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 #include <smgdef.h>
  66 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
  67 #include <efndef.h>
  68 #define NO_EFN EFN$C_ENF
  69 #else
  70 #define NO_EFN 0;
  71 #endif
  72
  73 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  74 int   decc$feature_get_index(const char *name);
  75 char* decc$feature_get_name(int index);
  76 int   decc$feature_get_value(int index, int mode);
  77 int   decc$feature_set_value(int index, int mode, int value);
  78 #else
  79 #include <unixlib.h>
  80 #endif
  81
  82 #pragma member_alignment save
  83 #pragma nomember_alignment longword
  84 struct item_list_3 {
  85         unsigned short len;
  86         unsigned short code;
  87         void * bufadr;
  88         unsigned short * retadr;
  89 };
  90 #pragma member_alignment restore
  91
  92 /* More specific prototype than in starlet_c.h makes programming errors
  93    more visible.
  94  */
  95 #ifdef sys$getdviw
  96 #undef sys$getdviw
  97 int sys$getdviw
  98        (unsigned long efn,
  99         unsigned short chan,
 100         const struct dsc$descriptor_s * devnam,
 101         const struct item_list_3 * itmlst,
 102         void * iosb,
 103         void * (astadr)(unsigned long),
 104         void * astprm,
 105         void * nullarg);
 106 #endif
 107
 108 #ifdef sys$get_security
 109 #undef sys$get_security
 110 int sys$get_security
 111        (const struct dsc$descriptor_s * clsnam,
 112         const struct dsc$descriptor_s * objnam,
 113         const unsigned int *objhan,
 114         unsigned int flags,
 115         const struct item_list_3 * itmlst,
 116         unsigned int * contxt,
 117         const unsigned int * acmode);
 118 #endif
 119
 120 #ifdef sys$set_security
 121 #undef sys$set_security
 122 int sys$set_security
 123        (const struct dsc$descriptor_s * clsnam,
 124         const struct dsc$descriptor_s * objnam,
 125         const unsigned int *objhan,
 126         unsigned int flags,
 127         const struct item_list_3 * itmlst,
 128         unsigned int * contxt,
 129         const unsigned int * acmode);
 130 #endif
 131
 132 #ifdef lib$find_image_symbol
 133 #undef lib$find_image_symbol
 134 int lib$find_image_symbol
 135        (const struct dsc$descriptor_s * imgname,
 136         const struct dsc$descriptor_s * symname,
 137         void * symval,
 138         const struct dsc$descriptor_s * defspec,
 139         unsigned long flag);
 140 #endif
 141
 142 #ifdef lib$rename_file
 143 #undef lib$rename_file
 144 int lib$rename_file
 145        (const struct dsc$descriptor_s * old_file_dsc,
 146         const struct dsc$descriptor_s * new_file_dsc,
 147         const struct dsc$descriptor_s * default_file_dsc,
 148         const struct dsc$descriptor_s * related_file_dsc,
 149         const unsigned long * flags,
 150         void * (success)(const struct dsc$descriptor_s * old_dsc,
 151                          const struct dsc$descriptor_s * new_dsc,
 152                          const void *),
 153         void * (error)(const struct dsc$descriptor_s * old_dsc,
 154                        const struct dsc$descriptor_s * new_dsc,
 155                        const int * rms_sts,
 156                        const int * rms_stv,
 157                        const int * error_src,
 158                        const void * usr_arg),
 159         int (confirm)(const struct dsc$descriptor_s * old_dsc,
 160                       const struct dsc$descriptor_s * new_dsc,
 161                       const void * old_fab,
 162                       const void * usr_arg),
 163         void * user_arg,
 164         struct dsc$descriptor_s * old_result_name_dsc,
 165         struct dsc$descriptor_s * new_result_name_dsc,
 166         unsigned long * file_scan_context);
 167 #endif
 168
 169 #if __CRTL_VER >= 70300000 && !defined(__VAX)
 170
 171 static int set_feature_default(const char *name, int value)
 172 {
 173     int status;
 174     int index;
 175
 176     index = decc$feature_get_index(name);
 177
 178     status = decc$feature_set_value(index, 1, value);
 179     if (index == -1 || (status == -1)) {
 180       return -1;
 181     }
 182
 183     status = decc$feature_get_value(index, 1);
 184     if (status != value) {
 185       return -1;
 186     }
 187
 188 return 0;
 189 }
 190 #endif
 191
 192 /* Older versions of ssdef.h don't have these */
 193 #ifndef SS$_INVFILFOROP
 194 #  define SS$_INVFILFOROP 3930
 195 #endif
 196 #ifndef SS$_NOSUCHOBJECT
 197 #  define SS$_NOSUCHOBJECT 2696
 198 #endif
 199
 200 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 201 #define PERLIO_NOT_STDIO 0
 202
 203 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 204  * code below needs to get to the underlying CRTL routines. */
 205 #define DONT_MASK_RTL_CALLS
 206 #include "EXTERN.h"
 207 #include "perl.h"
 208 #include "XSUB.h"
 209 /* Anticipating future expansion in lexical warnings . . . */
 210 #ifndef WARN_INTERNAL
 211 #  define WARN_INTERNAL WARN_MISC
 212 #endif
 213
 214 #ifdef VMS_LONGNAME_SUPPORT
 215 #include <libfildef.h>
 216 #endif
 217
 218 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 219 #  define RTL_USES_UTC 1
 220 #endif
 221
 222 /* Routine to create a decterm for use with the Perl debugger */
 223 /* No headers, this information was found in the Programming Concepts Manual */
 224
 225 static int (*decw_term_port)
 226    (const struct dsc$descriptor_s * display,
 227     const struct dsc$descriptor_s * setup_file,
 228     const struct dsc$descriptor_s * customization,
 229     struct dsc$descriptor_s * result_device_name,
 230     unsigned short * result_device_name_length,
 231     void * controller,
 232     void * char_buffer,
 233     void * char_change_buffer) = 0;
 234
 235 /* gcc's header files don't #define direct access macros
 236  * corresponding to VAXC's variant structs */
 237 #ifdef __GNUC__
 238 #  define uic$v_format uic$r_uic_form.uic$v_format
 239 #  define uic$v_group uic$r_uic_form.uic$v_group
 240 #  define uic$v_member uic$r_uic_form.uic$v_member
 241 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 242 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 243 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 244 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 245 #endif
 246
 247 #if defined(NEED_AN_H_ERRNO)
 248 dEXT int h_errno;
 249 #endif
 250
 251 #ifdef __DECC
 252 #pragma message disable pragma
 253 #pragma member_alignment save
 254 #pragma nomember_alignment longword
 255 #pragma message save
 256 #pragma message disable misalgndmem
 257 #endif
 258 struct itmlst_3 {
 259   unsigned short int buflen;
 260   unsigned short int itmcode;
 261   void *bufadr;
 262   unsigned short int *retlen;
 263 };
 264
 265 struct filescan_itmlst_2 {
 266     unsigned short length;
 267     unsigned short itmcode;
 268     char * component;
 269 };
 270
 271 struct vs_str_st {
 272     unsigned short length;
 273     char str[65536];
 274 };
 275
 276 #ifdef __DECC
 277 #pragma message restore
 278 #pragma member_alignment restore
 279 #endif
 280
 281 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 282 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 283 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 284 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 285 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 286 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 287 #define do_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 288 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 289 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 290 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 291 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 292 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 293
 294 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 295 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 296 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 297 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 298
 299 static char *  int_rmsexpand_vms(
 300     const char * filespec, char * outbuf, unsigned opts);
 301 static char * int_rmsexpand_tovms(
 302     const char * filespec, char * outbuf, unsigned opts);
 303 static char *int_tovmsspec
 304    (const char *path, char *buf, int dir_flag, int * utf8_flag);
 305 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
 306 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
 307
 308 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 309 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 310
 311 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 312  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 313  * the Perl facility.
 314  */
 315 #define PERL_LNM_MAX_ITER 10
 316
 317   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 318 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 319 #define MAX_DCL_SYMBOL          (8192)
 320 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 321 #else
 322 #define MAX_DCL_SYMBOL          (1024)
 323 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 324 #endif
 325
 326 static char *__mystrtolower(char *str)
 327 {
 328   if (str) for (; *str; ++str) *str= tolower(*str);
 329   return str;
 330 }
 331
 332 static struct dsc$descriptor_s fildevdsc =
 333   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 334 static struct dsc$descriptor_s crtlenvdsc =
 335   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 336 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 337 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 338 static struct dsc$descriptor_s **env_tables = defenv;
 339 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 340
 341 /* True if we shouldn't treat barewords as logicals during directory */
 342 /* munching */
 343 static int no_translate_barewords;
 344
 345 #ifndef RTL_USES_UTC
 346 static int tz_updated = 1;
 347 #endif
 348
 349 /* DECC Features that may need to affect how Perl interprets
 350  * displays filename information
 351  */
 352 static int decc_disable_to_vms_logname_translation = 1;
 353 static int decc_disable_posix_root = 1;
 354 int decc_efs_case_preserve = 0;
 355 static int decc_efs_charset = 0;
 356 static int decc_efs_charset_index = -1;
 357 static int decc_filename_unix_no_version = 0;
 358 static int decc_filename_unix_only = 0;
 359 int decc_filename_unix_report = 0;
 360 int decc_posix_compliant_pathnames = 0;
 361 int decc_readdir_dropdotnotype = 0;
 362 static int vms_process_case_tolerant = 1;
 363 int vms_vtf7_filenames = 0;
 364 int gnv_unix_shell = 0;
 365 static int vms_unlink_all_versions = 0;
 366 static int vms_posix_exit = 0;
 367
 368 /* bug workarounds if needed */
 369 int decc_bug_devnull = 1;
 370 int decc_dir_barename = 0;
 371 int vms_bug_stat_filename = 0;
 372
 373 static int vms_debug_on_exception = 0;
 374 static int vms_debug_fileify = 0;
 375
 376 /* Simple logical name translation */
 377 static int simple_trnlnm
 378    (const char * logname,
 379     char * value,
 380     int value_len)
 381 {
 382     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 383     const unsigned long attr = LNM$M_CASE_BLIND;
 384     struct dsc$descriptor_s name_dsc;
 385     int status;
 386     unsigned short result;
 387     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 388                                 {0, 0, 0, 0}};
 389
 390     name_dsc.dsc$w_length = strlen(logname);
 391     name_dsc.dsc$a_pointer = (char *)logname;
 392     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 393     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 394
 395     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 396
 397     if ($VMS_STATUS_SUCCESS(status)) {
 398
 399          /* Null terminate and return the string */
 400         /*--------------------------------------*/
 401         value[result] = 0;
 402         return result;
 403     }
 404
 405     return 0;
 406 }
 407
 408
 409 /* Is this a UNIX file specification?
 410  *   No longer a simple check with EFS file specs
 411  *   For now, not a full check, but need to
 412  *   handle POSIX ^UP^ specifications
 413  *   Fixing to handle ^/ cases would require
 414  *   changes to many other conversion routines.
 415  */
 416
 417 static int is_unix_filespec(const char *path)
 418 {
 419 int ret_val;
 420 const char * pch1;
 421
 422     ret_val = 0;
 423     if (strncmp(path,"\"^UP^",5) != 0) {
 424         pch1 = strchr(path, '/');
 425         if (pch1 != NULL)
 426             ret_val = 1;
 427         else {
 428
 429             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 430             if (decc_filename_unix_report || decc_filename_unix_only) {
 431             if (strcmp(path,".") == 0)
 432                 ret_val = 1;
 433             }
 434         }
 435     }
 436     return ret_val;
 437 }
 438
 439 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 440  */
 441
 442 static void ucs2_to_vtf7
 443    (char *outspec,
 444     unsigned long ucs2_char,
 445     int * output_cnt)
 446 {
 447 unsigned char * ucs_ptr;
 448 int hex;
 449
 450     ucs_ptr = (unsigned char *)&ucs2_char;
 451
 452     outspec[0] = '^';
 453     outspec[1] = 'U';
 454     hex = (ucs_ptr[1] >> 4) & 0xf;
 455     if (hex < 0xA)
 456         outspec[2] = hex + '0';
 457     else
 458         outspec[2] = (hex - 9) + 'A';
 459     hex = ucs_ptr[1] & 0xF;
 460     if (hex < 0xA)
 461         outspec[3] = hex + '0';
 462     else {
 463         outspec[3] = (hex - 9) + 'A';
 464     }
 465     hex = (ucs_ptr[0] >> 4) & 0xf;
 466     if (hex < 0xA)
 467         outspec[4] = hex + '0';
 468     else
 469         outspec[4] = (hex - 9) + 'A';
 470     hex = ucs_ptr[1] & 0xF;
 471     if (hex < 0xA)
 472         outspec[5] = hex + '0';
 473     else {
 474         outspec[5] = (hex - 9) + 'A';
 475     }
 476     *output_cnt = 6;
 477 }
 478
 479
 480 /* This handles the conversion of a UNIX extended character set to a ^
 481  * escaped VMS character.
 482  * in a UNIX file specification.
 483  *
 484  * The output count variable contains the number of characters added
 485  * to the output string.
 486  *
 487  * The return value is the number of characters read from the input string
 488  */
 489 static int copy_expand_unix_filename_escape
 490   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 491 {
 492 int count;
 493 int scnt;
 494 int utf8_flag;
 495
 496     utf8_flag = 0;
 497     if (utf8_fl)
 498       utf8_flag = *utf8_fl;
 499
 500     count = 0;
 501     *output_cnt = 0;
 502     if (*inspec >= 0x80) {
 503         if (utf8_fl && vms_vtf7_filenames) {
 504         unsigned long ucs_char;
 505
 506             ucs_char = 0;
 507
 508             if ((*inspec & 0xE0) == 0xC0) {
 509                 /* 2 byte Unicode */
 510                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 511                 if (ucs_char >= 0x80) {
 512                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 513                     return 2;
 514                 }
 515             } else if ((*inspec & 0xF0) == 0xE0) {
 516                 /* 3 byte Unicode */
 517                 ucs_char = ((inspec[0] & 0xF) << 12) +
 518                    ((inspec[1] & 0x3f) << 6) +
 519                    (inspec[2] & 0x3f);
 520                 if (ucs_char >= 0x800) {
 521                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 522                     return 3;
 523                 }
 524
 525 #if 0 /* I do not see longer sequences supported by OpenVMS */
 526       /* Maybe some one can fix this later */
 527             } else if ((*inspec & 0xF8) == 0xF0) {
 528                 /* 4 byte Unicode */
 529                 /* UCS-4 to UCS-2 */
 530             } else if ((*inspec & 0xFC) == 0xF8) {
 531                 /* 5 byte Unicode */
 532                 /* UCS-4 to UCS-2 */
 533             } else if ((*inspec & 0xFE) == 0xFC) {
 534                 /* 6 byte Unicode */
 535                 /* UCS-4 to UCS-2 */
 536 #endif
 537             }
 538         }
 539
 540         /* High bit set, but not a Unicode character! */
 541
 542         /* Non printing DECMCS or ISO Latin-1 character? */
 543         if (*inspec <= 0x9F) {
 544         int hex;
 545             outspec[0] = '^';
 546             outspec++;
 547             hex = (*inspec >> 4) & 0xF;
 548             if (hex < 0xA)
 549                 outspec[1] = hex + '0';
 550             else {
 551                 outspec[1] = (hex - 9) + 'A';
 552             }
 553             hex = *inspec & 0xF;
 554             if (hex < 0xA)
 555                 outspec[2] = hex + '0';
 556             else {
 557                 outspec[2] = (hex - 9) + 'A';
 558             }
 559             *output_cnt = 3;
 560             return 1;
 561         } else if (*inspec == 0xA0) {
 562             outspec[0] = '^';
 563             outspec[1] = 'A';
 564             outspec[2] = '0';
 565             *output_cnt = 3;
 566             return 1;
 567         } else if (*inspec == 0xFF) {
 568             outspec[0] = '^';
 569             outspec[1] = 'F';
 570             outspec[2] = 'F';
 571             *output_cnt = 3;
 572             return 1;
 573         }
 574         *outspec = *inspec;
 575         *output_cnt = 1;
 576         return 1;
 577     }
 578
 579     /* Is this a macro that needs to be passed through?
 580      * Macros start with $( and an alpha character, followed
 581      * by a string of alpha numeric characters ending with a )
 582      * If this does not match, then encode it as ODS-5.
 583      */
 584     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 585     int tcnt;
 586
 587         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 588             tcnt = 3;
 589             outspec[0] = inspec[0];
 590             outspec[1] = inspec[1];
 591             outspec[2] = inspec[2];
 592
 593             while(isalnum(inspec[tcnt]) ||
 594                   (inspec[2] == '.') || (inspec[2] == '_')) {
 595                 outspec[tcnt] = inspec[tcnt];
 596                 tcnt++;
 597             }
 598             if (inspec[tcnt] == ')') {
 599                 outspec[tcnt] = inspec[tcnt];
 600                 tcnt++;
 601                 *output_cnt = tcnt;
 602                 return tcnt;
 603             }
 604         }
 605     }
 606
 607     switch (*inspec) {
 608     case 0x7f:
 609         outspec[0] = '^';
 610         outspec[1] = '7';
 611         outspec[2] = 'F';
 612         *output_cnt = 3;
 613         return 1;
 614         break;
 615     case '?':
 616         if (decc_efs_charset == 0)
 617           outspec[0] = '%';
 618         else
 619           outspec[0] = '?';
 620         *output_cnt = 1;
 621         return 1;
 622         break;
 623     case '.':
 624     case '~':
 625     case '!':
 626     case '#':
 627     case '&':
 628     case '\'':
 629     case '`':
 630     case '(':
 631     case ')':
 632     case '+':
 633     case '@':
 634     case '{':
 635     case '}':
 636     case ',':
 637     case ';':
 638     case '[':
 639     case ']':
 640     case '%':
 641     case '^':
 642     case '\\':
 643         /* Don't escape again if following character is
 644          * already something we escape.
 645          */
 646         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 647             *outspec = *inspec;
 648             *output_cnt = 1;
 649             return 1;
 650             break;
 651         }
 652         /* But otherwise fall through and escape it. */
 653     case '=':
 654         /* Assume that this is to be escaped */
 655         outspec[0] = '^';
 656         outspec[1] = *inspec;
 657         *output_cnt = 2;
 658         return 1;
 659         break;
 660     case ' ': /* space */
 661         /* Assume that this is to be escaped */
 662         outspec[0] = '^';
 663         outspec[1] = '_';
 664         *output_cnt = 2;
 665         return 1;
 666         break;
 667     default:
 668         *outspec = *inspec;
 669         *output_cnt = 1;
 670         return 1;
 671         break;
 672     }
 673 }
 674
 675
 676 /* This handles the expansion of a '^' prefix to the proper character
 677  * in a UNIX file specification.
 678  *
 679  * The output count variable contains the number of characters added
 680  * to the output string.
 681  *
 682  * The return value is the number of characters read from the input
 683  * string
 684  */
 685 static int copy_expand_vms_filename_escape
 686   (char *outspec, const char *inspec, int *output_cnt)
 687 {
 688 int count;
 689 int scnt;
 690
 691     count = 0;
 692     *output_cnt = 0;
 693     if (*inspec == '^') {
 694         inspec++;
 695         switch (*inspec) {
 696         /* Spaces and non-trailing dots should just be passed through,
 697          * but eat the escape character.
 698          */
 699         case '.':
 700             *outspec = *inspec;
 701             count += 2;
 702             (*output_cnt)++;
 703             break;
 704         case '_': /* space */
 705             *outspec = ' ';
 706             count += 2;
 707             (*output_cnt)++;
 708             break;
 709         case '^':
 710             /* Hmm.  Better leave the escape escaped. */
 711             outspec[0] = '^';
 712             outspec[1] = '^';
 713             count += 2;
 714             (*output_cnt) += 2;
 715             break;
 716         case 'U': /* Unicode - FIX-ME this is wrong. */
 717             inspec++;
 718             count++;
 719             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 720             if (scnt == 4) {
 721                 unsigned int c1, c2;
 722                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 723                 outspec[0] == c1 & 0xff;
 724                 outspec[1] == c2 & 0xff;
 725                 if (scnt > 1) {
 726                     (*output_cnt) += 2;
 727                     count += 4;
 728                 }
 729             }
 730             else {
 731                 /* Error - do best we can to continue */
 732                 *outspec = 'U';
 733                 outspec++;
 734                 (*output_cnt++);
 735                 *outspec = *inspec;
 736                 count++;
 737                 (*output_cnt++);
 738             }
 739             break;
 740         default:
 741             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 742             if (scnt == 2) {
 743                 /* Hex encoded */
 744                 unsigned int c1;
 745                 scnt = sscanf(inspec, "%2x", &c1);
 746                 outspec[0] = c1 & 0xff;
 747                 if (scnt > 0) {
 748                     (*output_cnt++);
 749                     count += 2;
 750                 }
 751             }
 752             else {
 753                 *outspec = *inspec;
 754                 count++;
 755                 (*output_cnt++);
 756             }
 757         }
 758     }
 759     else {
 760         *outspec = *inspec;
 761         count++;
 762         (*output_cnt)++;
 763     }
 764     return count;
 765 }
 766
 767 #ifdef sys$filescan
 768 #undef sys$filescan
 769 int sys$filescan
 770    (const struct dsc$descriptor_s * srcstr,
 771     struct filescan_itmlst_2 * valuelist,
 772     unsigned long * fldflags,
 773     struct dsc$descriptor_s *auxout,
 774     unsigned short * retlen);
 775 #endif
 776
 777 /* vms_split_path - Verify that the input file specification is a
 778  * VMS format file specification, and provide pointers to the components of
 779  * it.  With EFS format filenames, this is virtually the only way to
 780  * parse a VMS path specification into components.
 781  *
 782  * If the sum of the components do not add up to the length of the
 783  * string, then the passed file specification is probably a UNIX style
 784  * path.
 785  */
 786 static int vms_split_path
 787    (const char * path,
 788     char * * volume,
 789     int * vol_len,
 790     char * * root,
 791     int * root_len,
 792     char * * dir,
 793     int * dir_len,
 794     char * * name,
 795     int * name_len,
 796     char * * ext,
 797     int * ext_len,
 798     char * * version,
 799     int * ver_len)
 800 {
 801 struct dsc$descriptor path_desc;
 802 int status;
 803 unsigned long flags;
 804 int ret_stat;
 805 struct filescan_itmlst_2 item_list[9];
 806 const int filespec = 0;
 807 const int nodespec = 1;
 808 const int devspec = 2;
 809 const int rootspec = 3;
 810 const int dirspec = 4;
 811 const int namespec = 5;
 812 const int typespec = 6;
 813 const int verspec = 7;
 814
 815     /* Assume the worst for an easy exit */
 816     ret_stat = -1;
 817     *volume = NULL;
 818     *vol_len = 0;
 819     *root = NULL;
 820     *root_len = 0;
 821     *dir = NULL;
 822     *dir_len;
 823     *name = NULL;
 824     *name_len = 0;
 825     *ext = NULL;
 826     *ext_len = 0;
 827     *version = NULL;
 828     *ver_len = 0;
 829
 830     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 831     path_desc.dsc$w_length = strlen(path);
 832     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 833     path_desc.dsc$b_class = DSC$K_CLASS_S;
 834
 835     /* Get the total length, if it is shorter than the string passed
 836      * then this was probably not a VMS formatted file specification
 837      */
 838     item_list[filespec].itmcode = FSCN$_FILESPEC;
 839     item_list[filespec].length = 0;
 840     item_list[filespec].component = NULL;
 841
 842     /* If the node is present, then it gets considered as part of the
 843      * volume name to hopefully make things simple.
 844      */
 845     item_list[nodespec].itmcode = FSCN$_NODE;
 846     item_list[nodespec].length = 0;
 847     item_list[nodespec].component = NULL;
 848
 849     item_list[devspec].itmcode = FSCN$_DEVICE;
 850     item_list[devspec].length = 0;
 851     item_list[devspec].component = NULL;
 852
 853     /* root is a special case,  adding it to either the directory or
 854      * the device components will probalby complicate things for the
 855      * callers of this routine, so leave it separate.
 856      */
 857     item_list[rootspec].itmcode = FSCN$_ROOT;
 858     item_list[rootspec].length = 0;
 859     item_list[rootspec].component = NULL;
 860
 861     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 862     item_list[dirspec].length = 0;
 863     item_list[dirspec].component = NULL;
 864
 865     item_list[namespec].itmcode = FSCN$_NAME;
 866     item_list[namespec].length = 0;
 867     item_list[namespec].component = NULL;
 868
 869     item_list[typespec].itmcode = FSCN$_TYPE;
 870     item_list[typespec].length = 0;
 871     item_list[typespec].component = NULL;
 872
 873     item_list[verspec].itmcode = FSCN$_VERSION;
 874     item_list[verspec].length = 0;
 875     item_list[verspec].component = NULL;
 876
 877     item_list[8].itmcode = 0;
 878     item_list[8].length = 0;
 879     item_list[8].component = NULL;
 880
 881     status = sys$filescan
 882        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 883         &flags, NULL, NULL);
 884     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 885
 886     /* If we parsed it successfully these two lengths should be the same */
 887     if (path_desc.dsc$w_length != item_list[filespec].length)
 888         return ret_stat;
 889
 890     /* If we got here, then it is a VMS file specification */
 891     ret_stat = 0;
 892
 893     /* set the volume name */
 894     if (item_list[nodespec].length > 0) {
 895         *volume = item_list[nodespec].component;
 896         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 897     }
 898     else {
 899         *volume = item_list[devspec].component;
 900         *vol_len = item_list[devspec].length;
 901     }
 902
 903     *root = item_list[rootspec].component;
 904     *root_len = item_list[rootspec].length;
 905
 906     *dir = item_list[dirspec].component;
 907     *dir_len = item_list[dirspec].length;
 908
 909     /* Now fun with versions and EFS file specifications
 910      * The parser can not tell the difference when a "." is a version
 911      * delimiter or a part of the file specification.
 912      */
 913     if ((decc_efs_charset) &&
 914         (item_list[verspec].length > 0) &&
 915         (item_list[verspec].component[0] == '.')) {
 916         *name = item_list[namespec].component;
 917         *name_len = item_list[namespec].length + item_list[typespec].length;
 918         *ext = item_list[verspec].component;
 919         *ext_len = item_list[verspec].length;
 920         *version = NULL;
 921         *ver_len = 0;
 922     }
 923     else {
 924         *name = item_list[namespec].component;
 925         *name_len = item_list[namespec].length;
 926         *ext = item_list[typespec].component;
 927         *ext_len = item_list[typespec].length;
 928         *version = item_list[verspec].component;
 929         *ver_len = item_list[verspec].length;
 930     }
 931     return ret_stat;
 932 }
 933
 934 /* Routine to determine if the file specification ends with .dir */
 935 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
 936
 937     /* e_len must be 4, and version must be <= 2 characters */
 938     if (e_len != 4 || vs_len > 2)
 939         return 0;
 940
 941     /* If a version number is present, it needs to be one */
 942     if ((vs_len == 2) && (vs_spec[1] != '1'))
 943         return 0;
 944
 945     /* Look for the DIR on the extension */
 946     if (vms_process_case_tolerant) {
 947         if ((toupper(e_spec[1]) == 'D') &&
 948             (toupper(e_spec[2]) == 'I') &&
 949             (toupper(e_spec[3]) == 'R')) {
 950             return 1;
 951         }
 952     } else {
 953         /* Directory extensions are supposed to be in upper case only */
 954         /* I would not be surprised if this rule can not be enforced */
 955         /* if and when someone fully debugs the case sensitive mode */
 956         if ((e_spec[1] == 'D') &&
 957             (e_spec[2] == 'I') &&
 958             (e_spec[3] == 'R')) {
 959             return 1;
 960         }
 961     }
 962     return 0;
 963 }
 964
 965
 966 /* my_maxidx
 967  * Routine to retrieve the maximum equivalence index for an input
 968  * logical name.  Some calls to this routine have no knowledge if
 969  * the variable is a logical or not.  So on error we return a max
 970  * index of zero.
 971  */
 972 /*{{{int my_maxidx(const char *lnm) */
 973 static int
 974 my_maxidx(const char *lnm)
 975 {
 976     int status;
 977     int midx;
 978     int attr = LNM$M_CASE_BLIND;
 979     struct dsc$descriptor lnmdsc;
 980     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 981                                 {0, 0, 0, 0}};
 982
 983     lnmdsc.dsc$w_length = strlen(lnm);
 984     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 985     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 986     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 987
 988     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 989     if ((status & 1) == 0)
 990        midx = 0;
 991
 992     return (midx);
 993 }
 994 /*}}}*/
 995
 996 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 997 int
 998 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 999   struct dsc$descriptor_s **tabvec, unsigned long int flags)
1000 {
1001     const char *cp1;
1002     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
1003     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
1004     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
1005     int midx;
1006     unsigned char acmode;
1007     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1008                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1009     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
1010                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
1011                                  {0, 0, 0, 0}};
1012     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1013 #if defined(PERL_IMPLICIT_CONTEXT)
1014     pTHX = NULL;
1015     if (PL_curinterp) {
1016       aTHX = PERL_GET_INTERP;
1017     } else {
1018       aTHX = NULL;
1019     }
1020 #endif
1021
1022     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
1023       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
1024     }
1025     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1026       *cp2 = _toupper(*cp1);
1027       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1028         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1029         return 0;
1030       }
1031     }
1032     lnmdsc.dsc$w_length = cp1 - lnm;
1033     lnmdsc.dsc$a_pointer = uplnm;
1034     uplnm[lnmdsc.dsc$w_length] = '\0';
1035     secure = flags & PERL__TRNENV_SECURE;
1036     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
1037     if (!tabvec || !*tabvec) tabvec = env_tables;
1038
1039     for (curtab = 0; tabvec[curtab]; curtab++) {
1040       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1041         if (!ivenv && !secure) {
1042           char *eq, *end;
1043           int i;
1044           if (!environ) {
1045             ivenv = 1;
1046 #if defined(PERL_IMPLICIT_CONTEXT)
1047             if (aTHX == NULL) {
1048                 fprintf(stderr,
1049                     "%%PERL-W-VMS_INIT Can't read CRTL environ\n");
1050             } else
1051 #endif
1052                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
1053             continue;
1054           }
1055           retsts = SS$_NOLOGNAM;
1056           for (i = 0; environ[i]; i++) {
1057             if ((eq = strchr(environ[i],'=')) &&
1058                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
1059                 !strncmp(environ[i],uplnm,eq - environ[i])) {
1060               eq++;
1061               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
1062               if (!eqvlen) continue;
1063               retsts = SS$_NORMAL;
1064               break;
1065             }
1066           }
1067           if (retsts != SS$_NOLOGNAM) break;
1068         }
1069       }
1070       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1071                !str$case_blind_compare(&tmpdsc,&clisym)) {
1072         if (!ivsym && !secure) {
1073           unsigned short int deflen = LNM$C_NAMLENGTH;
1074           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1075           /* dynamic dsc to accomodate possible long value */
1076           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
1077           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
1078           if (retsts & 1) {
1079             if (eqvlen > MAX_DCL_SYMBOL) {
1080               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
1081               eqvlen = MAX_DCL_SYMBOL;
1082               /* Special hack--we might be called before the interpreter's */
1083               /* fully initialized, in which case either thr or PL_curcop */
1084               /* might be bogus. We have to check, since ckWARN needs them */
1085               /* both to be valid if running threaded */
1086 #if defined(PERL_IMPLICIT_CONTEXT)
1087               if (aTHX == NULL) {
1088                   fprintf(stderr,
1089                      "%Perl-VMS-Init, Value of CLI symbol \"%s\" too long",lnm);
1090               } else
1091 #endif
1092                 if (ckWARN(WARN_MISC)) {
1093                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1094                 }
1095             }
1096             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1097           }
1098           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1099           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1100           if (retsts == LIB$_NOSUCHSYM) continue;
1101           break;
1102         }
1103       }
1104       else if (!ivlnm) {
1105         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1106           midx = my_maxidx(lnm);
1107           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1108             lnmlst[1].bufadr = cp2;
1109             eqvlen = 0;
1110             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1111             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1112             if (retsts == SS$_NOLOGNAM) break;
1113             /* PPFs have a prefix */
1114             if (
1115 #if INTSIZE == 4
1116                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1117 #endif
1118                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1119                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1120                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1121                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1122                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1123               memmove(eqv,eqv+4,eqvlen-4);
1124               eqvlen -= 4;
1125             }
1126             cp2 += eqvlen;
1127             *cp2 = '\0';
1128           }
1129           if ((retsts == SS$_IVLOGNAM) ||
1130               (retsts == SS$_NOLOGNAM)) { continue; }
1131         }
1132         else {
1133           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1134           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1135           if (retsts == SS$_NOLOGNAM) continue;
1136           eqv[eqvlen] = '\0';
1137         }
1138         eqvlen = strlen(eqv);
1139         break;
1140       }
1141     }
1142     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1143     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1144              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1145              retsts == SS$_NOLOGNAM) {
1146       set_errno(EINVAL);  set_vaxc_errno(retsts);
1147     }
1148     else _ckvmssts_noperl(retsts);
1149     return 0;
1150 }  /* end of vmstrnenv */
1151 /*}}}*/
1152
1153 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1154 /* Define as a function so we can access statics. */
1155 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1156 {
1157     int flags = 0;
1158
1159 #if defined(PERL_IMPLICIT_CONTEXT)
1160     if (aTHX != NULL)
1161 #endif
1162 #ifdef SECURE_INTERNAL_GETENV
1163         flags = (PL_curinterp ? PL_tainting : will_taint) ?
1164                  PERL__TRNENV_SECURE : 0;
1165 #endif
1166
1167     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1168 }
1169 /*}}}*/
1170
1171 /* my_getenv
1172  * Note: Uses Perl temp to store result so char * can be returned to
1173  * caller; this pointer will be invalidated at next Perl statement
1174  * transition.
1175  * We define this as a function rather than a macro in terms of my_getenv_len()
1176  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1177  * allocate SVs).
1178  */
1179 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1180 char *
1181 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1182 {
1183     const char *cp1;
1184     static char *__my_getenv_eqv = NULL;
1185     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1186     unsigned long int idx = 0;
1187     int trnsuccess, success, secure, saverr, savvmserr;
1188     int midx, flags;
1189     SV *tmpsv;
1190
1191     midx = my_maxidx(lnm) + 1;
1192
1193     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1194       /* Set up a temporary buffer for the return value; Perl will
1195        * clean it up at the next statement transition */
1196       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1197       if (!tmpsv) return NULL;
1198       eqv = SvPVX(tmpsv);
1199     }
1200     else {
1201       /* Assume no interpreter ==> single thread */
1202       if (__my_getenv_eqv != NULL) {
1203         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1204       }
1205       else {
1206         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1207       }
1208       eqv = __my_getenv_eqv;
1209     }
1210
1211     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1212     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1213       int len;
1214       getcwd(eqv,LNM$C_NAMLENGTH);
1215
1216       len = strlen(eqv);
1217
1218       /* Get rid of "000000/ in rooted filespecs */
1219       if (len > 7) {
1220         char * zeros;
1221         zeros = strstr(eqv, "/000000/");
1222         if (zeros != NULL) {
1223           int mlen;
1224           mlen = len - (zeros - eqv) - 7;
1225           memmove(zeros, &zeros[7], mlen);
1226           len = len - 7;
1227           eqv[len] = '\0';
1228         }
1229       }
1230       return eqv;
1231     }
1232     else {
1233       /* Impose security constraints only if tainting */
1234       if (sys) {
1235         /* Impose security constraints only if tainting */
1236         secure = PL_curinterp ? PL_tainting : will_taint;
1237         saverr = errno;  savvmserr = vaxc$errno;
1238       }
1239       else {
1240         secure = 0;
1241       }
1242
1243       flags =
1244 #ifdef SECURE_INTERNAL_GETENV
1245               secure ? PERL__TRNENV_SECURE : 0
1246 #else
1247               0
1248 #endif
1249       ;
1250
1251       /* For the getenv interface we combine all the equivalence names
1252        * of a search list logical into one value to acquire a maximum
1253        * value length of 255*128 (assuming %ENV is using logicals).
1254        */
1255       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1256
1257       /* If the name contains a semicolon-delimited index, parse it
1258        * off and make sure we only retrieve the equivalence name for
1259        * that index.  */
1260       if ((cp2 = strchr(lnm,';')) != NULL) {
1261         strcpy(uplnm,lnm);
1262         uplnm[cp2-lnm] = '\0';
1263         idx = strtoul(cp2+1,NULL,0);
1264         lnm = uplnm;
1265         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1266       }
1267
1268       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1269
1270       /* Discard NOLOGNAM on internal calls since we're often looking
1271        * for an optional name, and this "error" often shows up as the
1272        * (bogus) exit status for a die() call later on.  */
1273       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1274       return success ? eqv : NULL;
1275     }
1276
1277 }  /* end of my_getenv() */
1278 /*}}}*/
1279
1280
1281 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1282 char *
1283 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1284 {
1285     const char *cp1;
1286     char *buf, *cp2;
1287     unsigned long idx = 0;
1288     int midx, flags;
1289     static char *__my_getenv_len_eqv = NULL;
1290     int secure, saverr, savvmserr;
1291     SV *tmpsv;
1292
1293     midx = my_maxidx(lnm) + 1;
1294
1295     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1296       /* Set up a temporary buffer for the return value; Perl will
1297        * clean it up at the next statement transition */
1298       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1299       if (!tmpsv) return NULL;
1300       buf = SvPVX(tmpsv);
1301     }
1302     else {
1303       /* Assume no interpreter ==> single thread */
1304       if (__my_getenv_len_eqv != NULL) {
1305         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1306       }
1307       else {
1308         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1309       }
1310       buf = __my_getenv_len_eqv;
1311     }
1312
1313     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1314     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1315     char * zeros;
1316
1317       getcwd(buf,LNM$C_NAMLENGTH);
1318       *len = strlen(buf);
1319
1320       /* Get rid of "000000/ in rooted filespecs */
1321       if (*len > 7) {
1322       zeros = strstr(buf, "/000000/");
1323       if (zeros != NULL) {
1324         int mlen;
1325         mlen = *len - (zeros - buf) - 7;
1326         memmove(zeros, &zeros[7], mlen);
1327         *len = *len - 7;
1328         buf[*len] = '\0';
1329         }
1330       }
1331       return buf;
1332     }
1333     else {
1334       if (sys) {
1335         /* Impose security constraints only if tainting */
1336         secure = PL_curinterp ? PL_tainting : will_taint;
1337         saverr = errno;  savvmserr = vaxc$errno;
1338       }
1339       else {
1340         secure = 0;
1341       }
1342
1343       flags =
1344 #ifdef SECURE_INTERNAL_GETENV
1345               secure ? PERL__TRNENV_SECURE : 0
1346 #else
1347               0
1348 #endif
1349       ;
1350
1351       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1352
1353       if ((cp2 = strchr(lnm,';')) != NULL) {
1354         strcpy(buf,lnm);
1355         buf[cp2-lnm] = '\0';
1356         idx = strtoul(cp2+1,NULL,0);
1357         lnm = buf;
1358         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1359       }
1360
1361       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1362
1363       /* Get rid of "000000/ in rooted filespecs */
1364       if (*len > 7) {
1365       char * zeros;
1366         zeros = strstr(buf, "/000000/");
1367         if (zeros != NULL) {
1368           int mlen;
1369           mlen = *len - (zeros - buf) - 7;
1370           memmove(zeros, &zeros[7], mlen);
1371           *len = *len - 7;
1372           buf[*len] = '\0';
1373         }
1374       }
1375
1376       /* Discard NOLOGNAM on internal calls since we're often looking
1377        * for an optional name, and this "error" often shows up as the
1378        * (bogus) exit status for a die() call later on.  */
1379       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1380       return *len ? buf : NULL;
1381     }
1382
1383 }  /* end of my_getenv_len() */
1384 /*}}}*/
1385
1386 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1387
1388 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1389
1390 /*{{{ void prime_env_iter() */
1391 void
1392 prime_env_iter(void)
1393 /* Fill the %ENV associative array with all logical names we can
1394  * find, in preparation for iterating over it.
1395  */
1396 {
1397   static int primed = 0;
1398   HV *seenhv = NULL, *envhv;
1399   SV *sv = NULL;
1400   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1401   unsigned short int chan;
1402 #ifndef CLI$M_TRUSTED
1403 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1404 #endif
1405   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1406   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1407   long int i;
1408   bool have_sym = FALSE, have_lnm = FALSE;
1409   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1410   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1411   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1412   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1413   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1414 #if defined(PERL_IMPLICIT_CONTEXT)
1415   pTHX;
1416 #endif
1417 #if defined(USE_ITHREADS)
1418   static perl_mutex primenv_mutex;
1419   MUTEX_INIT(&primenv_mutex);
1420 #endif
1421
1422 #if defined(PERL_IMPLICIT_CONTEXT)
1423     /* We jump through these hoops because we can be called at */
1424     /* platform-specific initialization time, which is before anything is */
1425     /* set up--we can't even do a plain dTHX since that relies on the */
1426     /* interpreter structure to be initialized */
1427     if (PL_curinterp) {
1428       aTHX = PERL_GET_INTERP;
1429     } else {
1430       /* we never get here because the NULL pointer will cause the */
1431       /* several of the routines called by this routine to access violate */
1432
1433       /* This routine is only called by hv.c/hv_iterinit which has a */
1434       /* context, so the real fix may be to pass it through instead of */
1435       /* the hoops above */
1436       aTHX = NULL;
1437     }
1438 #endif
1439
1440   if (primed || !PL_envgv) return;
1441   MUTEX_LOCK(&primenv_mutex);
1442   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1443   envhv = GvHVn(PL_envgv);
1444   /* Perform a dummy fetch as an lval to insure that the hash table is
1445    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1446   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1447
1448   for (i = 0; env_tables[i]; i++) {
1449      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1450          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1451      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1452   }
1453   if (have_sym || have_lnm) {
1454     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1455     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1456     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1457     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1458   }
1459
1460   for (i--; i >= 0; i--) {
1461     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1462       char *start;
1463       int j;
1464       for (j = 0; environ[j]; j++) {
1465         if (!(start = strchr(environ[j],'='))) {
1466           if (ckWARN(WARN_INTERNAL))
1467             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1468         }
1469         else {
1470           start++;
1471           sv = newSVpv(start,0);
1472           SvTAINTED_on(sv);
1473           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1474         }
1475       }
1476       continue;
1477     }
1478     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1479              !str$case_blind_compare(&tmpdsc,&clisym)) {
1480       strcpy(cmd,"Show Symbol/Global *");
1481       cmddsc.dsc$w_length = 20;
1482       if (env_tables[i]->dsc$w_length == 12 &&
1483           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1484           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1485       flags = defflags | CLI$M_NOLOGNAM;
1486     }
1487     else {
1488       strcpy(cmd,"Show Logical *");
1489       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1490         strcat(cmd," /Table=");
1491         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1492         cmddsc.dsc$w_length = strlen(cmd);
1493       }
1494       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1495       flags = defflags | CLI$M_NOCLISYM;
1496     }
1497
1498     /* Create a new subprocess to execute each command, to exclude the
1499      * remote possibility that someone could subvert a mbx or file used
1500      * to write multiple commands to a single subprocess.
1501      */
1502     do {
1503       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1504                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1505       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1506       defflags &= ~CLI$M_TRUSTED;
1507     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1508     _ckvmssts(retsts);
1509     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1510     if (seenhv) SvREFCNT_dec(seenhv);
1511     seenhv = newHV();
1512     while (1) {
1513       char *cp1, *cp2, *key;
1514       unsigned long int sts, iosb[2], retlen, keylen;
1515       register U32 hash;
1516
1517       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1518       if (sts & 1) sts = iosb[0] & 0xffff;
1519       if (sts == SS$_ENDOFFILE) {
1520         int wakect = 0;
1521         while (substs == 0) { sys$hiber(); wakect++;}
1522         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1523         _ckvmssts(substs);
1524         break;
1525       }
1526       _ckvmssts(sts);
1527       retlen = iosb[0] >> 16;
1528       if (!retlen) continue;  /* blank line */
1529       buf[retlen] = '\0';
1530       if (iosb[1] != subpid) {
1531         if (iosb[1]) {
1532           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1533         }
1534         continue;
1535       }
1536       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1537         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1538
1539       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1540       if (*cp1 == '(' || /* Logical name table name */
1541           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1542       if (*cp1 == '"') cp1++;
1543       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1544       key = cp1;  keylen = cp2 - cp1;
1545       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1546       while (*cp2 && *cp2 != '=') cp2++;
1547       while (*cp2 && *cp2 == '=') cp2++;
1548       while (*cp2 && *cp2 == ' ') cp2++;
1549       if (*cp2 == '"') {  /* String translation; may embed "" */
1550         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1551         cp2++;  cp1--; /* Skip "" surrounding translation */
1552       }
1553       else {  /* Numeric translation */
1554         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1555         cp1--;  /* stop on last non-space char */
1556       }
1557       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1558         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1559         continue;
1560       }
1561       PERL_HASH(hash,key,keylen);
1562
1563       if (cp1 == cp2 && *cp2 == '.') {
1564         /* A single dot usually means an unprintable character, such as a null
1565          * to indicate a zero-length value.  Get the actual value to make sure.
1566          */
1567         char lnm[LNM$C_NAMLENGTH+1];
1568         char eqv[MAX_DCL_SYMBOL+1];
1569         int trnlen;
1570         strncpy(lnm, key, keylen);
1571         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1572         sv = newSVpvn(eqv, strlen(eqv));
1573       }
1574       else {
1575         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1576       }
1577
1578       SvTAINTED_on(sv);
1579       hv_store(envhv,key,keylen,sv,hash);
1580       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1581     }
1582     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1583       /* get the PPFs for this process, not the subprocess */
1584       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1585       char eqv[LNM$C_NAMLENGTH+1];
1586       int trnlen, i;
1587       for (i = 0; ppfs[i]; i++) {
1588         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1589         sv = newSVpv(eqv,trnlen);
1590         SvTAINTED_on(sv);
1591         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1592       }
1593     }
1594   }
1595   primed = 1;
1596   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1597   if (buf) Safefree(buf);
1598   if (seenhv) SvREFCNT_dec(seenhv);
1599   MUTEX_UNLOCK(&primenv_mutex);
1600   return;
1601
1602 }  /* end of prime_env_iter */
1603 /*}}}*/
1604
1605
1606 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1607 /* Define or delete an element in the same "environment" as
1608  * vmstrnenv().  If an element is to be deleted, it's removed from
1609  * the first place it's found.  If it's to be set, it's set in the
1610  * place designated by the first element of the table vector.
1611  * Like setenv() returns 0 for success, non-zero on error.
1612  */
1613 int
1614 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1615 {
1616     const char *cp1;
1617     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1618     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1619     int nseg = 0, j;
1620     unsigned long int retsts, usermode = PSL$C_USER;
1621     struct itmlst_3 *ile, *ilist;
1622     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1623                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1624                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1625     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1626     $DESCRIPTOR(local,"_LOCAL");
1627
1628     if (!lnm) {
1629         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1630         return SS$_IVLOGNAM;
1631     }
1632
1633     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1634       *cp2 = _toupper(*cp1);
1635       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1636         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1637         return SS$_IVLOGNAM;
1638       }
1639     }
1640     lnmdsc.dsc$w_length = cp1 - lnm;
1641     if (!tabvec || !*tabvec) tabvec = env_tables;
1642
1643     if (!eqv) {  /* we're deleting n element */
1644       for (curtab = 0; tabvec[curtab]; curtab++) {
1645         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1646         int i;
1647           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1648             if ((cp1 = strchr(environ[i],'=')) &&
1649                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1650                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1651 #ifdef HAS_SETENV
1652               return setenv(lnm,"",1) ? vaxc$errno : 0;
1653             }
1654           }
1655           ivenv = 1; retsts = SS$_NOLOGNAM;
1656 #else
1657               if (ckWARN(WARN_INTERNAL))
1658                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1659               ivenv = 1; retsts = SS$_NOSUCHPGM;
1660               break;
1661             }
1662           }
1663 #endif
1664         }
1665         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1666                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1667           unsigned int symtype;
1668           if (tabvec[curtab]->dsc$w_length == 12 &&
1669               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1670               !str$case_blind_compare(&tmpdsc,&local))
1671             symtype = LIB$K_CLI_LOCAL_SYM;
1672           else symtype = LIB$K_CLI_GLOBAL_SYM;
1673           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1674           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1675           if (retsts == LIB$_NOSUCHSYM) continue;
1676           break;
1677         }
1678         else if (!ivlnm) {
1679           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1680           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1681           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1682           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1683           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1684         }
1685       }
1686     }
1687     else {  /* we're defining a value */
1688       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1689 #ifdef HAS_SETENV
1690         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1691 #else
1692         if (ckWARN(WARN_INTERNAL))
1693           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1694         retsts = SS$_NOSUCHPGM;
1695 #endif
1696       }
1697       else {
1698         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1699         eqvdsc.dsc$w_length  = strlen(eqv);
1700         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1701             !str$case_blind_compare(&tmpdsc,&clisym)) {
1702           unsigned int symtype;
1703           if (tabvec[0]->dsc$w_length == 12 &&
1704               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1705                !str$case_blind_compare(&tmpdsc,&local))
1706             symtype = LIB$K_CLI_LOCAL_SYM;
1707           else symtype = LIB$K_CLI_GLOBAL_SYM;
1708           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1709         }
1710         else {
1711           if (!*eqv) eqvdsc.dsc$w_length = 1;
1712           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1713
1714             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1715             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1716               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1717                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1718               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1719               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1720             }
1721
1722             Newx(ilist,nseg+1,struct itmlst_3);
1723             ile = ilist;
1724             if (!ile) {
1725               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1726               return SS$_INSFMEM;
1727             }
1728             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1729
1730             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1731               ile->itmcode = LNM$_STRING;
1732               ile->bufadr = c;
1733               if ((j+1) == nseg) {
1734                 ile->buflen = strlen(c);
1735                 /* in case we are truncating one that's too long */
1736                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1737               }
1738               else {
1739                 ile->buflen = LNM$C_NAMLENGTH;
1740               }
1741             }
1742
1743             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1744             Safefree (ilist);
1745           }
1746           else {
1747             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1748           }
1749         }
1750       }
1751     }
1752     if (!(retsts & 1)) {
1753       switch (retsts) {
1754         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1755         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1756           set_errno(EVMSERR); break;
1757         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1758         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1759           set_errno(EINVAL); break;
1760         case SS$_NOPRIV:
1761           set_errno(EACCES); break;
1762         default:
1763           _ckvmssts(retsts);
1764           set_errno(EVMSERR);
1765        }
1766        set_vaxc_errno(retsts);
1767        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1768     }
1769     else {
1770       /* We reset error values on success because Perl does an hv_fetch()
1771        * before each hv_store(), and if the thing we're setting didn't
1772        * previously exist, we've got a leftover error message.  (Of course,
1773        * this fails in the face of
1774        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1775        * in that the error reported in $! isn't spurious,
1776        * but it's right more often than not.)
1777        */
1778       set_errno(0); set_vaxc_errno(retsts);
1779       return 0;
1780     }
1781
1782 }  /* end of vmssetenv() */
1783 /*}}}*/
1784
1785 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1786 /* This has to be a function since there's a prototype for it in proto.h */
1787 void
1788 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1789 {
1790     if (lnm && *lnm) {
1791       int len = strlen(lnm);
1792       if  (len == 7) {
1793         char uplnm[8];
1794         int i;
1795         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1796         if (!strcmp(uplnm,"DEFAULT")) {
1797           if (eqv && *eqv) my_chdir(eqv);
1798           return;
1799         }
1800     }
1801 #ifndef RTL_USES_UTC
1802     if (len == 6 || len == 2) {
1803       char uplnm[7];
1804       int i;
1805       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1806       uplnm[len] = '\0';
1807       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1808       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1809     }
1810 #endif
1811   }
1812   (void) vmssetenv(lnm,eqv,NULL);
1813 }
1814 /*}}}*/
1815
1816 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1817 /*  vmssetuserlnm
1818  *  sets a user-mode logical in the process logical name table
1819  *  used for redirection of sys$error
1820  */
1821 void
1822 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1823 {
1824     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1825     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1826     unsigned long int iss, attr = LNM$M_CONFINE;
1827     unsigned char acmode = PSL$C_USER;
1828     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1829                                  {0, 0, 0, 0}};
1830     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1831     d_name.dsc$w_length = strlen(name);
1832
1833     lnmlst[0].buflen = strlen(eqv);
1834     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1835
1836     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1837     if (!(iss&1)) lib$signal(iss);
1838 }
1839 /*}}}*/
1840
1841
1842 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1843 /* my_crypt - VMS password hashing
1844  * my_crypt() provides an interface compatible with the Unix crypt()
1845  * C library function, and uses sys$hash_password() to perform VMS
1846  * password hashing.  The quadword hashed password value is returned
1847  * as a NUL-terminated 8 character string.  my_crypt() does not change
1848  * the case of its string arguments; in order to match the behavior
1849  * of LOGINOUT et al., alphabetic characters in both arguments must
1850  *  be upcased by the caller.
1851  *
1852  * - fix me to call ACM services when available
1853  */
1854 char *
1855 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1856 {
1857 #   ifndef UAI$C_PREFERRED_ALGORITHM
1858 #     define UAI$C_PREFERRED_ALGORITHM 127
1859 #   endif
1860     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1861     unsigned short int salt = 0;
1862     unsigned long int sts;
1863     struct const_dsc {
1864         unsigned short int dsc$w_length;
1865         unsigned char      dsc$b_type;
1866         unsigned char      dsc$b_class;
1867         const char *       dsc$a_pointer;
1868     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1869        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1870     struct itmlst_3 uailst[3] = {
1871         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1872         { sizeof salt, UAI$_SALT,    &salt, 0},
1873         { 0,           0,            NULL,  NULL}};
1874     static char hash[9];
1875
1876     usrdsc.dsc$w_length = strlen(usrname);
1877     usrdsc.dsc$a_pointer = usrname;
1878     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1879       switch (sts) {
1880         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1881           set_errno(EACCES);
1882           break;
1883         case RMS$_RNF:
1884           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1885           break;
1886         default:
1887           set_errno(EVMSERR);
1888       }
1889       set_vaxc_errno(sts);
1890       if (sts != RMS$_RNF) return NULL;
1891     }
1892
1893     txtdsc.dsc$w_length = strlen(textpasswd);
1894     txtdsc.dsc$a_pointer = textpasswd;
1895     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1896       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1897     }
1898
1899     return (char *) hash;
1900
1901 }  /* end of my_crypt() */
1902 /*}}}*/
1903
1904
1905 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1906 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1907 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1908
1909 /* fixup barenames that are directories for internal use.
1910  * There have been problems with the consistent handling of UNIX
1911  * style directory names when routines are presented with a name that
1912  * has no directory delimitors at all.  So this routine will eventually
1913  * fix the issue.
1914  */
1915 static char * fixup_bare_dirnames(const char * name)
1916 {
1917   if (decc_disable_to_vms_logname_translation) {
1918 /* fix me */
1919   }
1920   return NULL;
1921 }
1922
1923 /* 8.3, remove() is now broken on symbolic links */
1924 static int rms_erase(const char * vmsname);
1925
1926
1927 /* mp_do_kill_file
1928  * A little hack to get around a bug in some implemenation of remove()
1929  * that do not know how to delete a directory
1930  *
1931  * Delete any file to which user has control access, regardless of whether
1932  * delete access is explicitly allowed.
1933  * Limitations: User must have write access to parent directory.
1934  *              Does not block signals or ASTs; if interrupted in midstream
1935  *              may leave file with an altered ACL.
1936  * HANDLE WITH CARE!
1937  */
1938 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1939 static int
1940 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1941 {
1942     char *vmsname;
1943     char *rslt;
1944     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1945     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1946     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1947     struct myacedef {
1948       unsigned char myace$b_length;
1949       unsigned char myace$b_type;
1950       unsigned short int myace$w_flags;
1951       unsigned long int myace$l_access;
1952       unsigned long int myace$l_ident;
1953     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1954                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1955       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1956      struct itmlst_3
1957        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1958                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1959        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1960        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1961        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1962        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1963
1964     /* Expand the input spec using RMS, since the CRTL remove() and
1965      * system services won't do this by themselves, so we may miss
1966      * a file "hiding" behind a logical name or search list. */
1967     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1968     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1969
1970     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1971     if (rslt == NULL) {
1972         PerlMem_free(vmsname);
1973         return -1;
1974       }
1975
1976     /* Erase the file */
1977     rmsts = rms_erase(vmsname);
1978
1979     /* Did it succeed */
1980     if ($VMS_STATUS_SUCCESS(rmsts)) {
1981         PerlMem_free(vmsname);
1982         return 0;
1983       }
1984
1985     /* If not, can changing protections help? */
1986     if (rmsts != RMS$_PRV) {
1987       set_vaxc_errno(rmsts);
1988       PerlMem_free(vmsname);
1989       return -1;
1990     }
1991
1992     /* No, so we get our own UIC to use as a rights identifier,
1993      * and the insert an ACE at the head of the ACL which allows us
1994      * to delete the file.
1995      */
1996     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1997     fildsc.dsc$w_length = strlen(vmsname);
1998     fildsc.dsc$a_pointer = vmsname;
1999     cxt = 0;
2000     newace.myace$l_ident = oldace.myace$l_ident;
2001     rmsts = -1;
2002     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
2003       switch (aclsts) {
2004         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
2005           set_errno(ENOENT); break;
2006         case RMS$_DIR:
2007           set_errno(ENOTDIR); break;
2008         case RMS$_DEV:
2009           set_errno(ENODEV); break;
2010         case RMS$_SYN: case SS$_INVFILFOROP:
2011           set_errno(EINVAL); break;
2012         case RMS$_PRV:
2013           set_errno(EACCES); break;
2014         default:
2015           _ckvmssts_noperl(aclsts);
2016       }
2017       set_vaxc_errno(aclsts);
2018       PerlMem_free(vmsname);
2019       return -1;
2020     }
2021     /* Grab any existing ACEs with this identifier in case we fail */
2022     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2023     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2024                     || fndsts == SS$_NOMOREACE ) {
2025       /* Add the new ACE . . . */
2026       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2027         goto yourroom;
2028
2029       rmsts = rms_erase(vmsname);
2030       if ($VMS_STATUS_SUCCESS(rmsts)) {
2031         rmsts = 0;
2032         }
2033         else {
2034         rmsts = -1;
2035         /* We blew it - dir with files in it, no write priv for
2036          * parent directory, etc.  Put things back the way they were. */
2037         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2038           goto yourroom;
2039         if (fndsts & 1) {
2040           addlst[0].bufadr = &oldace;
2041           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2042             goto yourroom;
2043         }
2044       }
2045     }
2046
2047     yourroom:
2048     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2049     /* We just deleted it, so of course it's not there.  Some versions of
2050      * VMS seem to return success on the unlock operation anyhow (after all
2051      * the unlock is successful), but others don't.
2052      */
2053     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2054     if (aclsts & 1) aclsts = fndsts;
2055     if (!(aclsts & 1)) {
2056       set_errno(EVMSERR);
2057       set_vaxc_errno(aclsts);
2058     }
2059
2060     PerlMem_free(vmsname);
2061     return rmsts;
2062
2063 }  /* end of kill_file() */
2064 /*}}}*/
2065
2066
2067 /*{{{int do_rmdir(char *name)*/
2068 int
2069 Perl_do_rmdir(pTHX_ const char *name)
2070 {
2071     char * dirfile;
2072     int retval;
2073     Stat_t st;
2074
2075     dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
2076     if (dirfile == NULL)
2077         _ckvmssts(SS$_INSFMEM);
2078
2079     /* Force to a directory specification */
2080     if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
2081         PerlMem_free(dirfile);
2082         return -1;
2083     }
2084     if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
2085         errno = ENOTDIR;
2086         retval = -1;
2087     }
2088     else
2089         retval = mp_do_kill_file(aTHX_ dirfile, 1);
2090
2091     PerlMem_free(dirfile);
2092     return retval;
2093
2094 }  /* end of do_rmdir */
2095 /*}}}*/
2096
2097 /* kill_file
2098  * Delete any file to which user has control access, regardless of whether
2099  * delete access is explicitly allowed.
2100  * Limitations: User must have write access to parent directory.
2101  *              Does not block signals or ASTs; if interrupted in midstream
2102  *              may leave file with an altered ACL.
2103  * HANDLE WITH CARE!
2104  */
2105 /*{{{int kill_file(char *name)*/
2106 int
2107 Perl_kill_file(pTHX_ const char *name)
2108 {
2109     char rspec[NAM$C_MAXRSS+1];
2110     char *tspec;
2111     Stat_t st;
2112     int rmsts;
2113
2114    /* Remove() is allowed to delete directories, according to the X/Open
2115     * specifications.
2116     * This may need special handling to work with the ACL hacks.
2117      */
2118    if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
2119         rmsts = Perl_do_rmdir(aTHX_ name);
2120         return rmsts;
2121     }
2122
2123    rmsts = mp_do_kill_file(aTHX_ name, 0);
2124
2125     return rmsts;
2126
2127 }  /* end of kill_file() */
2128 /*}}}*/
2129
2130
2131 /*{{{int my_mkdir(char *,Mode_t)*/
2132 int
2133 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2134 {
2135   STRLEN dirlen = strlen(dir);
2136
2137   /* zero length string sometimes gives ACCVIO */
2138   if (dirlen == 0) return -1;
2139
2140   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2141    * null file name/type.  However, it's commonplace under Unix,
2142    * so we'll allow it for a gain in portability.
2143    */
2144   if (dir[dirlen-1] == '/') {
2145     char *newdir = savepvn(dir,dirlen-1);
2146     int ret = mkdir(newdir,mode);
2147     Safefree(newdir);
2148     return ret;
2149   }
2150   else return mkdir(dir,mode);
2151 }  /* end of my_mkdir */
2152 /*}}}*/
2153
2154 /*{{{int my_chdir(char *)*/
2155 int
2156 Perl_my_chdir(pTHX_ const char *dir)
2157 {
2158   STRLEN dirlen = strlen(dir);
2159
2160   /* zero length string sometimes gives ACCVIO */
2161   if (dirlen == 0) return -1;
2162   const char *dir1;
2163
2164   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2165    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2166    * so that existing scripts do not need to be changed.
2167    */
2168   dir1 = dir;
2169   while ((dirlen > 0) && (*dir1 == ' ')) {
2170     dir1++;
2171     dirlen--;
2172   }
2173
2174   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2175    * that implies
2176    * null file name/type.  However, it's commonplace under Unix,
2177    * so we'll allow it for a gain in portability.
2178    *
2179    * - Preview- '/' will be valid soon on VMS
2180    */
2181   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2182     char *newdir = savepvn(dir1,dirlen-1);
2183     int ret = chdir(newdir);
2184     Safefree(newdir);
2185     return ret;
2186   }
2187   else return chdir(dir1);
2188 }  /* end of my_chdir */
2189 /*}}}*/
2190
2191
2192 /*{{{int my_chmod(char *, mode_t)*/
2193 int
2194 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2195 {
2196   STRLEN speclen = strlen(file_spec);
2197
2198   /* zero length string sometimes gives ACCVIO */
2199   if (speclen == 0) return -1;
2200
2201   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2202    * that implies null file name/type.  However, it's commonplace under Unix,
2203    * so we'll allow it for a gain in portability.
2204    *
2205    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2206    * in VMS file.dir notation.
2207    */
2208   if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2209     char *vms_src, *vms_dir, *rslt;
2210     int ret = -1;
2211     errno = EIO;
2212
2213     /* First convert this to a VMS format specification */
2214     vms_src = PerlMem_malloc(VMS_MAXRSS);
2215     if (vms_src == NULL)
2216         _ckvmssts_noperl(SS$_INSFMEM);
2217
2218     rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2219     if (rslt == NULL) {
2220         /* If we fail, then not a file specification */
2221         PerlMem_free(vms_src);
2222         errno = EIO;
2223         return -1;
2224     }
2225
2226     /* Now make it a directory spec so chmod is happy */
2227     vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2228     if (vms_dir == NULL)
2229         _ckvmssts_noperl(SS$_INSFMEM);
2230     rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2231     PerlMem_free(vms_src);
2232
2233     /* Now do it */
2234     if (rslt != NULL) {
2235         ret = chmod(vms_dir, mode);
2236     } else {
2237         errno = EIO;
2238     }
2239     PerlMem_free(vms_dir);
2240     return ret;
2241   }
2242   else return chmod(file_spec, mode);
2243 }  /* end of my_chmod */
2244 /*}}}*/
2245
2246
2247 /*{{{FILE *my_tmpfile()*/
2248 FILE *
2249 my_tmpfile(void)
2250 {
2251   FILE *fp;
2252   char *cp;
2253
2254   if ((fp = tmpfile())) return fp;
2255
2256   cp = PerlMem_malloc(L_tmpnam+24);
2257   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2258
2259   if (decc_filename_unix_only == 0)
2260     strcpy(cp,"Sys$Scratch:");
2261   else
2262     strcpy(cp,"/tmp/");
2263   tmpnam(cp+strlen(cp));
2264   strcat(cp,".Perltmp");
2265   fp = fopen(cp,"w+","fop=dlt");
2266   PerlMem_free(cp);
2267   return fp;
2268 }
2269 /*}}}*/
2270
2271
2272 #ifndef HOMEGROWN_POSIX_SIGNALS
2273 /*
2274  * The C RTL's sigaction fails to check for invalid signal numbers so we
2275  * help it out a bit.  The docs are correct, but the actual routine doesn't
2276  * do what the docs say it will.
2277  */
2278 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2279 int
2280 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2281                    struct sigaction* oact)
2282 {
2283   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2284         SETERRNO(EINVAL, SS$_INVARG);
2285         return -1;
2286   }
2287   return sigaction(sig, act, oact);
2288 }
2289 /*}}}*/
2290 #endif
2291
2292 #ifdef KILL_BY_SIGPRC
2293 #include <errnodef.h>
2294
2295 /* We implement our own kill() using the undocumented system service
2296    sys$sigprc for one of two reasons:
2297
2298    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2299    target process to do a sys$exit, which usually can't be handled
2300    gracefully...certainly not by Perl and the %SIG{} mechanism.
2301
2302    2.) If the kill() in the CRTL can't be called from a signal
2303    handler without disappearing into the ether, i.e., the signal
2304    it purportedly sends is never trapped. Still true as of VMS 7.3.
2305
2306    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2307    in the target process rather than calling sys$exit.
2308
2309    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2310    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2311    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2312    with condition codes C$_SIG0+nsig*8, catching the exception on the
2313    target process and resignaling with appropriate arguments.
2314
2315    But we don't have that VMS 7.0+ exception handler, so if you
2316    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2317
2318    Also note that SIGTERM is listed in the docs as being "unimplemented",
2319    yet always seems to be signaled with a VMS condition code of 4 (and
2320    correctly handled for that code).  So we hardwire it in.
2321
2322    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2323    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2324    than signalling with an unrecognized (and unhandled by CRTL) code.
2325 */
2326
2327 #define _MY_SIG_MAX 28
2328
2329 static unsigned int
2330 Perl_sig_to_vmscondition_int(int sig)
2331 {
2332     static unsigned int sig_code[_MY_SIG_MAX+1] =
2333     {
2334         0,                  /*  0 ZERO     */
2335         SS$_HANGUP,         /*  1 SIGHUP   */
2336         SS$_CONTROLC,       /*  2 SIGINT   */
2337         SS$_CONTROLY,       /*  3 SIGQUIT  */
2338         SS$_RADRMOD,        /*  4 SIGILL   */
2339         SS$_BREAK,          /*  5 SIGTRAP  */
2340         SS$_OPCCUS,         /*  6 SIGABRT  */
2341         SS$_COMPAT,         /*  7 SIGEMT   */
2342 #ifdef __VAX
2343         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2344 #else
2345         SS$_HPARITH,        /*  8 SIGFPE AXP */
2346 #endif
2347         SS$_ABORT,          /*  9 SIGKILL  */
2348         SS$_ACCVIO,         /* 10 SIGBUS   */
2349         SS$_ACCVIO,         /* 11 SIGSEGV  */
2350         SS$_BADPARAM,       /* 12 SIGSYS   */
2351         SS$_NOMBX,          /* 13 SIGPIPE  */
2352         SS$_ASTFLT,         /* 14 SIGALRM  */
2353         4,                  /* 15 SIGTERM  */
2354         0,                  /* 16 SIGUSR1  */
2355         0,                  /* 17 SIGUSR2  */
2356         0,                  /* 18 */
2357         0,                  /* 19 */
2358         0,                  /* 20 SIGCHLD  */
2359         0,                  /* 21 SIGCONT  */
2360         0,                  /* 22 SIGSTOP  */
2361         0,                  /* 23 SIGTSTP  */
2362         0,                  /* 24 SIGTTIN  */
2363         0,                  /* 25 SIGTTOU  */
2364         0,                  /* 26 */
2365         0,                  /* 27 */
2366         0                   /* 28 SIGWINCH  */
2367     };
2368
2369 #if __VMS_VER >= 60200000
2370     static int initted = 0;
2371     if (!initted) {
2372         initted = 1;
2373         sig_code[16] = C$_SIGUSR1;
2374         sig_code[17] = C$_SIGUSR2;
2375 #if __CRTL_VER >= 70000000
2376         sig_code[20] = C$_SIGCHLD;
2377 #endif
2378 #if __CRTL_VER >= 70300000
2379         sig_code[28] = C$_SIGWINCH;
2380 #endif
2381     }
2382 #endif
2383
2384     if (sig < _SIG_MIN) return 0;
2385     if (sig > _MY_SIG_MAX) return 0;
2386     return sig_code[sig];
2387 }
2388
2389 unsigned int
2390 Perl_sig_to_vmscondition(int sig)
2391 {
2392 #ifdef SS$_DEBUG
2393     if (vms_debug_on_exception != 0)
2394         lib$signal(SS$_DEBUG);
2395 #endif
2396     return Perl_sig_to_vmscondition_int(sig);
2397 }
2398
2399
2400 int
2401 Perl_my_kill(int pid, int sig)
2402 {
2403     dTHX;
2404     int iss;
2405     unsigned int code;
2406     int sys$sigprc(unsigned int *pidadr,
2407                      struct dsc$descriptor_s *prcname,
2408                      unsigned int code);
2409
2410      /* sig 0 means validate the PID */
2411     /*------------------------------*/
2412     if (sig == 0) {
2413         const unsigned long int jpicode = JPI$_PID;
2414         pid_t ret_pid;
2415         int status;
2416         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2417         if ($VMS_STATUS_SUCCESS(status))
2418            return 0;
2419         switch (status) {
2420         case SS$_NOSUCHNODE:
2421         case SS$_UNREACHABLE:
2422         case SS$_NONEXPR:
2423            errno = ESRCH;
2424            break;
2425         case SS$_NOPRIV:
2426            errno = EPERM;
2427            break;
2428         default:
2429            errno = EVMSERR;
2430         }
2431         vaxc$errno=status;
2432         return -1;
2433     }
2434
2435     code = Perl_sig_to_vmscondition_int(sig);
2436
2437     if (!code) {
2438         SETERRNO(EINVAL, SS$_BADPARAM);
2439         return -1;
2440     }
2441
2442     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2443      * signals are to be sent to multiple processes.
2444      *  pid = 0 - all processes in group except ones that the system exempts
2445      *  pid = -1 - all processes except ones that the system exempts
2446      *  pid = -n - all processes in group (abs(n)) except ...
2447      * For now, just report as not supported.
2448      */
2449
2450     if (pid <= 0) {
2451         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2452         return -1;
2453     }
2454
2455     iss = sys$sigprc((unsigned int *)&pid,0,code);
2456     if (iss&1) return 0;
2457
2458     switch (iss) {
2459       case SS$_NOPRIV:
2460         set_errno(EPERM);  break;
2461       case SS$_NONEXPR:
2462       case SS$_NOSUCHNODE:
2463       case SS$_UNREACHABLE:
2464         set_errno(ESRCH);  break;
2465       case SS$_INSFMEM:
2466         set_errno(ENOMEM); break;
2467       default:
2468         _ckvmssts_noperl(iss);
2469         set_errno(EVMSERR);
2470     }
2471     set_vaxc_errno(iss);
2472
2473     return -1;
2474 }
2475 #endif
2476
2477 /* Routine to convert a VMS status code to a UNIX status code.
2478 ** More tricky than it appears because of conflicting conventions with
2479 ** existing code.
2480 **
2481 ** VMS status codes are a bit mask, with the least significant bit set for
2482 ** success.
2483 **
2484 ** Special UNIX status of EVMSERR indicates that no translation is currently
2485 ** available, and programs should check the VMS status code.
2486 **
2487 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2488 ** decoding.
2489 */
2490
2491 #ifndef C_FACILITY_NO
2492 #define C_FACILITY_NO 0x350000
2493 #endif
2494 #ifndef DCL_IVVERB
2495 #define DCL_IVVERB 0x38090
2496 #endif
2497
2498 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2499 {
2500 int facility;
2501 int fac_sp;
2502 int msg_no;
2503 int msg_status;
2504 int unix_status;
2505
2506   /* Assume the best or the worst */
2507   if (vms_status & STS$M_SUCCESS)
2508     unix_status = 0;
2509   else
2510     unix_status = EVMSERR;
2511
2512   msg_status = vms_status & ~STS$M_CONTROL;
2513
2514   facility = vms_status & STS$M_FAC_NO;
2515   fac_sp = vms_status & STS$M_FAC_SP;
2516   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2517
2518   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2519     switch(msg_no) {
2520     case SS$_NORMAL:
2521         unix_status = 0;
2522         break;
2523     case SS$_ACCVIO:
2524         unix_status = EFAULT;
2525         break;
2526     case SS$_DEVOFFLINE:
2527         unix_status = EBUSY;
2528         break;
2529     case SS$_CLEARED:
2530         unix_status = ENOTCONN;
2531         break;
2532     case SS$_IVCHAN:
2533     case SS$_IVLOGNAM:
2534     case SS$_BADPARAM:
2535     case SS$_IVLOGTAB:
2536     case SS$_NOLOGNAM:
2537     case SS$_NOLOGTAB:
2538     case SS$_INVFILFOROP:
2539     case SS$_INVARG:
2540     case SS$_NOSUCHID:
2541     case SS$_IVIDENT:
2542         unix_status = EINVAL;
2543         break;
2544     case SS$_UNSUPPORTED:
2545         unix_status = ENOTSUP;
2546         break;
2547     case SS$_FILACCERR:
2548     case SS$_NOGRPPRV:
2549     case SS$_NOSYSPRV:
2550         unix_status = EACCES;
2551         break;
2552     case SS$_DEVICEFULL:
2553         unix_status = ENOSPC;
2554         break;
2555     case SS$_NOSUCHDEV:
2556         unix_status = ENODEV;
2557         break;
2558     case SS$_NOSUCHFILE:
2559     case SS$_NOSUCHOBJECT:
2560         unix_status = ENOENT;
2561         break;
2562     case SS$_ABORT:                                 /* Fatal case */
2563     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2564     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2565         unix_status = EINTR;
2566         break;
2567     case SS$_BUFFEROVF:
2568         unix_status = E2BIG;
2569         break;
2570     case SS$_INSFMEM:
2571         unix_status = ENOMEM;
2572         break;
2573     case SS$_NOPRIV:
2574         unix_status = EPERM;
2575         break;
2576     case SS$_NOSUCHNODE:
2577     case SS$_UNREACHABLE:
2578         unix_status = ESRCH;
2579         break;
2580     case SS$_NONEXPR:
2581         unix_status = ECHILD;
2582         break;
2583     default:
2584         if ((facility == 0) && (msg_no < 8)) {
2585           /* These are not real VMS status codes so assume that they are
2586           ** already UNIX status codes
2587           */
2588           unix_status = msg_no;
2589           break;
2590         }
2591     }
2592   }
2593   else {
2594     /* Translate a POSIX exit code to a UNIX exit code */
2595     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2596         unix_status = (msg_no & 0x07F8) >> 3;
2597     }
2598     else {
2599
2600          /* Documented traditional behavior for handling VMS child exits */
2601         /*--------------------------------------------------------------*/
2602         if (child_flag != 0) {
2603
2604              /* Success / Informational return 0 */
2605             /*----------------------------------*/
2606             if (msg_no & STS$K_SUCCESS)
2607                 return 0;
2608
2609              /* Warning returns 1 */
2610             /*-------------------*/
2611             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2612                 return 1;
2613
2614              /* Everything else pass through the severity bits */
2615             /*------------------------------------------------*/
2616             return (msg_no & STS$M_SEVERITY);
2617         }
2618
2619          /* Normal VMS status to ERRNO mapping attempt */
2620         /*--------------------------------------------*/
2621         switch(msg_status) {
2622         /* case RMS$_EOF: */ /* End of File */
2623         case RMS$_FNF:  /* File Not Found */
2624         case RMS$_DNF:  /* Dir Not Found */
2625                 unix_status = ENOENT;
2626                 break;
2627         case RMS$_RNF:  /* Record Not Found */
2628                 unix_status = ESRCH;
2629                 break;
2630         case RMS$_DIR:
2631                 unix_status = ENOTDIR;
2632                 break;
2633         case RMS$_DEV:
2634                 unix_status = ENODEV;
2635                 break;
2636         case RMS$_IFI:
2637         case RMS$_FAC:
2638         case RMS$_ISI:
2639                 unix_status = EBADF;
2640                 break;
2641         case RMS$_FEX:
2642                 unix_status = EEXIST;
2643                 break;
2644         case RMS$_SYN:
2645         case RMS$_FNM:
2646         case LIB$_INVSTRDES:
2647         case LIB$_INVARG:
2648         case LIB$_NOSUCHSYM:
2649         case LIB$_INVSYMNAM:
2650         case DCL_IVVERB:
2651                 unix_status = EINVAL;
2652                 break;
2653         case CLI$_BUFOVF:
2654         case RMS$_RTB:
2655         case CLI$_TKNOVF:
2656         case CLI$_RSLOVF:
2657                 unix_status = E2BIG;
2658                 break;
2659         case RMS$_PRV:  /* No privilege */
2660         case RMS$_ACC:  /* ACP file access failed */
2661         case RMS$_WLK:  /* Device write locked */
2662                 unix_status = EACCES;
2663                 break;
2664         case RMS$_MKD:  /* Failed to mark for delete */
2665                 unix_status = EPERM;
2666                 break;
2667         /* case RMS$_NMF: */  /* No more files */
2668         }
2669     }
2670   }
2671
2672   return unix_status;
2673 }
2674
2675 /* Try to guess at what VMS error status should go with a UNIX errno
2676  * value.  This is hard to do as there could be many possible VMS
2677  * error statuses that caused the errno value to be set.
2678  */
2679
2680 int Perl_unix_status_to_vms(int unix_status)
2681 {
2682 int test_unix_status;
2683
2684      /* Trivial cases first */
2685     /*---------------------*/
2686     if (unix_status == EVMSERR)
2687         return vaxc$errno;
2688
2689      /* Is vaxc$errno sane? */
2690     /*---------------------*/
2691     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2692     if (test_unix_status == unix_status)
2693         return vaxc$errno;
2694
2695      /* If way out of range, must be VMS code already */
2696     /*-----------------------------------------------*/
2697     if (unix_status > EVMSERR)
2698         return unix_status;
2699
2700      /* If out of range, punt */
2701     /*-----------------------*/
2702     if (unix_status > __ERRNO_MAX)
2703         return SS$_ABORT;
2704
2705
2706      /* Ok, now we have to do it the hard way. */
2707     /*----------------------------------------*/
2708     switch(unix_status) {
2709     case 0:     return SS$_NORMAL;
2710     case EPERM: return SS$_NOPRIV;
2711     case ENOENT: return SS$_NOSUCHOBJECT;
2712     case ESRCH: return SS$_UNREACHABLE;
2713     case EINTR: return SS$_ABORT;
2714     /* case EIO: */
2715     /* case ENXIO:  */
2716     case E2BIG: return SS$_BUFFEROVF;
2717     /* case ENOEXEC */
2718     case EBADF: return RMS$_IFI;
2719     case ECHILD: return SS$_NONEXPR;
2720     /* case EAGAIN */
2721     case ENOMEM: return SS$_INSFMEM;
2722     case EACCES: return SS$_FILACCERR;
2723     case EFAULT: return SS$_ACCVIO;
2724     /* case ENOTBLK */
2725     case EBUSY: return SS$_DEVOFFLINE;
2726     case EEXIST: return RMS$_FEX;
2727     /* case EXDEV */
2728     case ENODEV: return SS$_NOSUCHDEV;
2729     case ENOTDIR: return RMS$_DIR;
2730     /* case EISDIR */
2731     case EINVAL: return SS$_INVARG;
2732     /* case ENFILE */
2733     /* case EMFILE */
2734     /* case ENOTTY */
2735     /* case ETXTBSY */
2736     /* case EFBIG */
2737     case ENOSPC: return SS$_DEVICEFULL;
2738     case ESPIPE: return LIB$_INVARG;
2739     /* case EROFS: */
2740     /* case EMLINK: */
2741     /* case EPIPE: */
2742     /* case EDOM */
2743     case ERANGE: return LIB$_INVARG;
2744     /* case EWOULDBLOCK */
2745     /* case EINPROGRESS */
2746     /* case EALREADY */
2747     /* case ENOTSOCK */
2748     /* case EDESTADDRREQ */
2749     /* case EMSGSIZE */
2750     /* case EPROTOTYPE */
2751     /* case ENOPROTOOPT */
2752     /* case EPROTONOSUPPORT */
2753     /* case ESOCKTNOSUPPORT */
2754     /* case EOPNOTSUPP */
2755     /* case EPFNOSUPPORT */
2756     /* case EAFNOSUPPORT */
2757     /* case EADDRINUSE */
2758     /* case EADDRNOTAVAIL */
2759     /* case ENETDOWN */
2760     /* case ENETUNREACH */
2761     /* case ENETRESET */
2762     /* case ECONNABORTED */
2763     /* case ECONNRESET */
2764     /* case ENOBUFS */
2765     /* case EISCONN */
2766     case ENOTCONN: return SS$_CLEARED;
2767     /* case ESHUTDOWN */
2768     /* case ETOOMANYREFS */
2769     /* case ETIMEDOUT */
2770     /* case ECONNREFUSED */
2771     /* case ELOOP */
2772     /* case ENAMETOOLONG */
2773     /* case EHOSTDOWN */
2774     /* case EHOSTUNREACH */
2775     /* case ENOTEMPTY */
2776     /* case EPROCLIM */
2777     /* case EUSERS  */
2778     /* case EDQUOT  */
2779     /* case ENOMSG  */
2780     /* case EIDRM */
2781     /* case EALIGN */
2782     /* case ESTALE */
2783     /* case EREMOTE */
2784     /* case ENOLCK */
2785     /* case ENOSYS */
2786     /* case EFTYPE */
2787     /* case ECANCELED */
2788     /* case EFAIL */
2789     /* case EINPROG */
2790     case ENOTSUP:
2791         return SS$_UNSUPPORTED;
2792     /* case EDEADLK */
2793     /* case ENWAIT */
2794     /* case EILSEQ */
2795     /* case EBADCAT */
2796     /* case EBADMSG */
2797     /* case EABANDONED */
2798     default:
2799         return SS$_ABORT; /* punt */
2800     }
2801
2802   return SS$_ABORT; /* Should not get here */
2803 }
2804
2805
2806 /* default piping mailbox size */
2807 #define PERL_BUFSIZ        512
2808
2809
2810 static void
2811 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2812 {
2813   unsigned long int mbxbufsiz;
2814   static unsigned long int syssize = 0;
2815   unsigned long int dviitm = DVI$_DEVNAM;
2816   char csize[LNM$C_NAMLENGTH+1];
2817   int sts;
2818
2819   if (!syssize) {
2820     unsigned long syiitm = SYI$_MAXBUF;
2821     /*
2822      * Get the SYSGEN parameter MAXBUF
2823      *
2824      * If the logical 'PERL_MBX_SIZE' is defined
2825      * use the value of the logical instead of PERL_BUFSIZ, but
2826      * keep the size between 128 and MAXBUF.
2827      *
2828      */
2829     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2830   }
2831
2832   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2833       mbxbufsiz = atoi(csize);
2834   } else {
2835       mbxbufsiz = PERL_BUFSIZ;
2836   }
2837   if (mbxbufsiz < 128) mbxbufsiz = 128;
2838   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2839
2840   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2841
2842   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2843   _ckvmssts_noperl(sts);
2844   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2845
2846 }  /* end of create_mbx() */
2847
2848
2849 /*{{{  my_popen and my_pclose*/
2850
2851 typedef struct _iosb           IOSB;
2852 typedef struct _iosb*         pIOSB;
2853 typedef struct _pipe           Pipe;
2854 typedef struct _pipe*         pPipe;
2855 typedef struct pipe_details    Info;
2856 typedef struct pipe_details*  pInfo;
2857 typedef struct _srqp            RQE;
2858 typedef struct _srqp*          pRQE;
2859 typedef struct _tochildbuf      CBuf;
2860 typedef struct _tochildbuf*    pCBuf;
2861
2862 struct _iosb {
2863     unsigned short status;
2864     unsigned short count;
2865     unsigned long  dvispec;
2866 };
2867
2868 #pragma member_alignment save
2869 #pragma nomember_alignment quadword
2870 struct _srqp {          /* VMS self-relative queue entry */
2871     unsigned long qptr[2];
2872 };
2873 #pragma member_alignment restore
2874 static RQE  RQE_ZERO = {0,0};
2875
2876 struct _tochildbuf {
2877     RQE             q;
2878     int             eof;
2879     unsigned short  size;
2880     char            *buf;
2881 };
2882
2883 struct _pipe {
2884     RQE            free;
2885     RQE            wait;
2886     int            fd_out;
2887     unsigned short chan_in;
2888     unsigned short chan_out;
2889     char          *buf;
2890     unsigned int   bufsize;
2891     IOSB           iosb;
2892     IOSB           iosb2;
2893     int           *pipe_done;
2894     int            retry;
2895     int            type;
2896     int            shut_on_empty;
2897     int            need_wake;
2898     pPipe         *home;
2899     pInfo          info;
2900     pCBuf          curr;
2901     pCBuf          curr2;
2902 #if defined(PERL_IMPLICIT_CONTEXT)
2903     void            *thx;           /* Either a thread or an interpreter */
2904                                     /* pointer, depending on how we're built */
2905 #endif
2906 };
2907
2908
2909 struct pipe_details
2910 {
2911     pInfo           next;
2912     PerlIO *fp;  /* file pointer to pipe mailbox */
2913     int useFILE; /* using stdio, not perlio */
2914     int pid;   /* PID of subprocess */
2915     int mode;  /* == 'r' if pipe open for reading */
2916     int done;  /* subprocess has completed */
2917     int waiting; /* waiting for completion/closure */
2918     int             closing;        /* my_pclose is closing this pipe */
2919     unsigned long   completion;     /* termination status of subprocess */
2920     pPipe           in;             /* pipe in to sub */
2921     pPipe           out;            /* pipe out of sub */
2922     pPipe           err;            /* pipe of sub's sys$error */
2923     int             in_done;        /* true when in pipe finished */
2924     int             out_done;
2925     int             err_done;
2926     unsigned short  xchan;          /* channel to debug xterm */
2927     unsigned short  xchan_valid;    /* channel is assigned */
2928 };
2929
2930 struct exit_control_block
2931 {
2932     struct exit_control_block *flink;
2933     unsigned long int   (*exit_routine)();
2934     unsigned long int arg_count;
2935     unsigned long int *status_address;
2936     unsigned long int exit_status;
2937 };
2938
2939 typedef struct _closed_pipes    Xpipe;
2940 typedef struct _closed_pipes*  pXpipe;
2941
2942 struct _closed_pipes {
2943     int             pid;            /* PID of subprocess */
2944     unsigned long   completion;     /* termination status of subprocess */
2945 };
2946 #define NKEEPCLOSED 50
2947 static Xpipe closed_list[NKEEPCLOSED];
2948 static int   closed_index = 0;
2949 static int   closed_num = 0;
2950
2951 #define RETRY_DELAY     "0 ::0.20"
2952 #define MAX_RETRY              50
2953
2954 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2955 static unsigned long mypid;
2956 static unsigned long delaytime[2];
2957
2958 static pInfo open_pipes = NULL;
2959 static $DESCRIPTOR(nl_desc, "NL:");
2960
2961 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2962
2963
2964
2965 static unsigned long int
2966 pipe_exit_routine()
2967 {
2968     pInfo info;
2969     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2970     int sts, did_stuff, need_eof, j;
2971
2972    /*
2973     * Flush any pending i/o, but since we are in process run-down, be
2974     * careful about referencing PerlIO structures that may already have
2975     * been deallocated.  We may not even have an interpreter anymore.
2976     */
2977     info = open_pipes;
2978     while (info) {
2979         if (info->fp) {
2980 #if defined(PERL_IMPLICIT_CONTEXT)
2981            /* We need to use the Perl context of the thread that created */
2982            /* the pipe. */
2983            pTHX;
2984            if (info->err)
2985                aTHX = info->err->thx;
2986            else if (info->out)
2987                aTHX = info->out->thx;
2988            else if (info->in)
2989                aTHX = info->in->thx;
2990 #endif
2991            if (!info->useFILE
2992 #if defined(USE_ITHREADS)
2993              && my_perl
2994 #endif
2995              && PL_perlio_fd_refcnt)
2996                PerlIO_flush(info->fp);
2997            else
2998                fflush((FILE *)info->fp);
2999         }
3000         info = info->next;
3001     }
3002
3003     /*
3004      next we try sending an EOF...ignore if doesn't work, make sure we
3005      don't hang
3006     */
3007     did_stuff = 0;
3008     info = open_pipes;
3009
3010     while (info) {
3011       int need_eof;
3012       _ckvmssts_noperl(sys$setast(0));
3013       if (info->in && !info->in->shut_on_empty) {
3014         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3015                                  0, 0, 0, 0, 0, 0));
3016         info->waiting = 1;
3017         did_stuff = 1;
3018       }
3019       _ckvmssts_noperl(sys$setast(1));
3020       info = info->next;
3021     }
3022
3023     /* wait for EOF to have effect, up to ~ 30 sec [default] */
3024
3025     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3026         int nwait = 0;
3027
3028         info = open_pipes;
3029         while (info) {
3030           _ckvmssts_noperl(sys$setast(0));
3031           if (info->waiting && info->done)
3032                 info->waiting = 0;
3033           nwait += info->waiting;
3034           _ckvmssts_noperl(sys$setast(1));
3035           info = info->next;
3036         }
3037         if (!nwait) break;
3038         sleep(1);
3039     }
3040
3041     did_stuff = 0;
3042     info = open_pipes;
3043     while (info) {
3044       _ckvmssts_noperl(sys$setast(0));
3045       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3046         sts = sys$forcex(&info->pid,0,&abort);
3047         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3048         did_stuff = 1;
3049       }
3050       _ckvmssts_noperl(sys$setast(1));
3051       info = info->next;
3052     }
3053
3054     /* again, wait for effect */
3055
3056     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3057         int nwait = 0;
3058
3059         info = open_pipes;
3060         while (info) {
3061           _ckvmssts_noperl(sys$setast(0));
3062           if (info->waiting && info->done)
3063                 info->waiting = 0;
3064           nwait += info->waiting;
3065           _ckvmssts_noperl(sys$setast(1));
3066           info = info->next;
3067         }
3068         if (!nwait) break;
3069         sleep(1);
3070     }
3071
3072     info = open_pipes;
3073     while (info) {
3074       _ckvmssts_noperl(sys$setast(0));
3075       if (!info->done) {  /* We tried to be nice . . . */
3076         sts = sys$delprc(&info->pid,0);
3077         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3078         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3079       }
3080       _ckvmssts_noperl(sys$setast(1));
3081       info = info->next;
3082     }
3083
3084     while(open_pipes) {
3085
3086 #if defined(PERL_IMPLICIT_CONTEXT)
3087       /* We need to use the Perl context of the thread that created */
3088       /* the pipe. */
3089       pTHX;
3090       if (open_pipes->err)
3091           aTHX = open_pipes->err->thx;
3092       else if (open_pipes->out)
3093           aTHX = open_pipes->out->thx;
3094       else if (open_pipes->in)
3095           aTHX = open_pipes->in->thx;
3096 #endif
3097       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3098       else if (!(sts & 1)) retsts = sts;
3099     }
3100     return retsts;
3101 }
3102
3103 static struct exit_control_block pipe_exitblock =
3104        {(struct exit_control_block *) 0,
3105         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3106
3107 static void pipe_mbxtofd_ast(pPipe p);
3108 static void pipe_tochild1_ast(pPipe p);
3109 static void pipe_tochild2_ast(pPipe p);
3110
3111 static void
3112 popen_completion_ast(pInfo info)
3113 {
3114   pInfo i = open_pipes;
3115   int iss;
3116   int sts;
3117   pXpipe x;
3118
3119   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3120   closed_list[closed_index].pid = info->pid;
3121   closed_list[closed_index].completion = info->completion;
3122   closed_index++;
3123   if (closed_index == NKEEPCLOSED)
3124     closed_index = 0;
3125   closed_num++;
3126
3127   while (i) {
3128     if (i == info) break;
3129     i = i->next;
3130   }
3131   if (!i) return;       /* unlinked, probably freed too */
3132
3133   info->done = TRUE;
3134
3135 /*
3136     Writing to subprocess ...
3137             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3138
3139             chan_out may be waiting for "done" flag, or hung waiting
3140             for i/o completion to child...cancel the i/o.  This will
3141             put it into "snarf mode" (done but no EOF yet) that discards
3142             input.
3143
3144     Output from subprocess (stdout, stderr) needs to be flushed and
3145     shut down.   We try sending an EOF, but if the mbx is full the pipe
3146     routine should still catch the "shut_on_empty" flag, telling it to
3147     use immediate-style reads so that "mbx empty" -> EOF.
3148
3149
3150 */
3151   if (info->in && !info->in_done) {               /* only for mode=w */
3152         if (info->in->shut_on_empty && info->in->need_wake) {
3153             info->in->need_wake = FALSE;
3154             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3155         } else {
3156             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3157         }
3158   }
3159
3160   if (info->out && !info->out_done) {             /* were we also piping output? */
3161       info->out->shut_on_empty = TRUE;
3162       iss = sys$qio(0,info->out->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
3167   if (info->err && !info->err_done) {        /* we were piping stderr */
3168         info->err->shut_on_empty = TRUE;
3169         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3170         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3171         _ckvmssts_noperl(iss);
3172   }
3173   _ckvmssts_noperl(sys$setef(pipe_ef));
3174
3175 }
3176
3177 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3178 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3179
3180 /*
3181     we actually differ from vmstrnenv since we use this to
3182     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3183     are pointing to the same thing
3184 */
3185
3186 static unsigned short
3187 popen_translate(pTHX_ char *logical, char *result)
3188 {
3189     int iss;
3190     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3191     $DESCRIPTOR(d_log,"");
3192     struct _il3 {
3193         unsigned short length;
3194         unsigned short code;
3195         char *         buffer_addr;
3196         unsigned short *retlenaddr;
3197     } itmlst[2];
3198     unsigned short l, ifi;
3199
3200     d_log.dsc$a_pointer = logical;
3201     d_log.dsc$w_length  = strlen(logical);
3202
3203     itmlst[0].code = LNM$_STRING;
3204     itmlst[0].length = 255;
3205     itmlst[0].buffer_addr = result;
3206     itmlst[0].retlenaddr = &l;
3207
3208     itmlst[1].code = 0;
3209     itmlst[1].length = 0;
3210     itmlst[1].buffer_addr = 0;
3211     itmlst[1].retlenaddr = 0;
3212
3213     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3214     if (iss == SS$_NOLOGNAM) {
3215         iss = SS$_NORMAL;
3216         l = 0;
3217     }
3218     if (!(iss&1)) lib$signal(iss);
3219     result[l] = '\0';
3220 /*
3221     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3222     strip it off and return the ifi, if any
3223 */
3224     ifi  = 0;
3225     if (result[0] == 0x1b && result[1] == 0x00) {
3226         memmove(&ifi,result+2,2);
3227         strcpy(result,result+4);
3228     }
3229     return ifi;     /* this is the RMS internal file id */
3230 }
3231
3232 static void pipe_infromchild_ast(pPipe p);
3233
3234 /*
3235     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3236     inside an AST routine without worrying about reentrancy and which Perl
3237     memory allocator is being used.
3238
3239     We read data and queue up the buffers, then spit them out one at a
3240     time to the output mailbox when the output mailbox is ready for one.
3241
3242 */
3243 #define INITIAL_TOCHILDQUEUE  2
3244
3245 static pPipe
3246 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3247 {
3248     pPipe p;
3249     pCBuf b;
3250     char mbx1[64], mbx2[64];
3251     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3252                                       DSC$K_CLASS_S, mbx1},
3253                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3254                                       DSC$K_CLASS_S, mbx2};
3255     unsigned int dviitm = DVI$_DEVBUFSIZ;
3256     int j, n;
3257
3258     n = sizeof(Pipe);
3259     _ckvmssts_noperl(lib$get_vm(&n, &p));
3260
3261     create_mbx(&p->chan_in , &d_mbx1);
3262     create_mbx(&p->chan_out, &d_mbx2);
3263     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3264
3265     p->buf           = 0;
3266     p->shut_on_empty = FALSE;
3267     p->need_wake     = FALSE;
3268     p->type          = 0;
3269     p->retry         = 0;
3270     p->iosb.status   = SS$_NORMAL;
3271     p->iosb2.status  = SS$_NORMAL;
3272     p->free          = RQE_ZERO;
3273     p->wait          = RQE_ZERO;
3274     p->curr          = 0;
3275     p->curr2         = 0;
3276     p->info          = 0;
3277 #ifdef PERL_IMPLICIT_CONTEXT
3278     p->thx           = aTHX;
3279 #endif
3280
3281     n = sizeof(CBuf) + p->bufsize;
3282
3283     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3284         _ckvmssts_noperl(lib$get_vm(&n, &b));
3285         b->buf = (char *) b + sizeof(CBuf);
3286         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3287     }
3288
3289     pipe_tochild2_ast(p);
3290     pipe_tochild1_ast(p);
3291     strcpy(wmbx, mbx1);
3292     strcpy(rmbx, mbx2);
3293     return p;
3294 }
3295
3296 /*  reads the MBX Perl is writing, and queues */
3297
3298 static void
3299 pipe_tochild1_ast(pPipe p)
3300 {
3301     pCBuf b = p->curr;
3302     int iss = p->iosb.status;
3303     int eof = (iss == SS$_ENDOFFILE);
3304     int sts;
3305 #ifdef PERL_IMPLICIT_CONTEXT
3306     pTHX = p->thx;
3307 #endif
3308
3309     if (p->retry) {
3310         if (eof) {
3311             p->shut_on_empty = TRUE;
3312             b->eof     = TRUE;
3313             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3314         } else  {
3315             _ckvmssts_noperl(iss);
3316         }
3317
3318         b->eof  = eof;
3319         b->size = p->iosb.count;
3320         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3321         if (p->need_wake) {
3322             p->need_wake = FALSE;
3323             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3324         }
3325     } else {
3326         p->retry = 1;   /* initial call */
3327     }
3328
3329     if (eof) {                  /* flush the free queue, return when done */
3330         int n = sizeof(CBuf) + p->bufsize;
3331         while (1) {
3332             iss = lib$remqti(&p->free, &b);
3333             if (iss == LIB$_QUEWASEMP) return;
3334             _ckvmssts_noperl(iss);
3335             _ckvmssts_noperl(lib$free_vm(&n, &b));
3336         }
3337     }
3338
3339     iss = lib$remqti(&p->free, &b);
3340     if (iss == LIB$_QUEWASEMP) {
3341         int n = sizeof(CBuf) + p->bufsize;
3342         _ckvmssts_noperl(lib$get_vm(&n, &b));
3343         b->buf = (char *) b + sizeof(CBuf);
3344     } else {
3345        _ckvmssts_noperl(iss);
3346     }
3347
3348     p->curr = b;
3349     iss = sys$qio(0,p->chan_in,
3350              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3351              &p->iosb,
3352              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3353     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3354     _ckvmssts_noperl(iss);
3355 }
3356
3357
3358 /* writes queued buffers to output, waits for each to complete before
3359    doing the next */
3360
3361 static void
3362 pipe_tochild2_ast(pPipe p)
3363 {
3364     pCBuf b = p->curr2;
3365     int iss = p->iosb2.status;
3366     int n = sizeof(CBuf) + p->bufsize;
3367     int done = (p->info && p->info->done) ||
3368               iss == SS$_CANCEL || iss == SS$_ABORT;
3369 #if defined(PERL_IMPLICIT_CONTEXT)
3370     pTHX = p->thx;
3371 #endif
3372
3373     do {
3374         if (p->type) {         /* type=1 has old buffer, dispose */
3375             if (p->shut_on_empty) {
3376                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3377             } else {
3378                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3379             }
3380             p->type = 0;
3381         }
3382
3383         iss = lib$remqti(&p->wait, &b);
3384         if (iss == LIB$_QUEWASEMP) {
3385             if (p->shut_on_empty) {
3386                 if (done) {
3387                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3388                     *p->pipe_done = TRUE;
3389                     _ckvmssts_noperl(sys$setef(pipe_ef));
3390                 } else {
3391                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3392                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3393                 }
3394                 return;
3395             }
3396             p->need_wake = TRUE;
3397             return;
3398         }
3399         _ckvmssts_noperl(iss);
3400         p->type = 1;
3401     } while (done);
3402
3403
3404     p->curr2 = b;
3405     if (b->eof) {
3406         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3407             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3408     } else {
3409         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3410             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3411     }
3412
3413     return;
3414
3415 }
3416
3417
3418 static pPipe
3419 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3420 {
3421     pPipe p;
3422     char mbx1[64], mbx2[64];
3423     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3424                                       DSC$K_CLASS_S, mbx1},
3425                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3426                                       DSC$K_CLASS_S, mbx2};
3427     unsigned int dviitm = DVI$_DEVBUFSIZ;
3428
3429     int n = sizeof(Pipe);
3430     _ckvmssts_noperl(lib$get_vm(&n, &p));
3431     create_mbx(&p->chan_in , &d_mbx1);
3432     create_mbx(&p->chan_out, &d_mbx2);
3433
3434     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3435     n = p->bufsize * sizeof(char);
3436     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3437     p->shut_on_empty = FALSE;
3438     p->info   = 0;
3439     p->type   = 0;
3440     p->iosb.status = SS$_NORMAL;
3441 #if defined(PERL_IMPLICIT_CONTEXT)
3442     p->thx = aTHX;
3443 #endif
3444     pipe_infromchild_ast(p);
3445
3446     strcpy(wmbx, mbx1);
3447     strcpy(rmbx, mbx2);
3448     return p;
3449 }
3450
3451 static void
3452 pipe_infromchild_ast(pPipe p)
3453 {
3454     int iss = p->iosb.status;
3455     int eof = (iss == SS$_ENDOFFILE);
3456     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3457     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3458 #if defined(PERL_IMPLICIT_CONTEXT)
3459     pTHX = p->thx;
3460 #endif
3461
3462     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3463         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3464         p->chan_out = 0;
3465     }
3466
3467     /* read completed:
3468             input shutdown if EOF from self (done or shut_on_empty)
3469             output shutdown if closing flag set (my_pclose)
3470             send data/eof from child or eof from self
3471             otherwise, re-read (snarf of data from child)
3472     */
3473
3474     if (p->type == 1) {
3475         p->type = 0;
3476         if (myeof && p->chan_in) {                  /* input shutdown */
3477             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3478             p->chan_in = 0;
3479         }
3480
3481         if (p->chan_out) {
3482             if (myeof || kideof) {      /* pass EOF to parent */
3483                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3484                                          pipe_infromchild_ast, p,
3485                                          0, 0, 0, 0, 0, 0));
3486                 return;
3487             } else if (eof) {       /* eat EOF --- fall through to read*/
3488
3489             } else {                /* transmit data */
3490                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3491                                          pipe_infromchild_ast,p,
3492                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3493                 return;
3494             }
3495         }
3496     }
3497
3498     /*  everything shut? flag as done */
3499
3500     if (!p->chan_in && !p->chan_out) {
3501         *p->pipe_done = TRUE;
3502         _ckvmssts_noperl(sys$setef(pipe_ef));
3503         return;
3504     }
3505
3506     /* write completed (or read, if snarfing from child)
3507             if still have input active,
3508                queue read...immediate mode if shut_on_empty so we get EOF if empty
3509             otherwise,
3510                check if Perl reading, generate EOFs as needed
3511     */
3512
3513     if (p->type == 0) {
3514         p->type = 1;
3515         if (p->chan_in) {
3516             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3517                           pipe_infromchild_ast,p,
3518                           p->buf, p->bufsize, 0, 0, 0, 0);
3519             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3520             _ckvmssts_noperl(iss);
3521         } else {           /* send EOFs for extra reads */
3522             p->iosb.status = SS$_ENDOFFILE;
3523             p->iosb.dvispec = 0;
3524             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3525                                      0, 0, 0,
3526                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3527         }
3528     }
3529 }
3530
3531 static pPipe
3532 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3533 {
3534     pPipe p;
3535     char mbx[64];
3536     unsigned long dviitm = DVI$_DEVBUFSIZ;
3537     struct stat s;
3538     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3539                                       DSC$K_CLASS_S, mbx};
3540     int n = sizeof(Pipe);
3541
3542     /* things like terminals and mbx's don't need this filter */
3543     if (fd && fstat(fd,&s) == 0) {
3544         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3545         char device[65];
3546         unsigned short dev_len;
3547         struct dsc$descriptor_s d_dev;
3548         char * cptr;
3549         struct item_list_3 items[3];
3550         int status;
3551         unsigned short dvi_iosb[4];
3552
3553         cptr = getname(fd, out, 1);
3554         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3555         d_dev.dsc$a_pointer = out;
3556         d_dev.dsc$w_length = strlen(out);
3557         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3558         d_dev.dsc$b_class = DSC$K_CLASS_S;
3559
3560         items[0].len = 4;
3561         items[0].code = DVI$_DEVCHAR;
3562         items[0].bufadr = &devchar;
3563         items[0].retadr = NULL;
3564         items[1].len = 64;
3565         items[1].code = DVI$_FULLDEVNAM;
3566         items[1].bufadr = device;
3567         items[1].retadr = &dev_len;
3568         items[2].len = 0;
3569         items[2].code = 0;
3570
3571         status = sys$getdviw
3572                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3573         _ckvmssts_noperl(status);
3574         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3575             device[dev_len] = 0;
3576
3577             if (!(devchar & DEV$M_DIR)) {
3578                 strcpy(out, device);
3579                 return 0;
3580             }
3581         }
3582     }
3583
3584     _ckvmssts_noperl(lib$get_vm(&n, &p));
3585     p->fd_out = dup(fd);
3586     create_mbx(&p->chan_in, &d_mbx);
3587     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3588     n = (p->bufsize+1) * sizeof(char);
3589     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3590     p->shut_on_empty = FALSE;
3591     p->retry = 0;
3592     p->info  = 0;
3593     strcpy(out, mbx);
3594
3595     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3596                              pipe_mbxtofd_ast, p,
3597                              p->buf, p->bufsize, 0, 0, 0, 0));
3598
3599     return p;
3600 }
3601
3602 static void
3603 pipe_mbxtofd_ast(pPipe p)
3604 {
3605     int iss = p->iosb.status;
3606     int done = p->info->done;
3607     int iss2;
3608     int eof = (iss == SS$_ENDOFFILE);
3609     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3610     int err = !(iss&1) && !eof;
3611 #if defined(PERL_IMPLICIT_CONTEXT)
3612     pTHX = p->thx;
3613 #endif
3614
3615     if (done && myeof) {               /* end piping */
3616         close(p->fd_out);
3617         sys$dassgn(p->chan_in);
3618         *p->pipe_done = TRUE;
3619         _ckvmssts_noperl(sys$setef(pipe_ef));
3620         return;
3621     }
3622
3623     if (!err && !eof) {             /* good data to send to file */
3624         p->buf[p->iosb.count] = '\n';
3625         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3626         if (iss2 < 0) {
3627             p->retry++;
3628             if (p->retry < MAX_RETRY) {
3629                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3630                 return;
3631             }
3632         }
3633         p->retry = 0;
3634     } else if (err) {
3635         _ckvmssts_noperl(iss);
3636     }
3637
3638
3639     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3640           pipe_mbxtofd_ast, p,
3641           p->buf, p->bufsize, 0, 0, 0, 0);
3642     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3643     _ckvmssts_noperl(iss);
3644 }
3645
3646
3647 typedef struct _pipeloc     PLOC;
3648 typedef struct _pipeloc*   pPLOC;
3649
3650 struct _pipeloc {
3651     pPLOC   next;
3652     char    dir[NAM$C_MAXRSS+1];
3653 };
3654 static pPLOC  head_PLOC = 0;
3655
3656 void
3657 free_pipelocs(pTHX_ void *head)
3658 {
3659     pPLOC p, pnext;
3660     pPLOC *pHead = (pPLOC *)head;
3661
3662     p = *pHead;
3663     while (p) {
3664         pnext = p->next;
3665         PerlMem_free(p);
3666         p = pnext;
3667     }
3668     *pHead = 0;
3669 }
3670
3671 static void
3672 store_pipelocs(pTHX)
3673 {
3674     int    i;
3675     pPLOC  p;
3676     AV    *av = 0;
3677     SV    *dirsv;
3678     GV    *gv;
3679     char  *dir, *x;
3680     char  *unixdir;
3681     char  temp[NAM$C_MAXRSS+1];
3682     STRLEN n_a;
3683
3684     if (head_PLOC)
3685         free_pipelocs(aTHX_ &head_PLOC);
3686
3687 /*  the . directory from @INC comes last */
3688
3689     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3690     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3691     p->next = head_PLOC;
3692     head_PLOC = p;
3693     strcpy(p->dir,"./");
3694
3695 /*  get the directory from $^X */
3696
3697     unixdir = PerlMem_malloc(VMS_MAXRSS);
3698     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3699
3700 #ifdef PERL_IMPLICIT_CONTEXT
3701     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3702 #else
3703     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3704 #endif
3705         strcpy(temp, PL_origargv[0]);
3706         x = strrchr(temp,']');
3707         if (x == NULL) {
3708         x = strrchr(temp,'>');
3709           if (x == NULL) {
3710             /* It could be a UNIX path */
3711             x = strrchr(temp,'/');
3712           }
3713         }
3714         if (x)
3715           x[1] = '\0';
3716         else {
3717           /* Got a bare name, so use default directory */
3718           temp[0] = '.';
3719           temp[1] = '\0';
3720         }
3721
3722         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3723             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3724             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3725             p->next = head_PLOC;
3726             head_PLOC = p;
3727             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3728             p->dir[NAM$C_MAXRSS] = '\0';
3729         }
3730     }
3731
3732 /*  reverse order of @INC entries, skip "." since entered above */
3733
3734 #ifdef PERL_IMPLICIT_CONTEXT
3735     if (aTHX)
3736 #endif
3737     if (PL_incgv) av = GvAVn(PL_incgv);
3738
3739     for (i = 0; av && i <= AvFILL(av); i++) {
3740         dirsv = *av_fetch(av,i,TRUE);
3741
3742         if (SvROK(dirsv)) continue;
3743         dir = SvPVx(dirsv,n_a);
3744         if (strcmp(dir,".") == 0) continue;
3745         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3746             continue;
3747
3748         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3749         p->next = head_PLOC;
3750         head_PLOC = p;
3751         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3752         p->dir[NAM$C_MAXRSS] = '\0';
3753     }
3754
3755 /* most likely spot (ARCHLIB) put first in the list */
3756
3757 #ifdef ARCHLIB_EXP
3758     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3759         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3760         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3761         p->next = head_PLOC;
3762         head_PLOC = p;
3763         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3764         p->dir[NAM$C_MAXRSS] = '\0';
3765     }
3766 #endif
3767     PerlMem_free(unixdir);
3768 }
3769
3770 static I32
3771 Perl_cando_by_name_int
3772    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3773 #if !defined(PERL_IMPLICIT_CONTEXT)
3774 #define cando_by_name_int               Perl_cando_by_name_int
3775 #else
3776 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3777 #endif
3778
3779 static char *
3780 find_vmspipe(pTHX)
3781 {
3782     static int   vmspipe_file_status = 0;
3783     static char  vmspipe_file[NAM$C_MAXRSS+1];
3784
3785     /* already found? Check and use ... need read+execute permission */
3786
3787     if (vmspipe_file_status == 1) {
3788         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3789          && cando_by_name_int
3790            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3791             return vmspipe_file;
3792         }
3793         vmspipe_file_status = 0;
3794     }
3795
3796     /* scan through stored @INC, $^X */
3797
3798     if (vmspipe_file_status == 0) {
3799         char file[NAM$C_MAXRSS+1];
3800         pPLOC  p = head_PLOC;
3801
3802         while (p) {
3803             char * exp_res;
3804             int dirlen;
3805             strcpy(file, p->dir);
3806             dirlen = strlen(file);
3807             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3808             file[NAM$C_MAXRSS] = '\0';
3809             p = p->next;
3810
3811             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3812             if (!exp_res) continue;
3813
3814             if (cando_by_name_int
3815                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3816              && cando_by_name_int
3817                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3818                 vmspipe_file_status = 1;
3819                 return vmspipe_file;
3820             }
3821         }
3822         vmspipe_file_status = -1;   /* failed, use tempfiles */
3823     }
3824
3825     return 0;
3826 }
3827
3828 static FILE *
3829 vmspipe_tempfile(pTHX)
3830 {
3831     char file[NAM$C_MAXRSS+1];
3832     FILE *fp;
3833     static int index = 0;
3834     Stat_t s0, s1;
3835     int cmp_result;
3836
3837     /* create a tempfile */
3838
3839     /* we can't go from   W, shr=get to  R, shr=get without
3840        an intermediate vulnerable state, so don't bother trying...
3841
3842        and lib$spawn doesn't shr=put, so have to close the write
3843
3844        So... match up the creation date/time and the FID to
3845        make sure we're dealing with the same file
3846
3847     */
3848
3849     index++;
3850     if (!decc_filename_unix_only) {
3851       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3852       fp = fopen(file,"w");
3853       if (!fp) {
3854         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3855         fp = fopen(file,"w");
3856         if (!fp) {
3857             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3858             fp = fopen(file,"w");
3859         }
3860       }
3861      }
3862      else {
3863       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3864       fp = fopen(file,"w");
3865       if (!fp) {
3866         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3867         fp = fopen(file,"w");
3868         if (!fp) {
3869           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3870           fp = fopen(file,"w");
3871         }
3872       }
3873     }
3874     if (!fp) return 0;  /* we're hosed */
3875
3876     fprintf(fp,"$! 'f$verify(0)'\n");
3877     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3878     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3879     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3880     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3881     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3882     fprintf(fp,"$ perl_del    = \"delete\"\n");
3883     fprintf(fp,"$ pif         = \"if\"\n");
3884     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3885     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3886     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3887     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3888     fprintf(fp,"$!  --- build command line to get max possible length\n");
3889     fprintf(fp,"$c=perl_popen_cmd0\n");
3890     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3891     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3892     fprintf(fp,"$x=perl_popen_cmd3\n");
3893     fprintf(fp,"$c=c+x\n");
3894     fprintf(fp,"$ perl_on\n");
3895     fprintf(fp,"$ 'c'\n");
3896     fprintf(fp,"$ perl_status = $STATUS\n");
3897     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3898     fprintf(fp,"$ perl_exit 'perl_status'\n");
3899     fsync(fileno(fp));
3900
3901     fgetname(fp, file, 1);
3902     fstat(fileno(fp), (struct stat *)&s0);
3903     fclose(fp);
3904
3905     if (decc_filename_unix_only)
3906         int_tounixspec(file, file, NULL);
3907     fp = fopen(file,"r","shr=get");
3908     if (!fp) return 0;
3909     fstat(fileno(fp), (struct stat *)&s1);
3910
3911     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3912     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3913         fclose(fp);
3914         return 0;
3915     }
3916
3917     return fp;
3918 }
3919
3920
3921 static int vms_is_syscommand_xterm(void)
3922 {
3923     const static struct dsc$descriptor_s syscommand_dsc =
3924       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3925
3926     const static struct dsc$descriptor_s decwdisplay_dsc =
3927       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3928
3929     struct item_list_3 items[2];
3930     unsigned short dvi_iosb[4];
3931     unsigned long devchar;
3932     unsigned long devclass;
3933     int status;
3934
3935     /* Very simple check to guess if sys$command is a decterm? */
3936     /* First see if the DECW$DISPLAY: device exists */
3937     items[0].len = 4;
3938     items[0].code = DVI$_DEVCHAR;
3939     items[0].bufadr = &devchar;
3940     items[0].retadr = NULL;
3941     items[1].len = 0;
3942     items[1].code = 0;
3943
3944     status = sys$getdviw
3945         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3946
3947     if ($VMS_STATUS_SUCCESS(status)) {
3948         status = dvi_iosb[0];
3949     }
3950
3951     if (!$VMS_STATUS_SUCCESS(status)) {
3952         SETERRNO(EVMSERR, status);
3953         return -1;
3954     }
3955
3956     /* If it does, then for now assume that we are on a workstation */
3957     /* Now verify that SYS$COMMAND is a terminal */
3958     /* for creating the debugger DECTerm */
3959
3960     items[0].len = 4;
3961     items[0].code = DVI$_DEVCLASS;
3962     items[0].bufadr = &devclass;
3963     items[0].retadr = NULL;
3964     items[1].len = 0;
3965     items[1].code = 0;
3966
3967     status = sys$getdviw
3968         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3969
3970     if ($VMS_STATUS_SUCCESS(status)) {
3971         status = dvi_iosb[0];
3972     }
3973
3974     if (!$VMS_STATUS_SUCCESS(status)) {
3975         SETERRNO(EVMSERR, status);
3976         return -1;
3977     }
3978     else {
3979         if (devclass == DC$_TERM) {
3980             return 0;
3981         }
3982     }
3983     return -1;
3984 }
3985
3986 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3987 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3988 {
3989     int status;
3990     int ret_stat;
3991     char * ret_char;
3992     char device_name[65];
3993     unsigned short device_name_len;
3994     struct dsc$descriptor_s customization_dsc;
3995     struct dsc$descriptor_s device_name_dsc;
3996     const char * cptr;
3997     char * tptr;
3998     char customization[200];
3999     char title[40];
4000     pInfo info = NULL;
4001     char mbx1[64];
4002     unsigned short p_chan;
4003     int n;
4004     unsigned short iosb[4];
4005     struct item_list_3 items[2];
4006     const char * cust_str =
4007         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
4008     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
4009                                           DSC$K_CLASS_S, mbx1};
4010
4011      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4012     /*---------------------------------------*/
4013     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
4014
4015
4016     /* Make sure that this is from the Perl debugger */
4017     ret_char = strstr(cmd," xterm ");
4018     if (ret_char == NULL)
4019         return NULL;
4020     cptr = ret_char + 7;
4021     ret_char = strstr(cmd,"tty");
4022     if (ret_char == NULL)
4023         return NULL;
4024     ret_char = strstr(cmd,"sleep");
4025     if (ret_char == NULL)
4026         return NULL;
4027
4028     if (decw_term_port == 0) {
4029         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4030         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4031         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4032
4033        status = lib$find_image_symbol
4034                                (&filename1_dsc,
4035                                 &decw_term_port_dsc,
4036                                 (void *)&decw_term_port,
4037                                 NULL,
4038                                 0);
4039
4040         /* Try again with the other image name */
4041         if (!$VMS_STATUS_SUCCESS(status)) {
4042
4043            status = lib$find_image_symbol
4044                                (&filename2_dsc,
4045                                 &decw_term_port_dsc,
4046                                 (void *)&decw_term_port,
4047                                 NULL,
4048                                 0);
4049
4050         }
4051
4052     }
4053
4054
4055     /* No decw$term_port, give it up */
4056     if (!$VMS_STATUS_SUCCESS(status))
4057         return NULL;
4058
4059     /* Are we on a workstation? */
4060     /* to do: capture the rows / columns and pass their properties */
4061     ret_stat = vms_is_syscommand_xterm();
4062     if (ret_stat < 0)
4063         return NULL;
4064
4065     /* Make the title: */
4066     ret_char = strstr(cptr,"-title");
4067     if (ret_char != NULL) {
4068         while ((*cptr != 0) && (*cptr != '\"')) {
4069             cptr++;
4070         }
4071         if (*cptr == '\"')
4072             cptr++;
4073         n = 0;
4074         while ((*cptr != 0) && (*cptr != '\"')) {
4075             title[n] = *cptr;
4076             n++;
4077             if (n == 39) {
4078                 title[39] == 0;
4079                 break;
4080             }
4081             cptr++;
4082         }
4083         title[n] = 0;
4084     }
4085     else {
4086             /* Default title */
4087             strcpy(title,"Perl Debug DECTerm");
4088     }
4089     sprintf(customization, cust_str, title);
4090
4091     customization_dsc.dsc$a_pointer = customization;
4092     customization_dsc.dsc$w_length = strlen(customization);
4093     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4094     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4095
4096     device_name_dsc.dsc$a_pointer = device_name;
4097     device_name_dsc.dsc$w_length = sizeof device_name -1;
4098     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4099     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4100
4101     device_name_len = 0;
4102
4103     /* Try to create the window */
4104      status = (*decw_term_port)
4105        (NULL,
4106         NULL,
4107         &customization_dsc,
4108         &device_name_dsc,
4109         &device_name_len,
4110         NULL,
4111         NULL,
4112         NULL);
4113     if (!$VMS_STATUS_SUCCESS(status)) {
4114         SETERRNO(EVMSERR, status);
4115         return NULL;
4116     }
4117
4118     device_name[device_name_len] = '\0';
4119
4120     /* Need to set this up to look like a pipe for cleanup */
4121     n = sizeof(Info);
4122     status = lib$get_vm(&n, &info);
4123     if (!$VMS_STATUS_SUCCESS(status)) {
4124         SETERRNO(ENOMEM, status);
4125         return NULL;
4126     }
4127
4128     info->mode = *mode;
4129     info->done = FALSE;
4130     info->completion = 0;
4131     info->closing    = FALSE;
4132     info->in         = 0;
4133     info->out        = 0;
4134     info->err        = 0;
4135     info->fp         = NULL;
4136     info->useFILE    = 0;
4137     info->waiting    = 0;
4138     info->in_done    = TRUE;
4139     info->out_done   = TRUE;
4140     info->err_done   = TRUE;
4141
4142     /* Assign a channel on this so that it will persist, and not login */
4143     /* We stash this channel in the info structure for reference. */
4144     /* The created xterm self destructs when the last channel is removed */
4145     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4146     /* So leave this assigned. */
4147     device_name_dsc.dsc$w_length = device_name_len;
4148     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4149     if (!$VMS_STATUS_SUCCESS(status)) {
4150         SETERRNO(EVMSERR, status);
4151         return NULL;
4152     }
4153     info->xchan_valid = 1;
4154
4155     /* Now create a mailbox to be read by the application */
4156
4157     create_mbx(&p_chan, &d_mbx1);
4158
4159     /* write the name of the created terminal to the mailbox */
4160     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4161             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4162
4163     if (!$VMS_STATUS_SUCCESS(status)) {
4164         SETERRNO(EVMSERR, status);
4165         return NULL;
4166     }
4167
4168     info->fp  = PerlIO_open(mbx1, mode);
4169
4170     /* Done with this channel */
4171     sys$dassgn(p_chan);
4172
4173     /* If any errors, then clean up */
4174     if (!info->fp) {
4175         n = sizeof(Info);
4176         _ckvmssts_noperl(lib$free_vm(&n, &info));
4177         return NULL;
4178         }
4179
4180     /* All done */
4181     return info->fp;
4182 }
4183
4184 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4185
4186 static PerlIO *
4187 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4188 {
4189     static int handler_set_up = FALSE;
4190     PerlIO * ret_fp;
4191     unsigned long int sts, flags = CLI$M_NOWAIT;
4192     /* The use of a GLOBAL table (as was done previously) rendered
4193      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4194      * environment.  Hence we've switched to LOCAL symbol table.
4195      */
4196     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4197     int j, wait = 0, n;
4198     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4199     char *in, *out, *err, mbx[512];
4200     FILE *tpipe = 0;
4201     char tfilebuf[NAM$C_MAXRSS+1];
4202     pInfo info = NULL;
4203     char cmd_sym_name[20];
4204     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4205                                       DSC$K_CLASS_S, symbol};
4206     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4207                                       DSC$K_CLASS_S, 0};
4208     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4209                                       DSC$K_CLASS_S, cmd_sym_name};
4210     struct dsc$descriptor_s *vmscmd;
4211     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4212     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4213     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4214
4215     /* Check here for Xterm create request.  This means looking for
4216      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4217      *  is possible to create an xterm.
4218      */
4219     if (*in_mode == 'r') {
4220         PerlIO * xterm_fd;
4221
4222         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4223         if (xterm_fd != NULL)
4224             return xterm_fd;
4225     }
4226
4227     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4228
4229     /* once-per-program initialization...
4230        note that the SETAST calls and the dual test of pipe_ef
4231        makes sure that only the FIRST thread through here does
4232        the initialization...all other threads wait until it's
4233        done.
4234
4235        Yeah, uglier than a pthread call, it's got all the stuff inline
4236        rather than in a separate routine.
4237     */
4238
4239     if (!pipe_ef) {
4240         _ckvmssts_noperl(sys$setast(0));
4241         if (!pipe_ef) {
4242             unsigned long int pidcode = JPI$_PID;
4243             $DESCRIPTOR(d_delay, RETRY_DELAY);
4244             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4245             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4246             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4247         }
4248         if (!handler_set_up) {
4249           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4250           handler_set_up = TRUE;
4251         }
4252         _ckvmssts_noperl(sys$setast(1));
4253     }
4254
4255     /* see if we can find a VMSPIPE.COM */
4256
4257     tfilebuf[0] = '@';
4258     vmspipe = find_vmspipe(aTHX);
4259     if (vmspipe) {
4260         strcpy(tfilebuf+1,vmspipe);
4261     } else {        /* uh, oh...we're in tempfile hell */
4262         tpipe = vmspipe_tempfile(aTHX);
4263         if (!tpipe) {       /* a fish popular in Boston */
4264             if (ckWARN(WARN_PIPE)) {
4265                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4266             }
4267         return NULL;
4268         }
4269         fgetname(tpipe,tfilebuf+1,1);
4270     }
4271     vmspipedsc.dsc$a_pointer = tfilebuf;
4272     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4273
4274     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4275     if (!(sts & 1)) {
4276       switch (sts) {
4277         case RMS$_FNF:  case RMS$_DNF:
4278           set_errno(ENOENT); break;
4279         case RMS$_DIR:
4280           set_errno(ENOTDIR); break;
4281         case RMS$_DEV:
4282           set_errno(ENODEV); break;
4283         case RMS$_PRV:
4284           set_errno(EACCES); break;
4285         case RMS$_SYN:
4286           set_errno(EINVAL); break;
4287         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4288           set_errno(E2BIG); break;
4289         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4290           _ckvmssts_noperl(sts); /* fall through */
4291         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4292           set_errno(EVMSERR);
4293       }
4294       set_vaxc_errno(sts);
4295       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4296         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4297       }
4298       *psts = sts;
4299       return NULL;
4300     }
4301     n = sizeof(Info);
4302     _ckvmssts_noperl(lib$get_vm(&n, &info));
4303
4304     strcpy(mode,in_mode);
4305     info->mode = *mode;
4306     info->done = FALSE;
4307     info->completion = 0;
4308     info->closing    = FALSE;
4309     info->in         = 0;
4310     info->out        = 0;
4311     info->err        = 0;
4312     info->fp         = NULL;
4313     info->useFILE    = 0;
4314     info->waiting    = 0;
4315     info->in_done    = TRUE;
4316     info->out_done   = TRUE;
4317     info->err_done   = TRUE;
4318     info->xchan      = 0;
4319     info->xchan_valid = 0;
4320
4321     in = PerlMem_malloc(VMS_MAXRSS);
4322     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4323     out = PerlMem_malloc(VMS_MAXRSS);
4324     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4325     err = PerlMem_malloc(VMS_MAXRSS);
4326     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4327
4328     in[0] = out[0] = err[0] = '\0';
4329
4330     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4331         info->useFILE = 1;
4332         strcpy(p,p+1);
4333     }
4334     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4335         wait = 1;
4336         strcpy(p,p+1);
4337     }
4338
4339     if (*mode == 'r') {             /* piping from subroutine */
4340
4341         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4342         if (info->out) {
4343             info->out->pipe_done = &info->out_done;
4344             info->out_done = FALSE;
4345             info->out->info = info;
4346         }
4347         if (!info->useFILE) {
4348             info->fp  = PerlIO_open(mbx, mode);
4349         } else {
4350             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4351             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4352         }
4353
4354         if (!info->fp && info->out) {
4355             sys$cancel(info->out->chan_out);
4356
4357             while (!info->out_done) {
4358                 int done;
4359                 _ckvmssts_noperl(sys$setast(0));
4360                 done = info->out_done;
4361                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4362                 _ckvmssts_noperl(sys$setast(1));
4363                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4364             }
4365
4366             if (info->out->buf) {
4367                 n = info->out->bufsize * sizeof(char);
4368                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4369             }
4370             n = sizeof(Pipe);
4371             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4372             n = sizeof(Info);
4373             _ckvmssts_noperl(lib$free_vm(&n, &info));
4374             *psts = RMS$_FNF;
4375             return NULL;
4376         }
4377
4378         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4379         if (info->err) {
4380             info->err->pipe_done = &info->err_done;
4381             info->err_done = FALSE;
4382             info->err->info = info;
4383         }
4384
4385     } else if (*mode == 'w') {      /* piping to subroutine */
4386
4387         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4388         if (info->out) {
4389             info->out->pipe_done = &info->out_done;
4390             info->out_done = FALSE;
4391             info->out->info = info;
4392         }
4393
4394         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4395         if (info->err) {
4396             info->err->pipe_done = &info->err_done;
4397             info->err_done = FALSE;
4398             info->err->info = info;
4399         }
4400
4401         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4402         if (!info->useFILE) {
4403             info->fp  = PerlIO_open(mbx, mode);
4404         } else {
4405             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4406             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4407         }
4408
4409         if (info->in) {
4410             info->in->pipe_done = &info->in_done;
4411             info->in_done = FALSE;
4412             info->in->info = info;
4413         }
4414
4415         /* error cleanup */
4416         if (!info->fp && info->in) {
4417             info->done = TRUE;
4418             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4419                                       0, 0, 0, 0, 0, 0, 0, 0));
4420
4421             while (!info->in_done) {
4422                 int done;
4423                 _ckvmssts_noperl(sys$setast(0));
4424                 done = info->in_done;
4425                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4426                 _ckvmssts_noperl(sys$setast(1));
4427                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4428             }
4429
4430             if (info->in->buf) {
4431                 n = info->in->bufsize * sizeof(char);
4432                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4433             }
4434             n = sizeof(Pipe);
4435             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4436             n = sizeof(Info);
4437             _ckvmssts_noperl(lib$free_vm(&n, &info));
4438             *psts = RMS$_FNF;
4439             return NULL;
4440         }
4441
4442
4443     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4444         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4445         if (info->out) {
4446             info->out->pipe_done = &info->out_done;
4447             info->out_done = FALSE;
4448             info->out->info = info;
4449         }
4450
4451         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4452         if (info->err) {
4453             info->err->pipe_done = &info->err_done;
4454             info->err_done = FALSE;
4455             info->err->info = info;
4456         }
4457     }
4458
4459     symbol[MAX_DCL_SYMBOL] = '\0';
4460
4461     strncpy(symbol, in, MAX_DCL_SYMBOL);
4462     d_symbol.dsc$w_length = strlen(symbol);
4463     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4464
4465     strncpy(symbol, err, MAX_DCL_SYMBOL);
4466     d_symbol.dsc$w_length = strlen(symbol);
4467     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4468
4469     strncpy(symbol, out, MAX_DCL_SYMBOL);
4470     d_symbol.dsc$w_length = strlen(symbol);
4471     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4472
4473     /* Done with the names for the pipes */
4474     PerlMem_free(err);
4475     PerlMem_free(out);
4476     PerlMem_free(in);
4477
4478     p = vmscmd->dsc$a_pointer;
4479     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4480     if (*p == '$') p++;                         /* remove leading $ */
4481     while (*p == ' ' || *p == '\t') p++;
4482
4483     for (j = 0; j < 4; j++) {
4484         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4485         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4486
4487     strncpy(symbol, p, MAX_DCL_SYMBOL);
4488     d_symbol.dsc$w_length = strlen(symbol);
4489     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4490
4491         if (strlen(p) > MAX_DCL_SYMBOL) {
4492             p += MAX_DCL_SYMBOL;
4493         } else {
4494             p += strlen(p);
4495         }
4496     }
4497     _ckvmssts_noperl(sys$setast(0));
4498     info->next=open_pipes;  /* prepend to list */
4499     open_pipes=info;
4500     _ckvmssts_noperl(sys$setast(1));
4501     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4502      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4503      * have SYS$COMMAND if we need it.
4504      */
4505     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4506                       0, &info->pid, &info->completion,
4507                       0, popen_completion_ast,info,0,0,0));
4508
4509     /* if we were using a tempfile, close it now */
4510
4511     if (tpipe) fclose(tpipe);
4512
4513     /* once the subprocess is spawned, it has copied the symbols and
4514        we can get rid of ours */
4515
4516     for (j = 0; j < 4; j++) {
4517         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4518         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4519     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4520     }
4521     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4522     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4523     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4524     vms_execfree(vmscmd);
4525
4526 #ifdef PERL_IMPLICIT_CONTEXT
4527     if (aTHX)
4528 #endif
4529     PL_forkprocess = info->pid;
4530
4531     ret_fp = info->fp;
4532     if (wait) {
4533          dSAVEDERRNO;
4534          int done = 0;
4535          while (!done) {
4536              _ckvmssts_noperl(sys$setast(0));
4537              done = info->done;
4538              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4539              _ckvmssts_noperl(sys$setast(1));
4540              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4541          }
4542         *psts = info->completion;
4543 /* Caller thinks it is open and tries to close it. */
4544 /* This causes some problems, as it changes the error status */
4545 /*        my_pclose(info->fp); */
4546
4547          /* If we did not have a file pointer open, then we have to */
4548          /* clean up here or eventually we will run out of something */
4549          SAVE_ERRNO;
4550          if (info->fp == NULL) {
4551              my_pclose_pinfo(aTHX_ info);
4552          }
4553          RESTORE_ERRNO;
4554
4555     } else {
4556         *psts = info->pid;
4557     }
4558     return ret_fp;
4559 }  /* end of safe_popen */
4560
4561
4562 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4563 PerlIO *
4564 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4565 {
4566     int sts;
4567     TAINT_ENV();
4568     TAINT_PROPER("popen");
4569     PERL_FLUSHALL_FOR_CHILD;
4570     return safe_popen(aTHX_ cmd,mode,&sts);
4571 }
4572
4573 /*}}}*/
4574
4575
4576 /* Routine to close and cleanup a pipe info structure */
4577
4578 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4579
4580     unsigned long int retsts;
4581     int done, iss, n;
4582     int status;
4583     pInfo next, last;
4584
4585     /* If we were writing to a subprocess, insure that someone reading from
4586      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4587      * produce an EOF record in the mailbox.
4588      *
4589      *  well, at least sometimes it *does*, so we have to watch out for
4590      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4591      */
4592      if (info->fp) {
4593         if (!info->useFILE
4594 #if defined(USE_ITHREADS)
4595           && my_perl
4596 #endif
4597           && PL_perlio_fd_refcnt)
4598             PerlIO_flush(info->fp);
4599         else
4600             fflush((FILE *)info->fp);
4601     }
4602
4603     _ckvmssts(sys$setast(0));
4604      info->closing = TRUE;
4605      done = info->done && info->in_done && info->out_done && info->err_done;
4606      /* hanging on write to Perl's input? cancel it */
4607      if (info->mode == 'r' && info->out && !info->out_done) {
4608         if (info->out->chan_out) {
4609             _ckvmssts(sys$cancel(info->out->chan_out));
4610             if (!info->out->chan_in) {   /* EOF generation, need AST */
4611                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4612             }
4613         }
4614      }
4615      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4616          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4617                            0, 0, 0, 0, 0, 0));
4618     _ckvmssts(sys$setast(1));
4619     if (info->fp) {
4620      if (!info->useFILE
4621 #if defined(USE_ITHREADS)
4622          && my_perl
4623 #endif
4624          && PL_perlio_fd_refcnt)
4625         PerlIO_close(info->fp);
4626      else
4627         fclose((FILE *)info->fp);
4628     }
4629      /*
4630         we have to wait until subprocess completes, but ALSO wait until all
4631         the i/o completes...otherwise we'll be freeing the "info" structure
4632         that the i/o ASTs could still be using...
4633      */
4634
4635      while (!done) {
4636          _ckvmssts(sys$setast(0));
4637          done = info->done && info->in_done && info->out_done && info->err_done;
4638          if (!done) _ckvmssts(sys$clref(pipe_ef));
4639          _ckvmssts(sys$setast(1));
4640          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4641      }
4642      retsts = info->completion;
4643
4644     /* remove from list of open pipes */
4645     _ckvmssts(sys$setast(0));
4646     last = NULL;
4647     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4648         if (next == info)
4649             break;
4650     }
4651
4652     if (last)
4653         last->next = info->next;
4654     else
4655         open_pipes = info->next;
4656     _ckvmssts(sys$setast(1));
4657
4658     /* free buffers and structures */
4659
4660     if (info->in) {
4661         if (info->in->buf) {
4662             n = info->in->bufsize * sizeof(char);
4663             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4664         }
4665         n = sizeof(Pipe);
4666         _ckvmssts(lib$free_vm(&n, &info->in));
4667     }
4668     if (info->out) {
4669         if (info->out->buf) {
4670             n = info->out->bufsize * sizeof(char);
4671             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4672         }
4673         n = sizeof(Pipe);
4674         _ckvmssts(lib$free_vm(&n, &info->out));
4675     }
4676     if (info->err) {
4677         if (info->err->buf) {
4678             n = info->err->bufsize * sizeof(char);
4679             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4680         }
4681         n = sizeof(Pipe);
4682         _ckvmssts(lib$free_vm(&n, &info->err));
4683     }
4684     n = sizeof(Info);
4685     _ckvmssts(lib$free_vm(&n, &info));
4686
4687     return retsts;
4688 }
4689
4690
4691 /*{{{  I32 my_pclose(PerlIO *fp)*/
4692 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4693 {
4694     pInfo info, last = NULL;
4695     I32 ret_status;
4696
4697     /* Fixme - need ast and mutex protection here */
4698     for (info = open_pipes; info != NULL; last = info, info = info->next)
4699         if (info->fp == fp) break;
4700
4701     if (info == NULL) {  /* no such pipe open */
4702       set_errno(ECHILD); /* quoth POSIX */
4703       set_vaxc_errno(SS$_NONEXPR);
4704       return -1;
4705     }
4706
4707     ret_status = my_pclose_pinfo(aTHX_ info);
4708
4709     return ret_status;
4710
4711 }  /* end of my_pclose() */
4712
4713 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4714   /* Roll our own prototype because we want this regardless of whether
4715    * _VMS_WAIT is defined.
4716    */
4717   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4718 #endif
4719 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4720    created with popen(); otherwise partially emulate waitpid() unless
4721    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4722    Also check processes not considered by the CRTL waitpid().
4723  */
4724 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4725 Pid_t
4726 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4727 {
4728     pInfo info;
4729     int done;
4730     int sts;
4731     int j;
4732
4733     if (statusp) *statusp = 0;
4734
4735     for (info = open_pipes; info != NULL; info = info->next)
4736         if (info->pid == pid) break;
4737
4738     if (info != NULL) {  /* we know about this child */
4739       while (!info->done) {
4740           _ckvmssts(sys$setast(0));
4741           done = info->done;
4742           if (!done) _ckvmssts(sys$clref(pipe_ef));
4743           _ckvmssts(sys$setast(1));
4744           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4745       }
4746
4747       if (statusp) *statusp = info->completion;
4748       return pid;
4749     }
4750
4751     /* child that already terminated? */
4752
4753     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4754         if (closed_list[j].pid == pid) {
4755             if (statusp) *statusp = closed_list[j].completion;
4756             return pid;
4757         }
4758     }
4759
4760     /* fall through if this child is not one of our own pipe children */
4761
4762 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4763
4764       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4765        * in 7.2 did we get a version that fills in the VMS completion
4766        * status as Perl has always tried to do.
4767        */
4768
4769       sts = __vms_waitpid( pid, statusp, flags );
4770
4771       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4772          return sts;
4773
4774       /* If the real waitpid tells us the child does not exist, we
4775        * fall through here to implement waiting for a child that
4776        * was created by some means other than exec() (say, spawned
4777        * from DCL) or to wait for a process that is not a subprocess
4778        * of the current process.
4779        */
4780
4781 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4782
4783     {
4784       $DESCRIPTOR(intdsc,"0 00:00:01");
4785       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4786       unsigned long int pidcode = JPI$_PID, mypid;
4787       unsigned long int interval[2];
4788       unsigned int jpi_iosb[2];
4789       struct itmlst_3 jpilist[2] = {
4790           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4791           {                      0,         0,                 0, 0}
4792       };
4793
4794       if (pid <= 0) {
4795         /* Sorry folks, we don't presently implement rooting around for
4796            the first child we can find, and we definitely don't want to
4797            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4798          */
4799         set_errno(ENOTSUP);
4800         return -1;
4801       }
4802
4803       /* Get the owner of the child so I can warn if it's not mine. If the
4804        * process doesn't exist or I don't have the privs to look at it,
4805        * I can go home early.
4806        */
4807       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4808       if (sts & 1) sts = jpi_iosb[0];
4809       if (!(sts & 1)) {
4810         switch (sts) {
4811             case SS$_NONEXPR:
4812                 set_errno(ECHILD);
4813                 break;
4814             case SS$_NOPRIV:
4815                 set_errno(EACCES);
4816                 break;
4817             default:
4818                 _ckvmssts(sts);
4819         }
4820         set_vaxc_errno(sts);
4821         return -1;
4822       }
4823
4824       if (ckWARN(WARN_EXEC)) {
4825         /* remind folks they are asking for non-standard waitpid behavior */
4826         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4827         if (ownerpid != mypid)
4828           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4829                       "waitpid: process %x is not a child of process %x",
4830                       pid,mypid);
4831       }
4832
4833       /* simply check on it once a second until it's not there anymore. */
4834
4835       _ckvmssts(sys$bintim(&intdsc,interval));
4836       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4837             _ckvmssts(sys$schdwk(0,0,interval,0));
4838             _ckvmssts(sys$hiber());
4839       }
4840       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4841
4842       _ckvmssts(sts);
4843       return pid;
4844     }
4845 }  /* end of waitpid() */
4846 /*}}}*/
4847 /*}}}*/
4848 /*}}}*/
4849
4850 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4851 char *
4852 my_gconvert(double val, int ndig, int trail, char *buf)
4853 {
4854   static char __gcvtbuf[DBL_DIG+1];
4855   char *loc;
4856
4857   loc = buf ? buf : __gcvtbuf;
4858
4859 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4860   if (val < 1) {
4861     sprintf(loc,"%.*g",ndig,val);
4862     return loc;
4863   }
4864 #endif
4865
4866   if (val) {
4867     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4868     return gcvt(val,ndig,loc);
4869   }
4870   else {
4871     loc[0] = '0'; loc[1] = '\0';
4872     return loc;
4873   }
4874
4875 }
4876 /*}}}*/
4877
4878 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4879 static int rms_free_search_context(struct FAB * fab)
4880 {
4881 struct NAM * nam;
4882
4883     nam = fab->fab$l_nam;
4884     nam->nam$b_nop |= NAM$M_SYNCHK;
4885     nam->nam$l_rlf = NULL;
4886     fab->fab$b_dns = 0;
4887     return sys$parse(fab, NULL, NULL);
4888 }
4889
4890 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4891 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4892 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4893 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4894 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4895 #define rms_nam_esll(nam) nam.nam$b_esl
4896 #define rms_nam_esl(nam) nam.nam$b_esl
4897 #define rms_nam_name(nam) nam.nam$l_name
4898 #define rms_nam_namel(nam) nam.nam$l_name
4899 #define rms_nam_type(nam) nam.nam$l_type
4900 #define rms_nam_typel(nam) nam.nam$l_type
4901 #define rms_nam_ver(nam) nam.nam$l_ver
4902 #define rms_nam_verl(nam) nam.nam$l_ver
4903 #define rms_nam_rsll(nam) nam.nam$b_rsl
4904 #define rms_nam_rsl(nam) nam.nam$b_rsl
4905 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4906 #define rms_set_fna(fab, nam, name, size) \
4907         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4908 #define rms_get_fna(fab, nam) fab.fab$l_fna
4909 #define rms_set_dna(fab, nam, name, size) \
4910         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4911 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4912 #define rms_set_esa(nam, name, size) \
4913         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4914 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4915         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4916 #define rms_set_rsa(nam, name, size) \
4917         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4918 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4919         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4920 #define rms_nam_name_type_l_size(nam) \
4921         (nam.nam$b_name + nam.nam$b_type)
4922 #else
4923 static int rms_free_search_context(struct FAB * fab)
4924 {
4925 struct NAML * nam;
4926
4927     nam = fab->fab$l_naml;
4928     nam->naml$b_nop |= NAM$M_SYNCHK;
4929     nam->naml$l_rlf = NULL;
4930     nam->naml$l_long_defname_size = 0;
4931
4932     fab->fab$b_dns = 0;
4933     return sys$parse(fab, NULL, NULL);
4934 }
4935
4936 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4937 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4938 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4939 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4940 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4941 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4942 #define rms_nam_esl(nam) nam.naml$b_esl
4943 #define rms_nam_name(nam) nam.naml$l_name
4944 #define rms_nam_namel(nam) nam.naml$l_long_name
4945 #define rms_nam_type(nam) nam.naml$l_type
4946 #define rms_nam_typel(nam) nam.naml$l_long_type
4947 #define rms_nam_ver(nam) nam.naml$l_ver
4948 #define rms_nam_verl(nam) nam.naml$l_long_ver
4949 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4950 #define rms_nam_rsl(nam) nam.naml$b_rsl
4951 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4952 #define rms_set_fna(fab, nam, name, size) \
4953         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4954         nam.naml$l_long_filename_size = size; \
4955         nam.naml$l_long_filename = name;}
4956 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4957 #define rms_set_dna(fab, nam, name, size) \
4958         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4959         nam.naml$l_long_defname_size = size; \
4960         nam.naml$l_long_defname = name; }
4961 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4962 #define rms_set_esa(nam, name, size) \
4963         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4964         nam.naml$l_long_expand_alloc = size; \
4965         nam.naml$l_long_expand = name; }
4966 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4967         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4968         nam.naml$l_long_expand = l_name; \
4969         nam.naml$l_long_expand_alloc = l_size; }
4970 #define rms_set_rsa(nam, name, size) \
4971         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4972         nam.naml$l_long_result = name; \
4973         nam.naml$l_long_result_alloc = size; }
4974 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4975         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4976         nam.naml$l_long_result = l_name; \
4977         nam.naml$l_long_result_alloc = l_size; }
4978 #define rms_nam_name_type_l_size(nam) \
4979         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4980 #endif
4981
4982
4983 /* rms_erase
4984  * The CRTL for 8.3 and later can create symbolic links in any mode,
4985  * however in 8.3 the unlink/remove/delete routines will only properly handle
4986  * them if one of the PCP modes is active.
4987  */
4988 static int rms_erase(const char * vmsname)
4989 {
4990   int status;
4991   struct FAB myfab = cc$rms_fab;
4992   rms_setup_nam(mynam);
4993
4994   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4995   rms_bind_fab_nam(myfab, mynam);
4996
4997   /* Are we removing all versions? */
4998   if (vms_unlink_all_versions == 1) {
4999     const char * defspec = ";*";
5000     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5001   }
5002
5003 #ifdef NAML$M_OPEN_SPECIAL
5004   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5005 #endif
5006
5007   status = sys$erase(&myfab, 0, 0);
5008
5009   return status;
5010 }
5011
5012
5013 static int
5014 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5015                     const struct dsc$descriptor_s * vms_dst_dsc,
5016                     unsigned long flags)
5017 {
5018     /*  VMS and UNIX handle file permissions differently and the
5019      * the same ACL trick may be needed for renaming files,
5020      * especially if they are directories.
5021      */
5022
5023    /* todo: get kill_file and rename to share common code */
5024    /* I can not find online documentation for $change_acl
5025     * it appears to be replaced by $set_security some time ago */
5026
5027 const unsigned int access_mode = 0;
5028 $DESCRIPTOR(obj_file_dsc,"FILE");
5029 char *vmsname;
5030 char *rslt;
5031 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
5032 int aclsts, fndsts, rnsts = -1;
5033 unsigned int ctx = 0;
5034 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5035 struct dsc$descriptor_s * clean_dsc;
5036
5037 struct myacedef {
5038     unsigned char myace$b_length;
5039     unsigned char myace$b_type;
5040     unsigned short int myace$w_flags;
5041     unsigned long int myace$l_access;
5042     unsigned long int myace$l_ident;
5043 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5044              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5045              0},
5046              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5047
5048 struct item_list_3
5049         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5050                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5051                       {0,0,0,0}},
5052         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5053         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5054                      {0,0,0,0}};
5055
5056
5057     /* Expand the input spec using RMS, since we do not want to put
5058      * ACLs on the target of a symbolic link */
5059     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
5060     if (vmsname == NULL)
5061         return SS$_INSFMEM;
5062
5063     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5064                         vmsname,
5065                         PERL_RMSEXPAND_M_SYMLINK);
5066     if (rslt == NULL) {
5067         PerlMem_free(vmsname);
5068         return SS$_INSFMEM;
5069     }
5070
5071     /* So we get our own UIC to use as a rights identifier,
5072      * and the insert an ACE at the head of the ACL which allows us
5073      * to delete the file.
5074      */
5075     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5076
5077     fildsc.dsc$w_length = strlen(vmsname);
5078     fildsc.dsc$a_pointer = vmsname;
5079     ctx = 0;
5080     newace.myace$l_ident = oldace.myace$l_ident;
5081     rnsts = SS$_ABORT;
5082
5083     /* Grab any existing ACEs with this identifier in case we fail */
5084     clean_dsc = &fildsc;
5085     aclsts = fndsts = sys$get_security(&obj_file_dsc,
5086                                &fildsc,
5087                                NULL,
5088                                OSS$M_WLOCK,
5089                                findlst,
5090                                &ctx,
5091                                &access_mode);
5092
5093     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
5094         /* Add the new ACE . . . */
5095
5096         /* if the sys$get_security succeeded, then ctx is valid, and the
5097          * object/file descriptors will be ignored.  But otherwise they
5098          * are needed
5099          */
5100         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5101                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
5102         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5103             set_errno(EVMSERR);
5104             set_vaxc_errno(aclsts);
5105             PerlMem_free(vmsname);
5106             return aclsts;
5107         }
5108
5109         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5110                                 NULL, NULL,
5111                                 &flags,
5112                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5113
5114         if ($VMS_STATUS_SUCCESS(rnsts)) {
5115             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5116         }
5117
5118         /* Put things back the way they were. */
5119         ctx = 0;
5120         aclsts = sys$get_security(&obj_file_dsc,
5121                                   clean_dsc,
5122                                   NULL,
5123                                   OSS$M_WLOCK,
5124                                   findlst,
5125                                   &ctx,
5126                                   &access_mode);
5127
5128         if ($VMS_STATUS_SUCCESS(aclsts)) {
5129         int sec_flags;
5130
5131             sec_flags = 0;
5132             if (!$VMS_STATUS_SUCCESS(fndsts))
5133                 sec_flags = OSS$M_RELCTX;
5134
5135             /* Get rid of the new ACE */
5136             aclsts = sys$set_security(NULL, NULL, NULL,
5137                                   sec_flags, dellst, &ctx, &access_mode);
5138
5139             /* If there was an old ACE, put it back */
5140             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5141                 addlst[0].bufadr = &oldace;
5142                 aclsts = sys$set_security(NULL, NULL, NULL,
5143                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5144                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5145                     set_errno(EVMSERR);
5146                     set_vaxc_errno(aclsts);
5147                     rnsts = aclsts;
5148                 }
5149             } else {
5150             int aclsts2;
5151
5152                 /* Try to clear the lock on the ACL list */
5153                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5154                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5155
5156                 /* Rename errors are most important */
5157                 if (!$VMS_STATUS_SUCCESS(rnsts))
5158                     aclsts = rnsts;
5159                 set_errno(EVMSERR);
5160                 set_vaxc_errno(aclsts);
5161                 rnsts = aclsts;
5162             }
5163         }
5164         else {
5165             if (aclsts != SS$_ACLEMPTY)
5166                 rnsts = aclsts;
5167         }
5168     }
5169     else
5170         rnsts = fndsts;
5171
5172     PerlMem_free(vmsname);
5173     return rnsts;
5174 }
5175
5176
5177 /*{{{int rename(const char *, const char * */
5178 /* Not exactly what X/Open says to do, but doing it absolutely right
5179  * and efficiently would require a lot more work.  This should be close
5180  * enough to pass all but the most strict X/Open compliance test.
5181  */
5182 int
5183 Perl_rename(pTHX_ const char *src, const char * dst)
5184 {
5185 int retval;
5186 int pre_delete = 0;
5187 int src_sts;
5188 int dst_sts;
5189 Stat_t src_st;
5190 Stat_t dst_st;
5191
5192     /* Validate the source file */
5193     src_sts = flex_lstat(src, &src_st);
5194     if (src_sts != 0) {
5195
5196         /* No source file or other problem */
5197         return src_sts;
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, S_ISDIR(dst_st.st_mode));
5245             if (d_sts != 0)
5246                 return d_sts;
5247
5248             /* We killed the destination, so only errno now is EIO */
5249             pre_delete = 1;
5250         }
5251     }
5252
5253     /* Originally the idea was to call the CRTL rename() and only
5254      * try the lib$rename_file if it failed.
5255      * It turns out that there are too many variants in what the
5256      * the CRTL rename might do, so only use lib$rename_file
5257      */
5258     retval = -1;
5259
5260     {
5261         /* Is the source and dest both in VMS format */
5262         /* if the source is a directory, then need to fileify */
5263         /*  and dest must be a directory or non-existant. */
5264
5265         char * vms_src;
5266         char * vms_dst;
5267         int sts;
5268         char * ret_str;
5269         unsigned long flags;
5270         struct dsc$descriptor_s old_file_dsc;
5271         struct dsc$descriptor_s new_file_dsc;
5272
5273         /* We need to modify the src and dst depending
5274          * on if one or more of them are directories.
5275          */
5276
5277         vms_src = PerlMem_malloc(VMS_MAXRSS);
5278         if (vms_src == NULL)
5279             _ckvmssts_noperl(SS$_INSFMEM);
5280
5281         /* Source is always a VMS format file */
5282         ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5283         if (ret_str == NULL) {
5284             PerlMem_free(vms_src);
5285             errno = EIO;
5286             return -1;
5287         }
5288
5289         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5290         if (vms_dst == NULL)
5291             _ckvmssts_noperl(SS$_INSFMEM);
5292
5293         if (S_ISDIR(src_st.st_mode)) {
5294         char * ret_str;
5295         char * vms_dir_file;
5296
5297             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5298             if (vms_dir_file == NULL)
5299                 _ckvmssts_noperl(SS$_INSFMEM);
5300
5301             /* The source must be a file specification */
5302             ret_str = int_fileify_dirspec(vms_src, vms_dir_file, NULL);
5303             if (ret_str == NULL) {
5304                 PerlMem_free(vms_src);
5305                 PerlMem_free(vms_dst);
5306                 PerlMem_free(vms_dir_file);
5307                 errno = EIO;
5308                 return -1;
5309             }
5310             PerlMem_free(vms_src);
5311             vms_src = vms_dir_file;
5312
5313             /* If the dest is a directory, we must remove it
5314             if (dst_sts == 0) {
5315                 int d_sts;
5316                 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5317                 if (d_sts != 0) {
5318                     PerlMem_free(vms_src);
5319                     PerlMem_free(vms_dst);
5320                     errno = EIO;
5321                     return sts;
5322                 }
5323
5324                 pre_delete = 1;
5325             }
5326
5327            /* The dest must be a VMS file specification */
5328            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5329            if (ret_str == NULL) {
5330                 PerlMem_free(vms_src);
5331                 PerlMem_free(vms_dst);
5332                 errno = EIO;
5333                 return -1;
5334            }
5335
5336             /* The source must be a file specification */
5337             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5338             if (vms_dir_file == NULL)
5339                 _ckvmssts_noperl(SS$_INSFMEM);
5340
5341             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5342             if (ret_str == NULL) {
5343                 PerlMem_free(vms_src);
5344                 PerlMem_free(vms_dst);
5345                 PerlMem_free(vms_dir_file);
5346                 errno = EIO;
5347                 return -1;
5348             }
5349             PerlMem_free(vms_dst);
5350             vms_dst = vms_dir_file;
5351
5352         } else {
5353             /* File to file or file to new dir */
5354
5355             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5356                 /* VMS pathify a dir target */
5357                 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5358                 if (ret_str == NULL) {
5359                     PerlMem_free(vms_src);
5360                     PerlMem_free(vms_dst);
5361                     errno = EIO;
5362                     return -1;
5363                 }
5364             } else {
5365
5366                 /* fileify a target VMS file specification */
5367                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5368                 if (ret_str == NULL) {
5369                     PerlMem_free(vms_src);
5370                     PerlMem_free(vms_dst);
5371                     errno = EIO;
5372                     return -1;
5373                 }
5374             }
5375         }
5376
5377         old_file_dsc.dsc$a_pointer = vms_src;
5378         old_file_dsc.dsc$w_length = strlen(vms_src);
5379         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5380         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5381
5382         new_file_dsc.dsc$a_pointer = vms_dst;
5383         new_file_dsc.dsc$w_length = strlen(vms_dst);
5384         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5385         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5386
5387         flags = 0;
5388 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5389         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5390 #endif
5391
5392         sts = lib$rename_file(&old_file_dsc,
5393                               &new_file_dsc,
5394                               NULL, NULL,
5395                               &flags,
5396                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5397         if (!$VMS_STATUS_SUCCESS(sts)) {
5398
5399            /* We could have failed because VMS style permissions do not
5400             * permit renames that UNIX will allow.  Just like the hack
5401             * in for kill_file.
5402             */
5403            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5404         }
5405
5406         PerlMem_free(vms_src);
5407         PerlMem_free(vms_dst);
5408         if (!$VMS_STATUS_SUCCESS(sts)) {
5409             errno = EIO;
5410             return -1;
5411         }
5412         retval = 0;
5413     }
5414
5415     if (vms_unlink_all_versions) {
5416         /* Now get rid of any previous versions of the source file that
5417          * might still exist
5418          */
5419         int save_errno;
5420         save_errno = errno;
5421         src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5422         errno = save_errno;
5423     }
5424
5425     /* We deleted the destination, so must force the error to be EIO */
5426     if ((retval != 0) && (pre_delete != 0))
5427         errno = EIO;
5428
5429     return retval;
5430 }
5431 /*}}}*/
5432
5433
5434 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5435 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5436  * to expand file specification.  Allows for a single default file
5437  * specification and a simple mask of options.  If outbuf is non-NULL,
5438  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5439  * the resultant file specification is placed.  If outbuf is NULL, the
5440  * resultant file specification is placed into a static buffer.
5441  * The third argument, if non-NULL, is taken to be a default file
5442  * specification string.  The fourth argument is unused at present.
5443  * rmesexpand() returns the address of the resultant string if
5444  * successful, and NULL on error.
5445  *
5446  * New functionality for previously unused opts value:
5447  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5448  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5449  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5450  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5451  */
5452 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5453
5454 static char *
5455 int_rmsexpand
5456    (const char *filespec,
5457     char *outbuf,
5458     const char *defspec,
5459     unsigned opts,
5460     int * fs_utf8,
5461     int * dfs_utf8)
5462 {
5463   char * ret_spec;
5464   const char * in_spec;
5465   char * spec_buf;
5466   const char * def_spec;
5467   char * vmsfspec, *vmsdefspec;
5468   char * esa;
5469   char * esal = NULL;
5470   char * outbufl;
5471   struct FAB myfab = cc$rms_fab;
5472   rms_setup_nam(mynam);
5473   STRLEN speclen;
5474   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5475   int sts;
5476
5477   /* temp hack until UTF8 is actually implemented */
5478   if (fs_utf8 != NULL)
5479     *fs_utf8 = 0;
5480
5481   if (!filespec || !*filespec) {
5482     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5483     return NULL;
5484   }
5485
5486   vmsfspec = NULL;
5487   vmsdefspec = NULL;
5488   outbufl = NULL;
5489
5490   in_spec = filespec;
5491   isunix = 0;
5492   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5493       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5494       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5495
5496       /* If this is a UNIX file spec, convert it to VMS */
5497       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5498                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5499                            &e_len, &vs_spec, &vs_len);
5500       if (sts != 0) {
5501           isunix = 1;
5502           char * ret_spec;
5503
5504           vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5505           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5506           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5507           if (ret_spec == NULL) {
5508               PerlMem_free(vmsfspec);
5509               return NULL;
5510           }
5511           in_spec = (const char *)vmsfspec;
5512
5513           /* Unless we are forcing to VMS format, a UNIX input means
5514            * UNIX output, and that requires long names to be used
5515            */
5516           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5517 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5518               opts |= PERL_RMSEXPAND_M_LONG;
5519 #endif
5520           else
5521               isunix = 0;
5522       }
5523
5524   }
5525
5526   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5527   rms_bind_fab_nam(myfab, mynam);
5528
5529   /* Process the default file specification if present */
5530   def_spec = defspec;
5531   if (defspec && *defspec) {
5532     int t_isunix;
5533     t_isunix = is_unix_filespec(defspec);
5534     if (t_isunix) {
5535       vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
5536       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5537       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5538
5539       if (ret_spec == NULL) {
5540           /* Clean up and bail */
5541           PerlMem_free(vmsdefspec);
5542           if (vmsfspec != NULL)
5543               PerlMem_free(vmsfspec);
5544               return NULL;
5545           }
5546           def_spec = (const char *)vmsdefspec;
5547       }
5548       rms_set_dna(myfab, mynam,
5549                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5550   }
5551
5552   /* Now we need the expansion buffers */
5553   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5554   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5555 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5556   esal = PerlMem_malloc(VMS_MAXRSS);
5557   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5558 #endif
5559   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5560
5561   /* If a NAML block is used RMS always writes to the long and short
5562    * addresses unless you suppress the short name.
5563    */
5564 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5565   outbufl = PerlMem_malloc(VMS_MAXRSS);
5566   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5567 #endif
5568    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5569
5570 #ifdef NAM$M_NO_SHORT_UPCASE
5571   if (decc_efs_case_preserve)
5572     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5573 #endif
5574
5575    /* We may not want to follow symbolic links */
5576 #ifdef NAML$M_OPEN_SPECIAL
5577   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5578     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5579 #endif
5580
5581   /* First attempt to parse as an existing file */
5582   retsts = sys$parse(&myfab,0,0);
5583   if (!(retsts & STS$K_SUCCESS)) {
5584
5585     /* Could not find the file, try as syntax only if error is not fatal */
5586     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5587     if (retsts == RMS$_DNF ||
5588         retsts == RMS$_DIR ||
5589         retsts == RMS$_DEV ||
5590         retsts == RMS$_PRV) {
5591       retsts = sys$parse(&myfab,0,0);
5592       if (retsts & STS$K_SUCCESS) goto int_expanded;
5593     }
5594
5595      /* Still could not parse the file specification */
5596     /*----------------------------------------------*/
5597     sts = rms_free_search_context(&myfab); /* Free search context */
5598     if (vmsdefspec != NULL)
5599         PerlMem_free(vmsdefspec);
5600     if (vmsfspec != NULL)
5601         PerlMem_free(vmsfspec);
5602     if (outbufl != NULL)
5603         PerlMem_free(outbufl);
5604     PerlMem_free(esa);
5605     if (esal != NULL)
5606         PerlMem_free(esal);
5607     set_vaxc_errno(retsts);
5608     if      (retsts == RMS$_PRV) set_errno(EACCES);
5609     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5610     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5611     else                         set_errno(EVMSERR);
5612     return NULL;
5613   }
5614   retsts = sys$search(&myfab,0,0);
5615   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5616     sts = rms_free_search_context(&myfab); /* Free search context */
5617     if (vmsdefspec != NULL)
5618         PerlMem_free(vmsdefspec);
5619     if (vmsfspec != NULL)
5620         PerlMem_free(vmsfspec);
5621     if (outbufl != NULL)
5622         PerlMem_free(outbufl);
5623     PerlMem_free(esa);
5624     if (esal != NULL)
5625         PerlMem_free(esal);
5626     set_vaxc_errno(retsts);
5627     if      (retsts == RMS$_PRV) set_errno(EACCES);
5628     else                         set_errno(EVMSERR);
5629     return NULL;
5630   }
5631
5632   /* If the input filespec contained any lowercase characters,
5633    * downcase the result for compatibility with Unix-minded code. */
5634 int_expanded:
5635   if (!decc_efs_case_preserve) {
5636     char * tbuf;
5637     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5638       if (islower(*tbuf)) { haslower = 1; break; }
5639   }
5640
5641    /* Is a long or a short name expected */
5642   /*------------------------------------*/
5643   spec_buf = NULL;
5644   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5645     if (rms_nam_rsll(mynam)) {
5646         spec_buf = outbufl;
5647         speclen = rms_nam_rsll(mynam);
5648     }
5649     else {
5650         spec_buf = esal; /* Not esa */
5651         speclen = rms_nam_esll(mynam);
5652     }
5653   }
5654   else {
5655     if (rms_nam_rsl(mynam)) {
5656         spec_buf = outbuf;
5657         speclen = rms_nam_rsl(mynam);
5658     }
5659     else {
5660         spec_buf = esa; /* Not esal */
5661         speclen = rms_nam_esl(mynam);
5662     }
5663   }
5664   spec_buf[speclen] = '\0';
5665
5666   /* Trim off null fields added by $PARSE
5667    * If type > 1 char, must have been specified in original or default spec
5668    * (not true for version; $SEARCH may have added version of existing file).
5669    */
5670   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5671   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5672     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5673              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5674   }
5675   else {
5676     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5677              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5678   }
5679   if (trimver || trimtype) {
5680     if (defspec && *defspec) {
5681       char *defesal = NULL;
5682       char *defesa = NULL;
5683       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5684       if (defesa != NULL) {
5685         struct FAB deffab = cc$rms_fab;
5686 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5687         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5688         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5689 #endif
5690         rms_setup_nam(defnam);
5691
5692         rms_bind_fab_nam(deffab, defnam);
5693
5694         /* Cast ok */
5695         rms_set_fna
5696             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5697
5698         /* RMS needs the esa/esal as a work area if wildcards are involved */
5699         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5700
5701         rms_clear_nam_nop(defnam);
5702         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5703 #ifdef NAM$M_NO_SHORT_UPCASE
5704         if (decc_efs_case_preserve)
5705           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5706 #endif
5707 #ifdef NAML$M_OPEN_SPECIAL
5708         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5709           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5710 #endif
5711         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5712           if (trimver) {
5713              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5714           }
5715           if (trimtype) {
5716             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5717           }
5718         }
5719         if (defesal != NULL)
5720             PerlMem_free(defesal);
5721         PerlMem_free(defesa);
5722       } else {
5723           _ckvmssts_noperl(SS$_INSFMEM);
5724       }
5725     }
5726     if (trimver) {
5727       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5728         if (*(rms_nam_verl(mynam)) != '\"')
5729           speclen = rms_nam_verl(mynam) - spec_buf;
5730       }
5731       else {
5732         if (*(rms_nam_ver(mynam)) != '\"')
5733           speclen = rms_nam_ver(mynam) - spec_buf;
5734       }
5735     }
5736     if (trimtype) {
5737       /* If we didn't already trim version, copy down */
5738       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5739         if (speclen > rms_nam_verl(mynam) - spec_buf)
5740           memmove
5741            (rms_nam_typel(mynam),
5742             rms_nam_verl(mynam),
5743             speclen - (rms_nam_verl(mynam) - spec_buf));
5744           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5745       }
5746       else {
5747         if (speclen > rms_nam_ver(mynam) - spec_buf)
5748           memmove
5749            (rms_nam_type(mynam),
5750             rms_nam_ver(mynam),
5751             speclen - (rms_nam_ver(mynam) - spec_buf));
5752           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5753       }
5754     }
5755   }
5756
5757    /* Done with these copies of the input files */
5758   /*-------------------------------------------*/
5759   if (vmsfspec != NULL)
5760         PerlMem_free(vmsfspec);
5761   if (vmsdefspec != NULL)
5762         PerlMem_free(vmsdefspec);
5763
5764   /* If we just had a directory spec on input, $PARSE "helpfully"
5765    * adds an empty name and type for us */
5766 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5767   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5768     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5769         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5770         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5771       speclen = rms_nam_namel(mynam) - spec_buf;
5772   }
5773   else
5774 #endif
5775   {
5776     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5777         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5778         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5779       speclen = rms_nam_name(mynam) - spec_buf;
5780   }
5781
5782   /* Posix format specifications must have matching quotes */
5783   if (speclen < (VMS_MAXRSS - 1)) {
5784     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5785       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5786         spec_buf[speclen] = '\"';
5787         speclen++;
5788       }
5789     }
5790   }
5791   spec_buf[speclen] = '\0';
5792   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5793
5794   /* Have we been working with an expanded, but not resultant, spec? */
5795   /* Also, convert back to Unix syntax if necessary. */
5796   {
5797   int rsl;
5798
5799 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5800     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5801       rsl = rms_nam_rsll(mynam);
5802     } else
5803 #endif
5804     {
5805       rsl = rms_nam_rsl(mynam);
5806     }
5807     if (!rsl) {
5808       /* rsl is not present, it means that spec_buf is either */
5809       /* esa or esal, and needs to be copied to outbuf */
5810       /* convert to Unix if desired */
5811       if (isunix) {
5812         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5813       } else {
5814         /* VMS file specs are not in UTF-8 */
5815         if (fs_utf8 != NULL)
5816             *fs_utf8 = 0;
5817         strcpy(outbuf, spec_buf);
5818         ret_spec = outbuf;
5819       }
5820     }
5821     else {
5822       /* Now spec_buf is either outbuf or outbufl */
5823       /* We need the result into outbuf */
5824       if (isunix) {
5825            /* If we need this in UNIX, then we need another buffer */
5826            /* to keep things in order */
5827            char * src;
5828            char * new_src = NULL;
5829            if (spec_buf == outbuf) {
5830                new_src = PerlMem_malloc(VMS_MAXRSS);
5831                strcpy(new_src, spec_buf);
5832            } else {
5833                src = spec_buf;
5834            }
5835            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5836            if (new_src) {
5837                PerlMem_free(new_src);
5838            }
5839       } else {
5840            /* VMS file specs are not in UTF-8 */
5841            if (fs_utf8 != NULL)
5842                *fs_utf8 = 0;
5843
5844            /* Copy the buffer if needed */
5845            if (outbuf != spec_buf)
5846                strcpy(outbuf, spec_buf);
5847            ret_spec = outbuf;
5848       }
5849     }
5850   }
5851
5852   /* Need to clean up the search context */
5853   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5854   sts = rms_free_search_context(&myfab); /* Free search context */
5855
5856   /* Clean up the extra buffers */
5857   if (esal != NULL)
5858       PerlMem_free(esal);
5859   PerlMem_free(esa);
5860   if (outbufl != NULL)
5861      PerlMem_free(outbufl);
5862
5863   /* Return the result */
5864   return ret_spec;
5865 }
5866
5867 /* Common simple case - Expand an already VMS spec */
5868 static char *
5869 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5870     opts |= PERL_RMSEXPAND_M_VMS_IN;
5871     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5872 }
5873
5874 /* Common simple case - Expand to a VMS spec */
5875 static char *
5876 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5877     opts |= PERL_RMSEXPAND_M_VMS;
5878     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5879 }
5880
5881
5882 /* Entry point used by perl routines */
5883 static char *
5884 mp_do_rmsexpand
5885    (pTHX_ const char *filespec,
5886     char *outbuf,
5887     int ts,
5888     const char *defspec,
5889     unsigned opts,
5890     int * fs_utf8,
5891     int * dfs_utf8)
5892 {
5893     static char __rmsexpand_retbuf[VMS_MAXRSS];
5894     char * expanded, *ret_spec, *ret_buf;
5895
5896     expanded = NULL;
5897     ret_buf = outbuf;
5898     if (ret_buf == NULL) {
5899         if (ts) {
5900             Newx(expanded, VMS_MAXRSS, char);
5901             if (expanded == NULL)
5902                 _ckvmssts(SS$_INSFMEM);
5903             ret_buf = expanded;
5904         } else {
5905             ret_buf = __rmsexpand_retbuf;
5906         }
5907     }
5908
5909
5910     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5911                              opts, fs_utf8,  dfs_utf8);
5912
5913     if (ret_spec == NULL) {
5914        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5915        if (expanded)
5916            Safefree(expanded);
5917     }
5918
5919     return ret_spec;
5920 }
5921 /*}}}*/
5922 /* External entry points */
5923 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5924 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5925 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5926 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5927 char *Perl_rmsexpand_utf8
5928   (pTHX_ const char *spec, char *buf, const char *def,
5929    unsigned opt, int * fs_utf8, int * dfs_utf8)
5930 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5931 char *Perl_rmsexpand_utf8_ts
5932   (pTHX_ const char *spec, char *buf, const char *def,
5933    unsigned opt, int * fs_utf8, int * dfs_utf8)
5934 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5935
5936
5937 /*
5938 ** The following routines are provided to make life easier when
5939 ** converting among VMS-style and Unix-style directory specifications.
5940 ** All will take input specifications in either VMS or Unix syntax. On
5941 ** failure, all return NULL.  If successful, the routines listed below
5942 ** return a pointer to a buffer containing the appropriately
5943 ** reformatted spec (and, therefore, subsequent calls to that routine
5944 ** will clobber the result), while the routines of the same names with
5945 ** a _ts suffix appended will return a pointer to a mallocd string
5946 ** containing the appropriately reformatted spec.
5947 ** In all cases, only explicit syntax is altered; no check is made that
5948 ** the resulting string is valid or that the directory in question
5949 ** actually exists.
5950 **
5951 **   fileify_dirspec() - convert a directory spec into the name of the
5952 **     directory file (i.e. what you can stat() to see if it's a dir).
5953 **     The style (VMS or Unix) of the result is the same as the style
5954 **     of the parameter passed in.
5955 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5956 **     what you prepend to a filename to indicate what directory it's in).
5957 **     The style (VMS or Unix) of the result is the same as the style
5958 **     of the parameter passed in.
5959 **   tounixpath() - convert a directory spec into a Unix-style path.
5960 **   tovmspath() - convert a directory spec into a VMS-style path.
5961 **   tounixspec() - convert any file spec into a Unix-style file spec.
5962 **   tovmsspec() - convert any file spec into a VMS-style spec.
5963 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5964 **
5965 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5966 ** Permission is given to distribute this code as part of the Perl
5967 ** standard distribution under the terms of the GNU General Public
5968 ** License or the Perl Artistic License.  Copies of each may be
5969 ** found in the Perl standard distribution.
5970  */
5971
5972 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5973 static char *
5974 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
5975 {
5976     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5977     char *cp1, *cp2, *lastdir;
5978     char *trndir, *vmsdir;
5979     unsigned short int trnlnm_iter_count;
5980     int is_vms = 0;
5981     int is_unix = 0;
5982     int sts;
5983     if (utf8_fl != NULL)
5984         *utf8_fl = 0;
5985
5986     if (!dir || !*dir) {
5987       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5988     }
5989     dirlen = strlen(dir);
5990     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5991     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5992       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5993         dir = "/sys$disk";
5994         dirlen = 9;
5995       }
5996       else
5997         dirlen = 1;
5998     }
5999     if (dirlen > (VMS_MAXRSS - 1)) {
6000       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6001       return NULL;
6002     }
6003     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
6004     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6005     if (!strpbrk(dir+1,"/]>:")  &&
6006         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
6007       strcpy(trndir,*dir == '/' ? dir + 1: dir);
6008       trnlnm_iter_count = 0;
6009       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6010         trnlnm_iter_count++;
6011         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6012       }
6013       dirlen = strlen(trndir);
6014     }
6015     else {
6016       strncpy(trndir,dir,dirlen);
6017       trndir[dirlen] = '\0';
6018     }
6019
6020     /* At this point we are done with *dir and use *trndir which is a
6021      * copy that can be modified.  *dir must not be modified.
6022      */
6023
6024     /* If we were handed a rooted logical name or spec, treat it like a
6025      * simple directory, so that
6026      *    $ Define myroot dev:[dir.]
6027      *    ... do_fileify_dirspec("myroot",buf,1) ...
6028      * does something useful.
6029      */
6030     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6031       trndir[--dirlen] = '\0';
6032       trndir[dirlen-1] = ']';
6033     }
6034     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6035       trndir[--dirlen] = '\0';
6036       trndir[dirlen-1] = '>';
6037     }
6038
6039     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6040       /* If we've got an explicit filename, we can just shuffle the string. */
6041       if (*(cp1+1)) hasfilename = 1;
6042       /* Similarly, we can just back up a level if we've got multiple levels
6043          of explicit directories in a VMS spec which ends with directories. */
6044       else {
6045         for (cp2 = cp1; cp2 > trndir; cp2--) {
6046           if (*cp2 == '.') {
6047             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6048 /* fix-me, can not scan EFS file specs backward like this */
6049               *cp2 = *cp1; *cp1 = '\0';
6050               hasfilename = 1;
6051               break;
6052             }
6053           }
6054           if (*cp2 == '[' || *cp2 == '<') break;
6055         }
6056       }
6057     }
6058
6059     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
6060     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6061     cp1 = strpbrk(trndir,"]:>");
6062     if (hasfilename || !cp1) { /* filename present or not VMS */
6063
6064       if (decc_efs_charset && !cp1) {
6065
6066           /* EFS handling for UNIX mode */
6067
6068           /* Just remove the trailing '/' and we should be done */
6069           STRLEN trndir_len;
6070           trndir_len = strlen(trndir);
6071
6072           if (trndir_len > 1) {
6073               trndir_len--;
6074               if (trndir[trndir_len] == '/') {
6075                   trndir[trndir_len] = '\0';
6076               }
6077           }
6078           strcpy(buf, trndir);
6079           PerlMem_free(trndir);
6080           PerlMem_free(vmsdir);
6081           return buf;
6082       }
6083
6084       /* For non-EFS mode, this is left for backwards compatibility */
6085       /* For EFS mode, this is only done for VMS format filespecs as */
6086       /* Perl programs generally have problems when a UNIX format spec */
6087       /* returns a VMS format spec */
6088       if (trndir[0] == '.') {
6089         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6090           PerlMem_free(trndir);
6091           PerlMem_free(vmsdir);
6092           return int_fileify_dirspec("[]", buf, NULL);
6093         }
6094         else if (trndir[1] == '.' &&
6095                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6096           PerlMem_free(trndir);
6097           PerlMem_free(vmsdir);
6098           return int_fileify_dirspec("[-]", buf, NULL);
6099         }
6100       }
6101       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6102         dirlen -= 1;                 /* to last element */
6103         lastdir = strrchr(trndir,'/');
6104       }
6105       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6106         /* If we have "/." or "/..", VMSify it and let the VMS code
6107          * below expand it, rather than repeating the code to handle
6108          * relative components of a filespec here */
6109         do {
6110           if (*(cp1+2) == '.') cp1++;
6111           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6112             char * ret_chr;
6113             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6114                 PerlMem_free(trndir);
6115                 PerlMem_free(vmsdir);
6116                 return NULL;
6117             }
6118             if (strchr(vmsdir,'/') != NULL) {
6119               /* If int_tovmsspec() returned it, it must have VMS syntax
6120                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6121                * the time to check this here only so we avoid a recursion
6122                * loop; otherwise, gigo.
6123                */
6124               PerlMem_free(trndir);
6125               PerlMem_free(vmsdir);
6126               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6127               return NULL;
6128             }
6129             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6130                 PerlMem_free(trndir);
6131                 PerlMem_free(vmsdir);
6132                 return NULL;
6133             }
6134             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6135             PerlMem_free(trndir);
6136             PerlMem_free(vmsdir);
6137             return ret_chr;
6138           }
6139           cp1++;
6140         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6141         lastdir = strrchr(trndir,'/');
6142       }
6143       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6144         char * ret_chr;
6145         /* Ditto for specs that end in an MFD -- let the VMS code
6146          * figure out whether it's a real device or a rooted logical. */
6147
6148         /* This should not happen any more.  Allowing the fake /000000
6149          * in a UNIX pathname causes all sorts of problems when trying
6150          * to run in UNIX emulation.  So the VMS to UNIX conversions
6151          * now remove the fake /000000 directories.
6152          */
6153
6154         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6155         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6156             PerlMem_free(trndir);
6157             PerlMem_free(vmsdir);
6158             return NULL;
6159         }
6160         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6161             PerlMem_free(trndir);
6162             PerlMem_free(vmsdir);
6163             return NULL;
6164         }
6165         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6166         PerlMem_free(trndir);
6167         PerlMem_free(vmsdir);
6168         return ret_chr;
6169       }
6170       else {
6171
6172         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6173              !(lastdir = cp1 = strrchr(trndir,']')) &&
6174              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6175
6176         cp2 = strrchr(cp1,'.');
6177         if (cp2) {
6178             int e_len, vs_len = 0;
6179             int is_dir = 0;
6180             char * cp3;
6181             cp3 = strchr(cp2,';');
6182             e_len = strlen(cp2);
6183             if (cp3) {
6184                 vs_len = strlen(cp3);
6185                 e_len = e_len - vs_len;
6186             }
6187             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6188             if (!is_dir) {
6189                 if (!decc_efs_charset) {
6190                     /* If this is not EFS, then not a directory */
6191                     PerlMem_free(trndir);
6192                     PerlMem_free(vmsdir);
6193                     set_errno(ENOTDIR);
6194                     set_vaxc_errno(RMS$_DIR);
6195                     return NULL;
6196                 }
6197             } else {
6198                 /* Ok, here we have an issue, technically if a .dir shows */
6199                 /* from inside a directory, then we should treat it as */
6200                 /* xxx^.dir.dir.  But we do not have that context at this */
6201                 /* point unless this is totally restructured, so we remove */
6202                 /* The .dir for now, and fix this better later */
6203                 dirlen = cp2 - trndir;
6204             }
6205         }
6206
6207       }
6208
6209       retlen = dirlen + 6;
6210       memcpy(buf, trndir, dirlen);
6211       buf[dirlen] = '\0';
6212
6213       /* We've picked up everything up to the directory file name.
6214          Now just add the type and version, and we're set. */
6215
6216       /* We should only add type for VMS syntax, but historically Perl
6217          has added it for UNIX style also */
6218
6219       /* Fix me - we should not be using the same routine for VMS and
6220          UNIX format files.  Things are too tangled so we need to lookup
6221          what syntax the output is */
6222
6223       is_unix = 0;
6224       is_vms = 0;
6225       lastdir = strrchr(trndir,'/');
6226       if (lastdir) {
6227           is_unix = 1;
6228       } else {
6229           lastdir = strpbrk(trndir,"]:>");
6230           if (lastdir) {
6231               is_vms = 1;
6232           }
6233       }
6234
6235       if ((is_vms == 0) && (is_unix == 0)) {
6236           /* We still do not  know? */
6237           is_unix = decc_filename_unix_report;
6238           if (is_unix == 0)
6239               is_vms = 1;
6240       }
6241
6242       if ((is_unix && !decc_efs_charset) || is_vms) {
6243
6244            /* It is a bug to add a .dir to a UNIX format directory spec */
6245            /* However Perl on VMS may have programs that expect this so */
6246            /* If not using EFS character specifications allow it. */
6247
6248            if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
6249                /* Traditionally Perl expects filenames in lower case */
6250                strcat(buf, ".dir");
6251            } else {
6252                /* VMS expects the .DIR to be in upper case */
6253                strcat(buf, ".DIR");
6254            }
6255
6256            /* It is also a bug to put a VMS format version on a UNIX file */
6257            /* specification.  Perl self tests are looking for this */
6258            if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
6259                strcat(buf, ";1");
6260       }
6261       PerlMem_free(trndir);
6262       PerlMem_free(vmsdir);
6263       return buf;
6264     }
6265     else {  /* VMS-style directory spec */
6266
6267       char *esa, *esal, term, *cp;
6268       char *my_esa;
6269       int my_esa_len;
6270       unsigned long int sts, cmplen, haslower = 0;
6271       unsigned int nam_fnb;
6272       char * nam_type;
6273       struct FAB dirfab = cc$rms_fab;
6274       rms_setup_nam(savnam);
6275       rms_setup_nam(dirnam);
6276
6277       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6278       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6279       esal = NULL;
6280 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6281       esal = PerlMem_malloc(VMS_MAXRSS);
6282       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6283 #endif
6284       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6285       rms_bind_fab_nam(dirfab, dirnam);
6286       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6287       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6288 #ifdef NAM$M_NO_SHORT_UPCASE
6289       if (decc_efs_case_preserve)
6290         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6291 #endif
6292
6293       for (cp = trndir; *cp; cp++)
6294         if (islower(*cp)) { haslower = 1; break; }
6295       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6296         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6297             (dirfab.fab$l_sts == RMS$_DNF) ||
6298             (dirfab.fab$l_sts == RMS$_PRV)) {
6299             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6300             sts = sys$parse(&dirfab);
6301         }
6302         if (!sts) {
6303           PerlMem_free(esa);
6304           if (esal != NULL)
6305               PerlMem_free(esal);
6306           PerlMem_free(trndir);
6307           PerlMem_free(vmsdir);
6308           set_errno(EVMSERR);
6309           set_vaxc_errno(dirfab.fab$l_sts);
6310           return NULL;
6311         }
6312       }
6313       else {
6314         savnam = dirnam;
6315         /* Does the file really exist? */
6316         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6317           /* Yes; fake the fnb bits so we'll check type below */
6318           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6319         }
6320         else { /* No; just work with potential name */
6321           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6322           else {
6323             int fab_sts;
6324             fab_sts = dirfab.fab$l_sts;
6325             sts = rms_free_search_context(&dirfab);
6326             PerlMem_free(esa);
6327             if (esal != NULL)
6328                 PerlMem_free(esal);
6329             PerlMem_free(trndir);
6330             PerlMem_free(vmsdir);
6331             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6332             return NULL;
6333           }
6334         }
6335       }
6336
6337       /* Make sure we are using the right buffer */
6338       if (esal != NULL) {
6339         my_esa = esal;
6340         my_esa_len = rms_nam_esll(dirnam);
6341       } else {
6342         my_esa = esa;
6343         my_esa_len = rms_nam_esl(dirnam);
6344       }
6345       my_esa[my_esa_len] = '\0';
6346       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6347         cp1 = strchr(my_esa,']');
6348         if (!cp1) cp1 = strchr(my_esa,'>');
6349         if (cp1) {  /* Should always be true */
6350           my_esa_len -= cp1 - my_esa - 1;
6351           memmove(my_esa, cp1 + 1, my_esa_len);
6352         }
6353       }
6354       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6355         /* Yep; check version while we're at it, if it's there. */
6356         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6357         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6358           /* Something other than .DIR[;1].  Bzzt. */
6359           sts = rms_free_search_context(&dirfab);
6360           PerlMem_free(esa);
6361           if (esal != NULL)
6362              PerlMem_free(esal);
6363           PerlMem_free(trndir);
6364           PerlMem_free(vmsdir);
6365           set_errno(ENOTDIR);
6366           set_vaxc_errno(RMS$_DIR);
6367           return NULL;
6368         }
6369       }
6370
6371       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6372         /* They provided at least the name; we added the type, if necessary, */
6373         strcpy(buf, my_esa);
6374         sts = rms_free_search_context(&dirfab);
6375         PerlMem_free(trndir);
6376         PerlMem_free(esa);
6377         if (esal != NULL)
6378             PerlMem_free(esal);
6379         PerlMem_free(vmsdir);
6380         return buf;
6381       }
6382       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6383         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6384         *cp1 = '\0';
6385         my_esa_len -= 9;
6386       }
6387       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6388       if (cp1 == NULL) { /* should never happen */
6389         sts = rms_free_search_context(&dirfab);
6390         PerlMem_free(trndir);
6391         PerlMem_free(esa);
6392         if (esal != NULL)
6393             PerlMem_free(esal);
6394         PerlMem_free(vmsdir);
6395         return NULL;
6396       }
6397       term = *cp1;
6398       *cp1 = '\0';
6399       retlen = strlen(my_esa);
6400       cp1 = strrchr(my_esa,'.');
6401       /* ODS-5 directory specifications can have extra "." in them. */
6402       /* Fix-me, can not scan EFS file specifications backwards */
6403       while (cp1 != NULL) {
6404         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6405           break;
6406         else {
6407            cp1--;
6408            while ((cp1 > my_esa) && (*cp1 != '.'))
6409              cp1--;
6410         }
6411         if (cp1 == my_esa)
6412           cp1 = NULL;
6413       }
6414
6415       if ((cp1) != NULL) {
6416         /* There's more than one directory in the path.  Just roll back. */
6417         *cp1 = term;
6418         strcpy(buf, my_esa);
6419       }
6420       else {
6421         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6422           /* Go back and expand rooted logical name */
6423           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6424 #ifdef NAM$M_NO_SHORT_UPCASE
6425           if (decc_efs_case_preserve)
6426             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6427 #endif
6428           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6429             sts = rms_free_search_context(&dirfab);
6430             PerlMem_free(esa);
6431             if (esal != NULL)
6432                 PerlMem_free(esal);
6433             PerlMem_free(trndir);
6434             PerlMem_free(vmsdir);
6435             set_errno(EVMSERR);
6436             set_vaxc_errno(dirfab.fab$l_sts);
6437             return NULL;
6438           }
6439
6440           /* This changes the length of the string of course */
6441           if (esal != NULL) {
6442               my_esa_len = rms_nam_esll(dirnam);
6443           } else {
6444               my_esa_len = rms_nam_esl(dirnam);
6445           }
6446
6447           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6448           cp1 = strstr(my_esa,"][");
6449           if (!cp1) cp1 = strstr(my_esa,"]<");
6450           dirlen = cp1 - my_esa;
6451           memcpy(buf, my_esa, dirlen);
6452           if (!strncmp(cp1+2,"000000]",7)) {
6453             buf[dirlen-1] = '\0';
6454             /* fix-me Not full ODS-5, just extra dots in directories for now */
6455             cp1 = buf + dirlen - 1;
6456             while (cp1 > buf)
6457             {
6458               if (*cp1 == '[')
6459                 break;
6460               if (*cp1 == '.') {
6461                 if (*(cp1-1) != '^')
6462                   break;
6463               }
6464               cp1--;
6465             }
6466             if (*cp1 == '.') *cp1 = ']';
6467             else {
6468               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6469               memmove(cp1+1,"000000]",7);
6470             }
6471           }
6472           else {
6473             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6474             buf[retlen] = '\0';
6475             /* Convert last '.' to ']' */
6476             cp1 = buf+retlen-1;
6477             while (*cp != '[') {
6478               cp1--;
6479               if (*cp1 == '.') {
6480                 /* Do not trip on extra dots in ODS-5 directories */
6481                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6482                 break;
6483               }
6484             }
6485             if (*cp1 == '.') *cp1 = ']';
6486             else {
6487               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6488               memmove(cp1+1,"000000]",7);
6489             }
6490           }
6491         }
6492         else {  /* This is a top-level dir.  Add the MFD to the path. */
6493           cp1 = my_esa;
6494           cp2 = buf;
6495           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6496           strcpy(cp2,":[000000]");
6497           cp1 += 2;
6498           strcpy(cp2+9,cp1);
6499         }
6500       }
6501       sts = rms_free_search_context(&dirfab);
6502       /* We've set up the string up through the filename.  Add the
6503          type and version, and we're done. */
6504       strcat(buf,".DIR;1");
6505
6506       /* $PARSE may have upcased filespec, so convert output to lower
6507        * case if input contained any lowercase characters. */
6508       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6509       PerlMem_free(trndir);
6510       PerlMem_free(esa);
6511       if (esal != NULL)
6512         PerlMem_free(esal);
6513       PerlMem_free(vmsdir);
6514       return buf;
6515     }
6516 }  /* end of int_fileify_dirspec() */
6517
6518
6519 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6520 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6521 {
6522     static char __fileify_retbuf[VMS_MAXRSS];
6523     char * fileified, *ret_spec, *ret_buf;
6524
6525     fileified = NULL;
6526     ret_buf = buf;
6527     if (ret_buf == NULL) {
6528         if (ts) {
6529             Newx(fileified, VMS_MAXRSS, char);
6530             if (fileified == NULL)
6531                 _ckvmssts(SS$_INSFMEM);
6532             ret_buf = fileified;
6533         } else {
6534             ret_buf = __fileify_retbuf;
6535         }
6536     }
6537
6538     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6539
6540     if (ret_spec == NULL) {
6541        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6542        if (fileified)
6543            Safefree(fileified);
6544     }
6545
6546     return ret_spec;
6547 }  /* end of do_fileify_dirspec() */
6548 /*}}}*/
6549
6550 /* External entry points */
6551 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6552 { return do_fileify_dirspec(dir,buf,0,NULL); }
6553 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6554 { return do_fileify_dirspec(dir,buf,1,NULL); }
6555 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6556 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6557 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6558 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6559
6560 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6561     char * v_spec, int v_len, char * r_spec, int r_len,
6562     char * d_spec, int d_len, char * n_spec, int n_len,
6563     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6564
6565     /* VMS specification - Try to do this the simple way */
6566     if ((v_len + r_len > 0) || (d_len > 0)) {
6567         int is_dir;
6568
6569         /* No name or extension component, already a directory */
6570         if ((n_len + e_len + vs_len) == 0) {
6571             strcpy(buf, dir);
6572             return buf;
6573         }
6574
6575         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6576         /* This results from catfile() being used instead of catdir() */
6577         /* So even though it should not work, we need to allow it */
6578
6579         /* If this is .DIR;1 then do a simple conversion */
6580         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6581         if (is_dir || (e_len == 0) && (d_len > 0)) {
6582              int len;
6583              len = v_len + r_len + d_len - 1;
6584              char dclose = d_spec[d_len - 1];
6585              strncpy(buf, dir, len);
6586              buf[len] = '.';
6587              len++;
6588              strncpy(&buf[len], n_spec, n_len);
6589              len += n_len;
6590              buf[len] = dclose;
6591              buf[len + 1] = '\0';
6592              return buf;
6593         }
6594
6595 #ifdef HAS_SYMLINK
6596         else if (d_len > 0) {
6597             /* In the olden days, a directory needed to have a .DIR */
6598             /* extension to be a valid directory, but now it could  */
6599             /* be a symbolic link */
6600             int len;
6601             len = v_len + r_len + d_len - 1;
6602             char dclose = d_spec[d_len - 1];
6603             strncpy(buf, dir, len);
6604             buf[len] = '.';
6605             len++;
6606             strncpy(&buf[len], n_spec, n_len);
6607             len += n_len;
6608             if (e_len > 0) {
6609                 if (decc_efs_charset) {
6610                     buf[len] = '^';
6611                     len++;
6612                     strncpy(&buf[len], e_spec, e_len);
6613                     len += e_len;
6614                 } else {
6615                     set_vaxc_errno(RMS$_DIR);
6616                     set_errno(ENOTDIR);
6617                     return NULL;
6618                 }
6619             }
6620             buf[len] = dclose;
6621             buf[len + 1] = '\0';
6622             return buf;
6623         }
6624 #else
6625         else {
6626             set_vaxc_errno(RMS$_DIR);
6627             set_errno(ENOTDIR);
6628             return NULL;
6629         }
6630 #endif
6631     }
6632     set_vaxc_errno(RMS$_DIR);
6633     set_errno(ENOTDIR);
6634     return NULL;
6635 }
6636
6637
6638 /* Internal routine to make sure or convert a directory to be in a */
6639 /* path specification.  No utf8 flag because it is not changed or used */
6640 static char *int_pathify_dirspec(const char *dir, char *buf)
6641 {
6642     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6643     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6644     char * exp_spec, *ret_spec;
6645     char * trndir;
6646     unsigned short int trnlnm_iter_count;
6647     STRLEN trnlen;
6648     int need_to_lower;
6649
6650     if (vms_debug_fileify) {
6651         if (dir == NULL)
6652             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6653         else
6654             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6655     }
6656
6657     /* We may need to lower case the result if we translated  */
6658     /* a logical name or got the current working directory */
6659     need_to_lower = 0;
6660
6661     if (!dir || !*dir) {
6662       set_errno(EINVAL);
6663       set_vaxc_errno(SS$_BADPARAM);
6664       return NULL;
6665     }
6666
6667     trndir = PerlMem_malloc(VMS_MAXRSS);
6668     if (trndir == NULL)
6669         _ckvmssts_noperl(SS$_INSFMEM);
6670
6671     /* If no directory specified use the current default */
6672     if (*dir)
6673         strcpy(trndir, dir);
6674     else {
6675         getcwd(trndir, VMS_MAXRSS - 1);
6676         need_to_lower = 1;
6677     }
6678
6679     /* now deal with bare names that could be logical names */
6680     trnlnm_iter_count = 0;
6681     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6682            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6683         trnlnm_iter_count++;
6684         need_to_lower = 1;
6685         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6686             break;
6687         trnlen = strlen(trndir);
6688
6689         /* Trap simple rooted lnms, and return lnm:[000000] */
6690         if (!strcmp(trndir+trnlen-2,".]")) {
6691             strcpy(buf, dir);
6692             strcat(buf, ":[000000]");
6693             PerlMem_free(trndir);
6694
6695             if (vms_debug_fileify) {
6696                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6697             }
6698             return buf;
6699         }
6700     }
6701
6702     /* At this point we do not work with *dir, but the copy in  *trndir */
6703
6704     if (need_to_lower && !decc_efs_case_preserve) {
6705         /* Legacy mode, lower case the returned value */
6706         __mystrtolower(trndir);
6707     }
6708
6709
6710     /* Some special cases, '..', '.' */
6711     sts = 0;
6712     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6713        /* Force UNIX filespec */
6714        sts = 1;
6715
6716     } else {
6717         /* Is this Unix or VMS format? */
6718         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6719                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6720                              &e_len, &vs_spec, &vs_len);
6721         if (sts == 0) {
6722
6723             /* Just a filename? */
6724             if ((v_len + r_len + d_len) == 0) {
6725
6726                 /* Now we have a problem, this could be Unix or VMS */
6727                 /* We have to guess.  .DIR usually means VMS */
6728
6729                 /* In UNIX report mode, the .DIR extension is removed */
6730                 /* if one shows up, it is for a non-directory or a directory */
6731                 /* in EFS charset mode */
6732
6733                 /* So if we are in Unix report mode, assume that this */
6734                 /* is a relative Unix directory specification */
6735
6736                 sts = 1;
6737                 if (!decc_filename_unix_report && decc_efs_charset) {
6738                     int is_dir;
6739                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6740
6741                     if (is_dir) {
6742                         /* Traditional mode, assume .DIR is directory */
6743                         buf[0] = '[';
6744                         buf[1] = '.';
6745                         strncpy(&buf[2], n_spec, n_len);
6746                         buf[n_len + 2] = ']';
6747                         buf[n_len + 3] = '\0';
6748                         PerlMem_free(trndir);
6749                         if (vms_debug_fileify) {
6750                             fprintf(stderr,
6751                                     "int_pathify_dirspec: buf = %s\n",
6752                                     buf);
6753                         }
6754                         return buf;
6755                     }
6756                 }
6757             }
6758         }
6759     }
6760     if (sts == 0) {
6761         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6762             v_spec, v_len, r_spec, r_len,
6763             d_spec, d_len, n_spec, n_len,
6764             e_spec, e_len, vs_spec, vs_len);
6765
6766         if (ret_spec != NULL) {
6767             PerlMem_free(trndir);
6768             if (vms_debug_fileify) {
6769                 fprintf(stderr,
6770                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6771             }
6772             return ret_spec;
6773         }
6774
6775         /* Simple way did not work, which means that a logical name */
6776         /* was present for the directory specification.             */
6777         /* Need to use an rmsexpand variant to decode it completely */
6778         exp_spec = PerlMem_malloc(VMS_MAXRSS);
6779         if (exp_spec == NULL)
6780             _ckvmssts_noperl(SS$_INSFMEM);
6781
6782         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6783         if (ret_spec != NULL) {
6784             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6785                                  &r_spec, &r_len, &d_spec, &d_len,
6786                                  &n_spec, &n_len, &e_spec,
6787                                  &e_len, &vs_spec, &vs_len);
6788             if (sts == 0) {
6789                 ret_spec = int_pathify_dirspec_simple(
6790                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6791                     d_spec, d_len, n_spec, n_len,
6792                     e_spec, e_len, vs_spec, vs_len);
6793
6794                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6795                     /* Legacy mode, lower case the returned value */
6796                     __mystrtolower(ret_spec);
6797                 }
6798             } else {
6799                 set_vaxc_errno(RMS$_DIR);
6800                 set_errno(ENOTDIR);
6801                 ret_spec = NULL;
6802             }
6803         }
6804         PerlMem_free(exp_spec);
6805         PerlMem_free(trndir);
6806         if (vms_debug_fileify) {
6807             if (ret_spec == NULL)
6808                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6809             else
6810                 fprintf(stderr,
6811                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6812         }
6813         return ret_spec;
6814
6815     } else {
6816         /* Unix specification, Could be trivial conversion */
6817         STRLEN dir_len;
6818         dir_len = strlen(trndir);
6819
6820         /* If the extended file character set is in effect */
6821         /* then pathify is simple */
6822
6823         if (!decc_efs_charset) {
6824             /* Have to deal with traiing '.dir' or extra '.' */
6825             /* that should not be there in legacy mode, but is */
6826
6827             char * lastdot;
6828             char * lastslash;
6829             int is_dir;
6830
6831             lastslash = strrchr(trndir, '/');
6832             if (lastslash == NULL)
6833                 lastslash = trndir;
6834             else
6835                 lastslash++;
6836
6837             lastdot = NULL;
6838
6839             /* '..' or '.' are valid directory components */
6840             is_dir = 0;
6841             if (lastslash[0] == '.') {
6842                 if (lastslash[1] == '\0') {
6843                    is_dir = 1;
6844                 } else if (lastslash[1] == '.') {
6845                     if (lastslash[2] == '\0') {
6846                         is_dir = 1;
6847                     } else {
6848                         /* And finally allow '...' */
6849                         if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6850                             is_dir = 1;
6851                         }
6852                     }
6853                 }
6854             }
6855
6856             if (!is_dir) {
6857                lastdot = strrchr(lastslash, '.');
6858             }
6859             if (lastdot != NULL) {
6860                 STRLEN e_len;
6861
6862                 /* '.dir' is discarded, and any other '.' is invalid */
6863                 e_len = strlen(lastdot);
6864
6865                 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6866
6867                 if (is_dir) {
6868                     dir_len = dir_len - 4;
6869
6870                 }
6871             }
6872         }
6873
6874         strcpy(buf, trndir);
6875         if (buf[dir_len - 1] != '/') {
6876             buf[dir_len] = '/';
6877             buf[dir_len + 1] = '\0';
6878         }
6879
6880         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6881         if (!decc_efs_charset) {
6882              int dir_start = 0;
6883              char * str = buf;
6884              if (str[0] == '.') {
6885                  char * dots = str;
6886                  int cnt = 1;
6887                  while ((dots[cnt] == '.') && (cnt < 3))
6888                      cnt++;
6889                  if (cnt <= 3) {
6890                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6891                          dir_start = 1;
6892                          str += cnt;
6893                      }
6894                  }
6895              }
6896              for (; *str; ++str) {
6897                  while (*str == '/') {
6898                      dir_start = 1;
6899                      *str++;
6900                  }
6901                  if (dir_start) {
6902
6903                      /* Have to skip up to three dots which could be */
6904                      /* directories, 3 dots being a VMS extension for Perl */
6905                      char * dots = str;
6906                      int cnt = 0;
6907                      while ((dots[cnt] == '.') && (cnt < 3)) {
6908                          cnt++;
6909                      }
6910                      if (dots[cnt] == '\0')
6911                          break;
6912                      if ((cnt > 1) && (dots[cnt] != '/')) {
6913                          dir_start = 0;
6914                      } else {
6915                          str += cnt;
6916                      }
6917
6918                      /* too many dots? */
6919                      if ((cnt == 0) || (cnt > 3)) {
6920                          dir_start = 0;
6921                      }
6922                  }
6923                  if (!dir_start && (*str == '.')) {
6924                      *str = '_';
6925                  }
6926              }
6927         }
6928         PerlMem_free(trndir);
6929         ret_spec = buf;
6930         if (vms_debug_fileify) {
6931             if (ret_spec == NULL)
6932                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6933             else
6934                 fprintf(stderr,
6935                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6936         }
6937         return ret_spec;
6938     }
6939 }
6940
6941 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6942 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6943 {
6944     static char __pathify_retbuf[VMS_MAXRSS];
6945     char * pathified, *ret_spec, *ret_buf;
6946
6947     pathified = NULL;
6948     ret_buf = buf;
6949     if (ret_buf == NULL) {
6950         if (ts) {
6951             Newx(pathified, VMS_MAXRSS, char);
6952             if (pathified == NULL)
6953                 _ckvmssts(SS$_INSFMEM);
6954             ret_buf = pathified;
6955         } else {
6956             ret_buf = __pathify_retbuf;
6957         }
6958     }
6959
6960     ret_spec = int_pathify_dirspec(dir, ret_buf);
6961
6962     if (ret_spec == NULL) {
6963        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6964        if (pathified)
6965            Safefree(pathified);
6966     }
6967
6968     return ret_spec;
6969
6970 }  /* end of do_pathify_dirspec() */
6971
6972
6973 /* External entry points */
6974 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6975 { return do_pathify_dirspec(dir,buf,0,NULL); }
6976 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6977 { return do_pathify_dirspec(dir,buf,1,NULL); }
6978 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6979 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6980 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6981 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6982
6983 /* Internal tounixspec routine that does not use a thread context */
6984 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6985 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
6986 {
6987   char *dirend, *cp1, *cp3, *tmp;
6988   const char *cp2;
6989   int devlen, dirlen, retlen = VMS_MAXRSS;
6990   int expand = 1; /* guarantee room for leading and trailing slashes */
6991   unsigned short int trnlnm_iter_count;
6992   int cmp_rslt;
6993   if (utf8_fl != NULL)
6994     *utf8_fl = 0;
6995
6996   if (vms_debug_fileify) {
6997       if (spec == NULL)
6998           fprintf(stderr, "int_tounixspec: spec = NULL\n");
6999       else
7000           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7001   }
7002
7003
7004   if (spec == NULL) {
7005       set_errno(EINVAL);
7006       set_vaxc_errno(SS$_BADPARAM);
7007       return NULL;
7008   }
7009   if (strlen(spec) > (VMS_MAXRSS-1)) {
7010       set_errno(E2BIG);
7011       set_vaxc_errno(SS$_BUFFEROVF);
7012       return NULL;
7013   }
7014
7015   /* New VMS specific format needs translation
7016    * glob passes filenames with trailing '\n' and expects this preserved.
7017    */
7018   if (decc_posix_compliant_pathnames) {
7019     if (strncmp(spec, "\"^UP^", 5) == 0) {
7020       char * uspec;
7021       char *tunix;
7022       int tunix_len;
7023       int nl_flag;
7024
7025       tunix = PerlMem_malloc(VMS_MAXRSS);
7026       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7027       strcpy(tunix, spec);
7028       tunix_len = strlen(tunix);
7029       nl_flag = 0;
7030       if (tunix[tunix_len - 1] == '\n') {
7031         tunix[tunix_len - 1] = '\"';
7032         tunix[tunix_len] = '\0';
7033         tunix_len--;
7034         nl_flag = 1;
7035       }
7036       uspec = decc$translate_vms(tunix);
7037       PerlMem_free(tunix);
7038       if ((int)uspec > 0) {
7039         strcpy(rslt,uspec);
7040         if (nl_flag) {
7041           strcat(rslt,"\n");
7042         }
7043         else {
7044           /* If we can not translate it, makemaker wants as-is */
7045           strcpy(rslt, spec);
7046         }
7047         return rslt;
7048       }
7049     }
7050   }
7051
7052   cmp_rslt = 0; /* Presume VMS */
7053   cp1 = strchr(spec, '/');
7054   if (cp1 == NULL)
7055     cmp_rslt = 0;
7056
7057     /* Look for EFS ^/ */
7058     if (decc_efs_charset) {
7059       while (cp1 != NULL) {
7060         cp2 = cp1 - 1;
7061         if (*cp2 != '^') {
7062           /* Found illegal VMS, assume UNIX */
7063           cmp_rslt = 1;
7064           break;
7065         }
7066       cp1++;
7067       cp1 = strchr(cp1, '/');
7068     }
7069   }
7070
7071   /* Look for "." and ".." */
7072   if (decc_filename_unix_report) {
7073     if (spec[0] == '.') {
7074       if ((spec[1] == '\0') || (spec[1] == '\n')) {
7075         cmp_rslt = 1;
7076       }
7077       else {
7078         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7079           cmp_rslt = 1;
7080         }
7081       }
7082     }
7083   }
7084   /* This is already UNIX or at least nothing VMS understands */
7085   if (cmp_rslt) {
7086     strcpy(rslt,spec);
7087     if (vms_debug_fileify) {
7088         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7089     }
7090     return rslt;
7091   }
7092
7093   cp1 = rslt;
7094   cp2 = spec;
7095   dirend = strrchr(spec,']');
7096   if (dirend == NULL) dirend = strrchr(spec,'>');
7097   if (dirend == NULL) dirend = strchr(spec,':');
7098   if (dirend == NULL) {
7099     strcpy(rslt,spec);
7100     if (vms_debug_fileify) {
7101         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7102     }
7103     return rslt;
7104   }
7105
7106   /* Special case 1 - sys$posix_root = / */
7107 #if __CRTL_VER >= 70000000
7108   if (!decc_disable_posix_root) {
7109     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7110       *cp1 = '/';
7111       cp1++;
7112       cp2 = cp2 + 15;
7113       }
7114   }
7115 #endif
7116
7117   /* Special case 2 - Convert NLA0: to /dev/null */
7118 #if __CRTL_VER < 70000000
7119   cmp_rslt = strncmp(spec,"NLA0:", 5);
7120   if (cmp_rslt != 0)
7121      cmp_rslt = strncmp(spec,"nla0:", 5);
7122 #else
7123   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7124 #endif
7125   if (cmp_rslt == 0) {
7126     strcpy(rslt, "/dev/null");
7127     cp1 = cp1 + 9;
7128     cp2 = cp2 + 5;
7129     if (spec[6] != '\0') {
7130       cp1[9] == '/';
7131       cp1++;
7132       cp2++;
7133     }
7134   }
7135
7136    /* Also handle special case "SYS$SCRATCH:" */
7137 #if __CRTL_VER < 70000000
7138   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
7139   if (cmp_rslt != 0)
7140      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
7141 #else
7142   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7143 #endif
7144   tmp = PerlMem_malloc(VMS_MAXRSS);
7145   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7146   if (cmp_rslt == 0) {
7147   int islnm;
7148
7149     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7150     if (!islnm) {
7151       strcpy(rslt, "/tmp");
7152       cp1 = cp1 + 4;
7153       cp2 = cp2 + 12;
7154       if (spec[12] != '\0') {
7155         cp1[4] == '/';
7156         cp1++;
7157         cp2++;
7158       }
7159     }
7160   }
7161
7162   if (*cp2 != '[' && *cp2 != '<') {
7163     *(cp1++) = '/';
7164   }
7165   else {  /* the VMS spec begins with directories */
7166     cp2++;
7167     if (*cp2 == ']' || *cp2 == '>') {
7168       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7169       PerlMem_free(tmp);
7170       return rslt;
7171     }
7172     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7173       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7174         PerlMem_free(tmp);
7175         if (vms_debug_fileify) {
7176             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7177         }
7178         return NULL;
7179       }
7180       trnlnm_iter_count = 0;
7181       do {
7182         cp3 = tmp;
7183         while (*cp3 != ':' && *cp3) cp3++;
7184         *(cp3++) = '\0';
7185         if (strchr(cp3,']') != NULL) break;
7186         trnlnm_iter_count++;
7187         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7188       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7189       cp1 = rslt;
7190       cp3 = tmp;
7191       *(cp1++) = '/';
7192       while (*cp3) {
7193         *(cp1++) = *(cp3++);
7194         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7195             PerlMem_free(tmp);
7196             set_errno(ENAMETOOLONG);
7197             set_vaxc_errno(SS$_BUFFEROVF);
7198             if (vms_debug_fileify) {
7199                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7200             }
7201             return NULL; /* No room */
7202         }
7203       }
7204       *(cp1++) = '/';
7205     }
7206     if ((*cp2 == '^')) {
7207         /* EFS file escape, pass the next character as is */
7208         /* Fix me: HEX encoding for Unicode not implemented */
7209         cp2++;
7210     }
7211     else if ( *cp2 == '.') {
7212       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7213         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7214         cp2 += 3;
7215       }
7216       else cp2++;
7217     }
7218   }
7219   PerlMem_free(tmp);
7220   for (; cp2 <= dirend; cp2++) {
7221     if ((*cp2 == '^')) {
7222         /* EFS file escape, pass the next character as is */
7223         /* Fix me: HEX encoding for Unicode not implemented */
7224         *(cp1++) = *(++cp2);
7225         /* An escaped dot stays as is -- don't convert to slash */
7226         if (*cp2 == '.') cp2++;
7227     }
7228     if (*cp2 == ':') {
7229       *(cp1++) = '/';
7230       if (*(cp2+1) == '[') cp2++;
7231     }
7232     else if (*cp2 == ']' || *cp2 == '>') {
7233       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7234     }
7235     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7236       *(cp1++) = '/';
7237       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7238         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7239                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7240         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7241             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7242       }
7243       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7244         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7245         cp2 += 2;
7246       }
7247     }
7248     else if (*cp2 == '-') {
7249       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7250         while (*cp2 == '-') {
7251           cp2++;
7252           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7253         }
7254         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7255                                                          /* filespecs like */
7256           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7257           if (vms_debug_fileify) {
7258               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7259           }
7260           return NULL;
7261         }
7262       }
7263       else *(cp1++) = *cp2;
7264     }
7265     else *(cp1++) = *cp2;
7266   }
7267   /* Translate the rest of the filename. */
7268   while (*cp2) {
7269       int dot_seen;
7270       dot_seen = 0;
7271       switch(*cp2) {
7272       /* Fixme - for compatibility with the CRTL we should be removing */
7273       /* spaces from the file specifications, but this may show that */
7274       /* some tests that were appearing to pass are not really passing */
7275       case '%':
7276           cp2++;
7277           *(cp1++) = '?';
7278           break;
7279       case '^':
7280           /* Fix me hex expansions not implemented */
7281           cp2++;  /* '^.' --> '.' and other. */
7282           if (*cp2) {
7283               if (*cp2 == '_') {
7284                   cp2++;
7285                   *(cp1++) = ' ';
7286               } else {
7287                   *(cp1++) = *(cp2++);
7288               }
7289           }
7290           break;
7291       case ';':
7292           if (decc_filename_unix_no_version) {
7293               /* Easy, drop the version */
7294               while (*cp2)
7295                   cp2++;
7296               break;
7297           } else {
7298               /* Punt - passing the version as a dot will probably */
7299               /* break perl in weird ways, but so did passing */
7300               /* through the ; as a version.  Follow the CRTL and */
7301               /* hope for the best. */
7302               cp2++;
7303               *(cp1++) = '.';
7304           }
7305           break;
7306       case '.':
7307           if (dot_seen) {
7308               /* We will need to fix this properly later */
7309               /* As Perl may be installed on an ODS-5 volume, but not */
7310               /* have the EFS_CHARSET enabled, it still may encounter */
7311               /* filenames with extra dots in them, and a precedent got */
7312               /* set which allowed them to work, that we will uphold here */
7313               /* If extra dots are present in a name and no ^ is on them */
7314               /* VMS assumes that the first one is the extension delimiter */
7315               /* the rest have an implied ^. */
7316
7317               /* this is also a conflict as the . is also a version */
7318               /* delimiter in VMS, */
7319
7320               *(cp1++) = *(cp2++);
7321               break;
7322           }
7323           dot_seen = 1;
7324           /* This is an extension */
7325           if (decc_readdir_dropdotnotype) {
7326               cp2++;
7327               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7328                   /* Drop the dot for the extension */
7329                   break;
7330               } else {
7331                   *(cp1++) = '.';
7332               }
7333               break;
7334           }
7335       default:
7336           *(cp1++) = *(cp2++);
7337       }
7338   }
7339   *cp1 = '\0';
7340
7341   /* This still leaves /000000/ when working with a
7342    * VMS device root or concealed root.
7343    */
7344   {
7345   int ulen;
7346   char * zeros;
7347
7348       ulen = strlen(rslt);
7349
7350       /* Get rid of "000000/ in rooted filespecs */
7351       if (ulen > 7) {
7352         zeros = strstr(rslt, "/000000/");
7353         if (zeros != NULL) {
7354           int mlen;
7355           mlen = ulen - (zeros - rslt) - 7;
7356           memmove(zeros, &zeros[7], mlen);
7357           ulen = ulen - 7;
7358           rslt[ulen] = '\0';
7359         }
7360       }
7361   }
7362
7363   if (vms_debug_fileify) {
7364       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7365   }
7366   return rslt;
7367
7368 }  /* end of int_tounixspec() */
7369
7370
7371 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7372 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7373 {
7374     static char __tounixspec_retbuf[VMS_MAXRSS];
7375     char * unixspec, *ret_spec, *ret_buf;
7376
7377     unixspec = NULL;
7378     ret_buf = buf;
7379     if (ret_buf == NULL) {
7380         if (ts) {
7381             Newx(unixspec, VMS_MAXRSS, char);
7382             if (unixspec == NULL)
7383                 _ckvmssts(SS$_INSFMEM);
7384             ret_buf = unixspec;
7385         } else {
7386             ret_buf = __tounixspec_retbuf;
7387         }
7388     }
7389
7390     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7391
7392     if (ret_spec == NULL) {
7393        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7394        if (unixspec)
7395            Safefree(unixspec);
7396     }
7397
7398     return ret_spec;
7399
7400 }  /* end of do_tounixspec() */
7401 /*}}}*/
7402 /* External entry points */
7403 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7404   { return do_tounixspec(spec,buf,0, NULL); }
7405 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7406   { return do_tounixspec(spec,buf,1, NULL); }
7407 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7408   { return do_tounixspec(spec,buf,0, utf8_fl); }
7409 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7410   { return do_tounixspec(spec,buf,1, utf8_fl); }
7411
7412 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7413
7414 /*
7415  This procedure is used to identify if a path is based in either
7416  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7417  it returns the OpenVMS format directory for it.
7418
7419  It is expecting specifications of only '/' or '/xxxx/'
7420
7421  If a posix root does not exist, or 'xxxx' is not a directory
7422  in the posix root, it returns a failure.
7423
7424  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7425
7426  It is used only internally by posix_to_vmsspec_hardway().
7427  */
7428
7429 static int posix_root_to_vms
7430   (char *vmspath, int vmspath_len,
7431    const char *unixpath,
7432    const int * utf8_fl)
7433 {
7434 int sts;
7435 struct FAB myfab = cc$rms_fab;
7436 rms_setup_nam(mynam);
7437 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7438 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7439 char * esa, * esal, * rsa, * rsal;
7440 char *vms_delim;
7441 int dir_flag;
7442 int unixlen;
7443
7444     dir_flag = 0;
7445     vmspath[0] = '\0';
7446     unixlen = strlen(unixpath);
7447     if (unixlen == 0) {
7448       return RMS$_FNF;
7449     }
7450
7451 #if __CRTL_VER >= 80200000
7452   /* If not a posix spec already, convert it */
7453   if (decc_posix_compliant_pathnames) {
7454     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7455       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7456     }
7457     else {
7458       /* This is already a VMS specification, no conversion */
7459       unixlen--;
7460       strncpy(vmspath,unixpath, vmspath_len);
7461     }
7462   }
7463   else
7464 #endif
7465   {
7466   int path_len;
7467   int i,j;
7468
7469      /* Check to see if this is under the POSIX root */
7470      if (decc_disable_posix_root) {
7471         return RMS$_FNF;
7472      }
7473
7474      /* Skip leading / */
7475      if (unixpath[0] == '/') {
7476         unixpath++;
7477         unixlen--;
7478      }
7479
7480
7481      strcpy(vmspath,"SYS$POSIX_ROOT:");
7482
7483      /* If this is only the / , or blank, then... */
7484      if (unixpath[0] == '\0') {
7485         /* by definition, this is the answer */
7486         return SS$_NORMAL;
7487      }
7488
7489      /* Need to look up a directory */
7490      vmspath[15] = '[';
7491      vmspath[16] = '\0';
7492
7493      /* Copy and add '^' escape characters as needed */
7494      j = 16;
7495      i = 0;
7496      while (unixpath[i] != 0) {
7497      int k;
7498
7499         j += copy_expand_unix_filename_escape
7500             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7501         i += k;
7502      }
7503
7504      path_len = strlen(vmspath);
7505      if (vmspath[path_len - 1] == '/')
7506         path_len--;
7507      vmspath[path_len] = ']';
7508      path_len++;
7509      vmspath[path_len] = '\0';
7510
7511   }
7512   vmspath[vmspath_len] = 0;
7513   if (unixpath[unixlen - 1] == '/')
7514   dir_flag = 1;
7515   esal = PerlMem_malloc(VMS_MAXRSS);
7516   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7517   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7518   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7519   rsal = PerlMem_malloc(VMS_MAXRSS);
7520   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7521   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7522   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7523   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7524   rms_bind_fab_nam(myfab, mynam);
7525   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7526   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7527   if (decc_efs_case_preserve)
7528     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7529 #ifdef NAML$M_OPEN_SPECIAL
7530   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7531 #endif
7532
7533   /* Set up the remaining naml fields */
7534   sts = sys$parse(&myfab);
7535
7536   /* It failed! Try again as a UNIX filespec */
7537   if (!(sts & 1)) {
7538     PerlMem_free(esal);
7539     PerlMem_free(esa);
7540     PerlMem_free(rsal);
7541     PerlMem_free(rsa);
7542     return sts;
7543   }
7544
7545    /* get the Device ID and the FID */
7546    sts = sys$search(&myfab);
7547
7548    /* These are no longer needed */
7549    PerlMem_free(esa);
7550    PerlMem_free(rsal);
7551    PerlMem_free(rsa);
7552
7553    /* on any failure, returned the POSIX ^UP^ filespec */
7554    if (!(sts & 1)) {
7555       PerlMem_free(esal);
7556       return sts;
7557    }
7558    specdsc.dsc$a_pointer = vmspath;
7559    specdsc.dsc$w_length = vmspath_len;
7560
7561    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7562    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7563    sts = lib$fid_to_name
7564       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7565
7566   /* on any failure, returned the POSIX ^UP^ filespec */
7567   if (!(sts & 1)) {
7568      /* This can happen if user does not have permission to read directories */
7569      if (strncmp(unixpath,"\"^UP^",5) != 0)
7570        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7571      else
7572        strcpy(vmspath, unixpath);
7573   }
7574   else {
7575     vmspath[specdsc.dsc$w_length] = 0;
7576
7577     /* Are we expecting a directory? */
7578     if (dir_flag != 0) {
7579     int i;
7580     char *eptr;
7581
7582       eptr = NULL;
7583
7584       i = specdsc.dsc$w_length - 1;
7585       while (i > 0) {
7586       int zercnt;
7587         zercnt = 0;
7588         /* Version must be '1' */
7589         if (vmspath[i--] != '1')
7590           break;
7591         /* Version delimiter is one of ".;" */
7592         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7593           break;
7594         i--;
7595         if (vmspath[i--] != 'R')
7596           break;
7597         if (vmspath[i--] != 'I')
7598           break;
7599         if (vmspath[i--] != 'D')
7600           break;
7601         if (vmspath[i--] != '.')
7602           break;
7603         eptr = &vmspath[i+1];
7604         while (i > 0) {
7605           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7606             if (vmspath[i-1] != '^') {
7607               if (zercnt != 6) {
7608                 *eptr = vmspath[i];
7609                 eptr[1] = '\0';
7610                 vmspath[i] = '.';
7611                 break;
7612               }
7613               else {
7614                 /* Get rid of 6 imaginary zero directory filename */
7615                 vmspath[i+1] = '\0';
7616               }
7617             }
7618           }
7619           if (vmspath[i] == '0')
7620             zercnt++;
7621           else
7622             zercnt = 10;
7623           i--;
7624         }
7625         break;
7626       }
7627     }
7628   }
7629   PerlMem_free(esal);
7630   return sts;
7631 }
7632
7633 /* /dev/mumble needs to be handled special.
7634    /dev/null becomes NLA0:, And there is the potential for other stuff
7635    like /dev/tty which may need to be mapped to something.
7636 */
7637
7638 static int
7639 slash_dev_special_to_vms
7640    (const char * unixptr,
7641     char * vmspath,
7642     int vmspath_len)
7643 {
7644 char * nextslash;
7645 int len;
7646 int cmp;
7647 int islnm;
7648
7649     unixptr += 4;
7650     nextslash = strchr(unixptr, '/');
7651     len = strlen(unixptr);
7652     if (nextslash != NULL)
7653         len = nextslash - unixptr;
7654     cmp = strncmp("null", unixptr, 5);
7655     if (cmp == 0) {
7656         if (vmspath_len >= 6) {
7657             strcpy(vmspath, "_NLA0:");
7658             return SS$_NORMAL;
7659         }
7660     }
7661 }
7662
7663
7664 /* The built in routines do not understand perl's special needs, so
7665     doing a manual conversion from UNIX to VMS
7666
7667     If the utf8_fl is not null and points to a non-zero value, then
7668     treat 8 bit characters as UTF-8.
7669
7670     The sequence starting with '$(' and ending with ')' will be passed
7671     through with out interpretation instead of being escaped.
7672
7673   */
7674 static int posix_to_vmsspec_hardway
7675   (char *vmspath, int vmspath_len,
7676    const char *unixpath,
7677    int dir_flag,
7678    int * utf8_fl) {
7679
7680 char *esa;
7681 const char *unixptr;
7682 const char *unixend;
7683 char *vmsptr;
7684 const char *lastslash;
7685 const char *lastdot;
7686 int unixlen;
7687 int vmslen;
7688 int dir_start;
7689 int dir_dot;
7690 int quoted;
7691 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7692 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7693
7694   if (utf8_fl != NULL)
7695     *utf8_fl = 0;
7696
7697   unixptr = unixpath;
7698   dir_dot = 0;
7699
7700   /* Ignore leading "/" characters */
7701   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7702     unixptr++;
7703   }
7704   unixlen = strlen(unixptr);
7705
7706   /* Do nothing with blank paths */
7707   if (unixlen == 0) {
7708     vmspath[0] = '\0';
7709     return SS$_NORMAL;
7710   }
7711
7712   quoted = 0;
7713   /* This could have a "^UP^ on the front */
7714   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7715     quoted = 1;
7716     unixptr+= 5;
7717     unixlen-= 5;
7718   }
7719
7720   lastslash = strrchr(unixptr,'/');
7721   lastdot = strrchr(unixptr,'.');
7722   unixend = strrchr(unixptr,'\"');
7723   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7724     unixend = unixptr + unixlen;
7725   }
7726
7727   /* last dot is last dot or past end of string */
7728   if (lastdot == NULL)
7729     lastdot = unixptr + unixlen;
7730
7731   /* if no directories, set last slash to beginning of string */
7732   if (lastslash == NULL) {
7733     lastslash = unixptr;
7734   }
7735   else {
7736     /* Watch out for trailing "." after last slash, still a directory */
7737     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7738       lastslash = unixptr + unixlen;
7739     }
7740
7741     /* Watch out for traiing ".." after last slash, still a directory */
7742     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7743       lastslash = unixptr + unixlen;
7744     }
7745
7746     /* dots in directories are aways escaped */
7747     if (lastdot < lastslash)
7748       lastdot = unixptr + unixlen;
7749   }
7750
7751   /* if (unixptr < lastslash) then we are in a directory */
7752
7753   dir_start = 0;
7754
7755   vmsptr = vmspath;
7756   vmslen = 0;
7757
7758   /* Start with the UNIX path */
7759   if (*unixptr != '/') {
7760     /* relative paths */
7761
7762     /* If allowing logical names on relative pathnames, then handle here */
7763     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7764         !decc_posix_compliant_pathnames) {
7765     char * nextslash;
7766     int seg_len;
7767     char * trn;
7768     int islnm;
7769
7770         /* Find the next slash */
7771         nextslash = strchr(unixptr,'/');
7772
7773         esa = PerlMem_malloc(vmspath_len);
7774         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7775
7776         trn = PerlMem_malloc(VMS_MAXRSS);
7777         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7778
7779         if (nextslash != NULL) {
7780
7781             seg_len = nextslash - unixptr;
7782             strncpy(esa, unixptr, seg_len);
7783             esa[seg_len] = 0;
7784         }
7785         else {
7786             strcpy(esa, unixptr);
7787             seg_len = strlen(unixptr);
7788         }
7789         /* trnlnm(section) */
7790         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7791
7792         if (islnm) {
7793             /* Now fix up the directory */
7794
7795             /* Split up the path to find the components */
7796             sts = vms_split_path
7797                   (trn,
7798                    &v_spec,
7799                    &v_len,
7800                    &r_spec,
7801                    &r_len,
7802                    &d_spec,
7803                    &d_len,
7804                    &n_spec,
7805                    &n_len,
7806                    &e_spec,
7807                    &e_len,
7808                    &vs_spec,
7809                    &vs_len);
7810
7811             while (sts == 0) {
7812             char * strt;
7813             int cmp;
7814
7815                 /* A logical name must be a directory  or the full
7816                    specification.  It is only a full specification if
7817                    it is the only component */
7818                 if ((unixptr[seg_len] == '\0') ||
7819                     (unixptr[seg_len+1] == '\0')) {
7820
7821                     /* Is a directory being required? */
7822                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7823                         /* Not a logical name */
7824                         break;
7825                     }
7826
7827
7828                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7829                         /* This must be a directory */
7830                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7831                             strcpy(vmsptr, esa);
7832                             vmslen=strlen(vmsptr);
7833                             vmsptr[vmslen] = ':';
7834                             vmslen++;
7835                             vmsptr[vmslen] = '\0';
7836                             return SS$_NORMAL;
7837                         }
7838                     }
7839
7840                 }
7841
7842
7843                 /* must be dev/directory - ignore version */
7844                 if ((n_len + e_len) != 0)
7845                     break;
7846
7847                 /* transfer the volume */
7848                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7849                     strncpy(vmsptr, v_spec, v_len);
7850                     vmsptr += v_len;
7851                     vmsptr[0] = '\0';
7852                     vmslen += v_len;
7853                 }
7854
7855                 /* unroot the rooted directory */
7856                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7857                     r_spec[0] = '[';
7858                     r_spec[r_len - 1] = ']';
7859
7860                     /* This should not be there, but nothing is perfect */
7861                     if (r_len > 9) {
7862                         cmp = strcmp(&r_spec[1], "000000.");
7863                         if (cmp == 0) {
7864                             r_spec += 7;
7865                             r_spec[7] = '[';
7866                             r_len -= 7;
7867                             if (r_len == 2)
7868                                 r_len = 0;
7869                         }
7870                     }
7871                     if (r_len > 0) {
7872                         strncpy(vmsptr, r_spec, r_len);
7873                         vmsptr += r_len;
7874                         vmslen += r_len;
7875                         vmsptr[0] = '\0';
7876                     }
7877                 }
7878                 /* Bring over the directory. */
7879                 if ((d_len > 0) &&
7880                     ((d_len + vmslen) < vmspath_len)) {
7881                     d_spec[0] = '[';
7882                     d_spec[d_len - 1] = ']';
7883                     if (d_len > 9) {
7884                         cmp = strcmp(&d_spec[1], "000000.");
7885                         if (cmp == 0) {
7886                             d_spec += 7;
7887                             d_spec[7] = '[';
7888                             d_len -= 7;
7889                             if (d_len == 2)
7890                                 d_len = 0;
7891                         }
7892                     }
7893
7894                     if (r_len > 0) {
7895                         /* Remove the redundant root */
7896                         if (r_len > 0) {
7897                             /* remove the ][ */
7898                             vmsptr--;
7899                             vmslen--;
7900                             d_spec++;
7901                             d_len--;
7902                         }
7903                         strncpy(vmsptr, d_spec, d_len);
7904                             vmsptr += d_len;
7905                             vmslen += d_len;
7906                             vmsptr[0] = '\0';
7907                     }
7908                 }
7909                 break;
7910             }
7911         }
7912
7913         PerlMem_free(esa);
7914         PerlMem_free(trn);
7915     }
7916
7917     if (lastslash > unixptr) {
7918     int dotdir_seen;
7919
7920       /* skip leading ./ */
7921       dotdir_seen = 0;
7922       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7923         dotdir_seen = 1;
7924         unixptr++;
7925         unixptr++;
7926       }
7927
7928       /* Are we still in a directory? */
7929       if (unixptr <= lastslash) {
7930         *vmsptr++ = '[';
7931         vmslen = 1;
7932         dir_start = 1;
7933
7934         /* if not backing up, then it is relative forward. */
7935         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7936               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7937           *vmsptr++ = '.';
7938           vmslen++;
7939           dir_dot = 1;
7940           }
7941        }
7942        else {
7943          if (dotdir_seen) {
7944            /* Perl wants an empty directory here to tell the difference
7945             * between a DCL commmand and a filename
7946             */
7947           *vmsptr++ = '[';
7948           *vmsptr++ = ']';
7949           vmslen = 2;
7950         }
7951       }
7952     }
7953     else {
7954       /* Handle two special files . and .. */
7955       if (unixptr[0] == '.') {
7956         if (&unixptr[1] == unixend) {
7957           *vmsptr++ = '[';
7958           *vmsptr++ = ']';
7959           vmslen += 2;
7960           *vmsptr++ = '\0';
7961           return SS$_NORMAL;
7962         }
7963         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7964           *vmsptr++ = '[';
7965           *vmsptr++ = '-';
7966           *vmsptr++ = ']';
7967           vmslen += 3;
7968           *vmsptr++ = '\0';
7969           return SS$_NORMAL;
7970         }
7971       }
7972     }
7973   }
7974   else {        /* Absolute PATH handling */
7975   int sts;
7976   char * nextslash;
7977   int seg_len;
7978     /* Need to find out where root is */
7979
7980     /* In theory, this procedure should never get an absolute POSIX pathname
7981      * that can not be found on the POSIX root.
7982      * In practice, that can not be relied on, and things will show up
7983      * here that are a VMS device name or concealed logical name instead.
7984      * So to make things work, this procedure must be tolerant.
7985      */
7986     esa = PerlMem_malloc(vmspath_len);
7987     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7988
7989     sts = SS$_NORMAL;
7990     nextslash = strchr(&unixptr[1],'/');
7991     seg_len = 0;
7992     if (nextslash != NULL) {
7993     int cmp;
7994       seg_len = nextslash - &unixptr[1];
7995       strncpy(vmspath, unixptr, seg_len + 1);
7996       vmspath[seg_len+1] = 0;
7997       cmp = 1;
7998       if (seg_len == 3) {
7999         cmp = strncmp(vmspath, "dev", 4);
8000         if (cmp == 0) {
8001             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
8002             if (sts = SS$_NORMAL)
8003                 return SS$_NORMAL;
8004         }
8005       }
8006       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
8007     }
8008
8009     if ($VMS_STATUS_SUCCESS(sts)) {
8010       /* This is verified to be a real path */
8011
8012       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8013       if ($VMS_STATUS_SUCCESS(sts)) {
8014         strcpy(vmspath, esa);
8015         vmslen = strlen(vmspath);
8016         vmsptr = vmspath + vmslen;
8017         unixptr++;
8018         if (unixptr < lastslash) {
8019         char * rptr;
8020           vmsptr--;
8021           *vmsptr++ = '.';
8022           dir_start = 1;
8023           dir_dot = 1;
8024           if (vmslen > 7) {
8025           int cmp;
8026             rptr = vmsptr - 7;
8027             cmp = strcmp(rptr,"000000.");
8028             if (cmp == 0) {
8029               vmslen -= 7;
8030               vmsptr -= 7;
8031               vmsptr[1] = '\0';
8032             } /* removing 6 zeros */
8033           } /* vmslen < 7, no 6 zeros possible */
8034         } /* Not in a directory */
8035       } /* Posix root found */
8036       else {
8037         /* No posix root, fall back to default directory */
8038         strcpy(vmspath, "SYS$DISK:[");
8039         vmsptr = &vmspath[10];
8040         vmslen = 10;
8041         if (unixptr > lastslash) {
8042            *vmsptr = ']';
8043            vmsptr++;
8044            vmslen++;
8045         }
8046         else {
8047            dir_start = 1;
8048         }
8049       }
8050     } /* end of verified real path handling */
8051     else {
8052     int add_6zero;
8053     int islnm;
8054
8055       /* Ok, we have a device or a concealed root that is not in POSIX
8056        * or we have garbage.  Make the best of it.
8057        */
8058
8059       /* Posix to VMS destroyed this, so copy it again */
8060       strncpy(vmspath, &unixptr[1], seg_len);
8061       vmspath[seg_len] = 0;
8062       vmslen = seg_len;
8063       vmsptr = &vmsptr[vmslen];
8064       islnm = 0;
8065
8066       /* Now do we need to add the fake 6 zero directory to it? */
8067       add_6zero = 1;
8068       if ((*lastslash == '/') && (nextslash < lastslash)) {
8069         /* No there is another directory */
8070         add_6zero = 0;
8071       }
8072       else {
8073       int trnend;
8074       int cmp;
8075
8076         /* now we have foo:bar or foo:[000000]bar to decide from */
8077         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8078
8079         if (!islnm && !decc_posix_compliant_pathnames) {
8080
8081             cmp = strncmp("bin", vmspath, 4);
8082             if (cmp == 0) {
8083                 /* bin => SYS$SYSTEM: */
8084                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8085             }
8086             else {
8087                 /* tmp => SYS$SCRATCH: */
8088                 cmp = strncmp("tmp", vmspath, 4);
8089                 if (cmp == 0) {
8090                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8091                 }
8092             }
8093         }
8094
8095         trnend = islnm ? islnm - 1 : 0;
8096
8097         /* if this was a logical name, ']' or '>' must be present */
8098         /* if not a logical name, then assume a device and hope. */
8099         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8100
8101         /* if log name and trailing '.' then rooted - treat as device */
8102         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8103
8104         /* Fix me, if not a logical name, a device lookup should be
8105          * done to see if the device is file structured.  If the device
8106          * is not file structured, the 6 zeros should not be put on.
8107          *
8108          * As it is, perl is occasionally looking for dev:[000000]tty.
8109          * which looks a little strange.
8110          *
8111          * Not that easy to detect as "/dev" may be file structured with
8112          * special device files.
8113          */
8114
8115         if ((add_6zero == 0) && (*nextslash == '/') &&
8116             (&nextslash[1] == unixend)) {
8117           /* No real directory present */
8118           add_6zero = 1;
8119         }
8120       }
8121
8122       /* Put the device delimiter on */
8123       *vmsptr++ = ':';
8124       vmslen++;
8125       unixptr = nextslash;
8126       unixptr++;
8127
8128       /* Start directory if needed */
8129       if (!islnm || add_6zero) {
8130         *vmsptr++ = '[';
8131         vmslen++;
8132         dir_start = 1;
8133       }
8134
8135       /* add fake 000000] if needed */
8136       if (add_6zero) {
8137         *vmsptr++ = '0';
8138         *vmsptr++ = '0';
8139         *vmsptr++ = '0';
8140         *vmsptr++ = '0';
8141         *vmsptr++ = '0';
8142         *vmsptr++ = '0';
8143         *vmsptr++ = ']';
8144         vmslen += 7;
8145         dir_start = 0;
8146       }
8147
8148     } /* non-POSIX translation */
8149     PerlMem_free(esa);
8150   } /* End of relative/absolute path handling */
8151
8152   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8153   int dash_flag;
8154   int in_cnt;
8155   int out_cnt;
8156
8157     dash_flag = 0;
8158
8159     if (dir_start != 0) {
8160
8161       /* First characters in a directory are handled special */
8162       while ((*unixptr == '/') ||
8163              ((*unixptr == '.') &&
8164               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8165                 (&unixptr[1]==unixend)))) {
8166       int loop_flag;
8167
8168         loop_flag = 0;
8169
8170         /* Skip redundant / in specification */
8171         while ((*unixptr == '/') && (dir_start != 0)) {
8172           loop_flag = 1;
8173           unixptr++;
8174           if (unixptr == lastslash)
8175             break;
8176         }
8177         if (unixptr == lastslash)
8178           break;
8179
8180         /* Skip redundant ./ characters */
8181         while ((*unixptr == '.') &&
8182                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8183           loop_flag = 1;
8184           unixptr++;
8185           if (unixptr == lastslash)
8186             break;
8187           if (*unixptr == '/')
8188             unixptr++;
8189         }
8190         if (unixptr == lastslash)
8191           break;
8192
8193         /* Skip redundant ../ characters */
8194         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8195              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8196           /* Set the backing up flag */
8197           loop_flag = 1;
8198           dir_dot = 0;
8199           dash_flag = 1;
8200           *vmsptr++ = '-';
8201           vmslen++;
8202           unixptr++; /* first . */
8203           unixptr++; /* second . */
8204           if (unixptr == lastslash)
8205             break;
8206           if (*unixptr == '/') /* The slash */
8207             unixptr++;
8208         }
8209         if (unixptr == lastslash)
8210           break;
8211
8212         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8213         /* Not needed when VMS is pretending to be UNIX. */
8214
8215         /* Is this loop stuck because of too many dots? */
8216         if (loop_flag == 0) {
8217           /* Exit the loop and pass the rest through */
8218           break;
8219         }
8220       }
8221
8222       /* Are we done with directories yet? */
8223       if (unixptr >= lastslash) {
8224
8225         /* Watch out for trailing dots */
8226         if (dir_dot != 0) {
8227             vmslen --;
8228             vmsptr--;
8229         }
8230         *vmsptr++ = ']';
8231         vmslen++;
8232         dash_flag = 0;
8233         dir_start = 0;
8234         if (*unixptr == '/')
8235           unixptr++;
8236       }
8237       else {
8238         /* Have we stopped backing up? */
8239         if (dash_flag) {
8240           *vmsptr++ = '.';
8241           vmslen++;
8242           dash_flag = 0;
8243           /* dir_start continues to be = 1 */
8244         }
8245         if (*unixptr == '-') {
8246           *vmsptr++ = '^';
8247           *vmsptr++ = *unixptr++;
8248           vmslen += 2;
8249           dir_start = 0;
8250
8251           /* Now are we done with directories yet? */
8252           if (unixptr >= lastslash) {
8253
8254             /* Watch out for trailing dots */
8255             if (dir_dot != 0) {
8256               vmslen --;
8257               vmsptr--;
8258             }
8259
8260             *vmsptr++ = ']';
8261             vmslen++;
8262             dash_flag = 0;
8263             dir_start = 0;
8264           }
8265         }
8266       }
8267     }
8268
8269     /* All done? */
8270     if (unixptr >= unixend)
8271       break;
8272
8273     /* Normal characters - More EFS work probably needed */
8274     dir_start = 0;
8275     dir_dot = 0;
8276
8277     switch(*unixptr) {
8278     case '/':
8279         /* remove multiple / */
8280         while (unixptr[1] == '/') {
8281            unixptr++;
8282         }
8283         if (unixptr == lastslash) {
8284           /* Watch out for trailing dots */
8285           if (dir_dot != 0) {
8286             vmslen --;
8287             vmsptr--;
8288           }
8289           *vmsptr++ = ']';
8290         }
8291         else {
8292           dir_start = 1;
8293           *vmsptr++ = '.';
8294           dir_dot = 1;
8295
8296           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8297           /* Not needed when VMS is pretending to be UNIX. */
8298
8299         }
8300         dash_flag = 0;
8301         if (unixptr != unixend)
8302           unixptr++;
8303         vmslen++;
8304         break;
8305     case '.':
8306         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8307             (&unixptr[1] == unixend)) {
8308           *vmsptr++ = '^';
8309           *vmsptr++ = '.';
8310           vmslen += 2;
8311           unixptr++;
8312
8313           /* trailing dot ==> '^..' on VMS */
8314           if (unixptr == unixend) {
8315             *vmsptr++ = '.';
8316             vmslen++;
8317             unixptr++;
8318           }
8319           break;
8320         }
8321
8322         *vmsptr++ = *unixptr++;
8323         vmslen ++;
8324         break;
8325     case '"':
8326         if (quoted && (&unixptr[1] == unixend)) {
8327             unixptr++;
8328             break;
8329         }
8330         in_cnt = copy_expand_unix_filename_escape
8331                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8332         vmsptr += out_cnt;
8333         unixptr += in_cnt;
8334         break;
8335     case '~':
8336     case ';':
8337     case '\\':
8338     case '?':
8339     case ' ':
8340     default:
8341         in_cnt = copy_expand_unix_filename_escape
8342                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8343         vmsptr += out_cnt;
8344         unixptr += in_cnt;
8345         break;
8346     }
8347   }
8348
8349   /* Make sure directory is closed */
8350   if (unixptr == lastslash) {
8351     char *vmsptr2;
8352     vmsptr2 = vmsptr - 1;
8353
8354     if (*vmsptr2 != ']') {
8355       *vmsptr2--;
8356
8357       /* directories do not end in a dot bracket */
8358       if (*vmsptr2 == '.') {
8359         vmsptr2--;
8360
8361         /* ^. is allowed */
8362         if (*vmsptr2 != '^') {
8363           vmsptr--; /* back up over the dot */
8364         }
8365       }
8366       *vmsptr++ = ']';
8367     }
8368   }
8369   else {
8370     char *vmsptr2;
8371     /* Add a trailing dot if a file with no extension */
8372     vmsptr2 = vmsptr - 1;
8373     if ((vmslen > 1) &&
8374         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8375         (*vmsptr2 != ')') && (*lastdot != '.')) {
8376         *vmsptr++ = '.';
8377         vmslen++;
8378     }
8379   }
8380
8381   *vmsptr = '\0';
8382   return SS$_NORMAL;
8383 }
8384 #endif
8385
8386  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8387 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8388 {
8389 char * result;
8390 int utf8_flag;
8391
8392    /* If a UTF8 flag is being passed, honor it */
8393    utf8_flag = 0;
8394    if (utf8_fl != NULL) {
8395      utf8_flag = *utf8_fl;
8396     *utf8_fl = 0;
8397    }
8398
8399    if (utf8_flag) {
8400      /* If there is a possibility of UTF8, then if any UTF8 characters
8401         are present, then they must be converted to VTF-7
8402       */
8403      result = strcpy(rslt, path); /* FIX-ME */
8404    }
8405    else
8406      result = strcpy(rslt, path);
8407
8408    return result;
8409 }
8410
8411
8412
8413 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8414 static char *int_tovmsspec
8415    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8416   char *dirend;
8417   char *lastdot;
8418   char *vms_delim;
8419   register char *cp1;
8420   const char *cp2;
8421   unsigned long int infront = 0, hasdir = 1;
8422   int rslt_len;
8423   int no_type_seen;
8424   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8425   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8426
8427   if (vms_debug_fileify) {
8428       if (path == NULL)
8429           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8430       else
8431           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8432   }
8433
8434   if (path == NULL) {
8435       /* If we fail, we should be setting errno */
8436       set_errno(EINVAL);
8437       set_vaxc_errno(SS$_BADPARAM);
8438       return NULL;
8439   }
8440   rslt_len = VMS_MAXRSS-1;
8441
8442   /* '.' and '..' are "[]" and "[-]" for a quick check */
8443   if (path[0] == '.') {
8444     if (path[1] == '\0') {
8445       strcpy(rslt,"[]");
8446       if (utf8_flag != NULL)
8447         *utf8_flag = 0;
8448       return rslt;
8449     }
8450     else {
8451       if (path[1] == '.' && path[2] == '\0') {
8452         strcpy(rslt,"[-]");
8453         if (utf8_flag != NULL)
8454            *utf8_flag = 0;
8455         return rslt;
8456       }
8457     }
8458   }
8459
8460    /* Posix specifications are now a native VMS format */
8461   /*--------------------------------------------------*/
8462 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8463   if (decc_posix_compliant_pathnames) {
8464     if (strncmp(path,"\"^UP^",5) == 0) {
8465       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8466       return rslt;
8467     }
8468   }
8469 #endif
8470
8471   /* This is really the only way to see if this is already in VMS format */
8472   sts = vms_split_path
8473        (path,
8474         &v_spec,
8475         &v_len,
8476         &r_spec,
8477         &r_len,
8478         &d_spec,
8479         &d_len,
8480         &n_spec,
8481         &n_len,
8482         &e_spec,
8483         &e_len,
8484         &vs_spec,
8485         &vs_len);
8486   if (sts == 0) {
8487     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8488        replacement, because the above parse just took care of most of
8489        what is needed to do vmspath when the specification is already
8490        in VMS format.
8491
8492        And if it is not already, it is easier to do the conversion as
8493        part of this routine than to call this routine and then work on
8494        the result.
8495      */
8496
8497     /* If VMS punctuation was found, it is already VMS format */
8498     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8499       if (utf8_flag != NULL)
8500         *utf8_flag = 0;
8501       strcpy(rslt, path);
8502       if (vms_debug_fileify) {
8503           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8504       }
8505       return rslt;
8506     }
8507     /* Now, what to do with trailing "." cases where there is no
8508        extension?  If this is a UNIX specification, and EFS characters
8509        are enabled, then the trailing "." should be converted to a "^.".
8510        But if this was already a VMS specification, then it should be
8511        left alone.
8512
8513        So in the case of ambiguity, leave the specification alone.
8514      */
8515
8516
8517     /* If there is a possibility of UTF8, then if any UTF8 characters
8518         are present, then they must be converted to VTF-7
8519      */
8520     if (utf8_flag != NULL)
8521       *utf8_flag = 0;
8522     strcpy(rslt, path);
8523     if (vms_debug_fileify) {
8524         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8525     }
8526     return rslt;
8527   }
8528
8529   dirend = strrchr(path,'/');
8530
8531   if (dirend == NULL) {
8532      char *macro_start;
8533      int has_macro;
8534
8535      /* If we get here with no UNIX directory delimiters, then this is
8536         not a complete file specification, either garbage a UNIX glob
8537         specification that can not be converted to a VMS wildcard, or
8538         it a UNIX shell macro.  MakeMaker wants shell macros passed
8539         through AS-IS,
8540
8541         utf8 flag setting needs to be preserved.
8542       */
8543       hasdir = 0;
8544
8545       has_macro = 0;
8546       macro_start = strchr(path,'$');
8547       if (macro_start != NULL) {
8548           if (macro_start[1] == '(') {
8549               has_macro = 1;
8550           }
8551       }
8552       if ((decc_efs_charset == 0) || (has_macro)) {
8553           strcpy(rslt, path);
8554           if (vms_debug_fileify) {
8555               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8556           }
8557           return rslt;
8558       }
8559   }
8560
8561 /* If POSIX mode active, handle the conversion */
8562 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8563   if (decc_efs_charset) {
8564     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8565     if (vms_debug_fileify) {
8566         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8567     }
8568     return rslt;
8569   }
8570 #endif
8571
8572   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8573     if (!*(dirend+2)) dirend +=2;
8574     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8575     if (decc_efs_charset == 0) {
8576       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8577     }
8578   }
8579
8580   cp1 = rslt;
8581   cp2 = path;
8582   lastdot = strrchr(cp2,'.');
8583   if (*cp2 == '/') {
8584     char *trndev;
8585     int islnm, rooted;
8586     STRLEN trnend;
8587
8588     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8589     if (!*(cp2+1)) {
8590       if (decc_disable_posix_root) {
8591         strcpy(rslt,"sys$disk:[000000]");
8592       }
8593       else {
8594         strcpy(rslt,"sys$posix_root:[000000]");
8595       }
8596       if (utf8_flag != NULL)
8597         *utf8_flag = 0;
8598       if (vms_debug_fileify) {
8599           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8600       }
8601       return rslt;
8602     }
8603     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8604     *cp1 = '\0';
8605     trndev = PerlMem_malloc(VMS_MAXRSS);
8606     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8607     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8608
8609      /* DECC special handling */
8610     if (!islnm) {
8611       if (strcmp(rslt,"bin") == 0) {
8612         strcpy(rslt,"sys$system");
8613         cp1 = rslt + 10;
8614         *cp1 = 0;
8615         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8616       }
8617       else if (strcmp(rslt,"tmp") == 0) {
8618         strcpy(rslt,"sys$scratch");
8619         cp1 = rslt + 11;
8620         *cp1 = 0;
8621         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8622       }
8623       else if (!decc_disable_posix_root) {
8624         strcpy(rslt, "sys$posix_root");
8625         cp1 = rslt + 14;
8626         *cp1 = 0;
8627         cp2 = path;
8628         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8629         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8630       }
8631       else if (strcmp(rslt,"dev") == 0) {
8632         if (strncmp(cp2,"/null", 5) == 0) {
8633           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8634             strcpy(rslt,"NLA0");
8635             cp1 = rslt + 4;
8636             *cp1 = 0;
8637             cp2 = cp2 + 5;
8638             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8639           }
8640         }
8641       }
8642     }
8643
8644     trnend = islnm ? strlen(trndev) - 1 : 0;
8645     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8646     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8647     /* If the first element of the path is a logical name, determine
8648      * whether it has to be translated so we can add more directories. */
8649     if (!islnm || rooted) {
8650       *(cp1++) = ':';
8651       *(cp1++) = '[';
8652       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8653       else cp2++;
8654     }
8655     else {
8656       if (cp2 != dirend) {
8657         strcpy(rslt,trndev);
8658         cp1 = rslt + trnend;
8659         if (*cp2 != 0) {
8660           *(cp1++) = '.';
8661           cp2++;
8662         }
8663       }
8664       else {
8665         if (decc_disable_posix_root) {
8666           *(cp1++) = ':';
8667           hasdir = 0;
8668         }
8669       }
8670     }
8671     PerlMem_free(trndev);
8672   }
8673   else {
8674     *(cp1++) = '[';
8675     if (*cp2 == '.') {
8676       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8677         cp2 += 2;         /* skip over "./" - it's redundant */
8678         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8679       }
8680       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8681         *(cp1++) = '-';                                 /* "../" --> "-" */
8682         cp2 += 3;
8683       }
8684       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8685                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8686         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8687         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8688         cp2 += 4;
8689       }
8690       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8691         /* Escape the extra dots in EFS file specifications */
8692         *(cp1++) = '^';
8693       }
8694       if (cp2 > dirend) cp2 = dirend;
8695     }
8696     else *(cp1++) = '.';
8697   }
8698   for (; cp2 < dirend; cp2++) {
8699     if (*cp2 == '/') {
8700       if (*(cp2-1) == '/') continue;
8701       if (*(cp1-1) != '.') *(cp1++) = '.';
8702       infront = 0;
8703     }
8704     else if (!infront && *cp2 == '.') {
8705       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8706       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8707       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8708         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8709         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8710         else {  /* back up over previous directory name */
8711           cp1--;
8712           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8713           if (*(cp1-1) == '[') {
8714             memcpy(cp1,"000000.",7);
8715             cp1 += 7;
8716           }
8717         }
8718         cp2 += 2;
8719         if (cp2 == dirend) break;
8720       }
8721       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8722                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8723         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8724         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8725         if (!*(cp2+3)) {
8726           *(cp1++) = '.';  /* Simulate trailing '/' */
8727           cp2 += 2;  /* for loop will incr this to == dirend */
8728         }
8729         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8730       }
8731       else {
8732         if (decc_efs_charset == 0)
8733           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8734         else {
8735           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8736           *(cp1++) = '.';
8737         }
8738       }
8739     }
8740     else {
8741       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8742       if (*cp2 == '.') {
8743         if (decc_efs_charset == 0)
8744           *(cp1++) = '_';
8745         else {
8746           *(cp1++) = '^';
8747           *(cp1++) = '.';
8748         }
8749       }
8750       else                  *(cp1++) =  *cp2;
8751       infront = 1;
8752     }
8753   }
8754   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8755   if (hasdir) *(cp1++) = ']';
8756   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8757   /* fixme for ODS5 */
8758   no_type_seen = 0;
8759   if (cp2 > lastdot)
8760     no_type_seen = 1;
8761   while (*cp2) {
8762     switch(*cp2) {
8763     case '?':
8764         if (decc_efs_charset == 0)
8765           *(cp1++) = '%';
8766         else
8767           *(cp1++) = '?';
8768         cp2++;
8769     case ' ':
8770         *(cp1)++ = '^';
8771         *(cp1)++ = '_';
8772         cp2++;
8773         break;
8774     case '.':
8775         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8776             decc_readdir_dropdotnotype) {
8777           *(cp1)++ = '^';
8778           *(cp1)++ = '.';
8779           cp2++;
8780
8781           /* trailing dot ==> '^..' on VMS */
8782           if (*cp2 == '\0') {
8783             *(cp1++) = '.';
8784             no_type_seen = 0;
8785           }
8786         }
8787         else {
8788           *(cp1++) = *(cp2++);
8789           no_type_seen = 0;
8790         }
8791         break;
8792     case '$':
8793          /* This could be a macro to be passed through */
8794         *(cp1++) = *(cp2++);
8795         if (*cp2 == '(') {
8796         const char * save_cp2;
8797         char * save_cp1;
8798         int is_macro;
8799
8800             /* paranoid check */
8801             save_cp2 = cp2;
8802             save_cp1 = cp1;
8803             is_macro = 0;
8804
8805             /* Test through */
8806             *(cp1++) = *(cp2++);
8807             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8808                 *(cp1++) = *(cp2++);
8809                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8810                     *(cp1++) = *(cp2++);
8811                 }
8812                 if (*cp2 == ')') {
8813                     *(cp1++) = *(cp2++);
8814                     is_macro = 1;
8815                 }
8816             }
8817             if (is_macro == 0) {
8818                 /* Not really a macro - never mind */
8819                 cp2 = save_cp2;
8820                 cp1 = save_cp1;
8821             }
8822         }
8823         break;
8824     case '\"':
8825     case '~':
8826     case '`':
8827     case '!':
8828     case '#':
8829     case '%':
8830     case '^':
8831         /* Don't escape again if following character is
8832          * already something we escape.
8833          */
8834         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8835             *(cp1++) = *(cp2++);
8836             break;
8837         }
8838         /* But otherwise fall through and escape it. */
8839     case '&':
8840     case '(':
8841     case ')':
8842     case '=':
8843     case '+':
8844     case '\'':
8845     case '@':
8846     case '[':
8847     case ']':
8848     case '{':
8849     case '}':
8850     case ':':
8851     case '\\':
8852     case '|':
8853     case '<':
8854     case '>':
8855         *(cp1++) = '^';
8856         *(cp1++) = *(cp2++);
8857         break;
8858     case ';':
8859         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8860          * which is wrong.  UNIX notation should be ".dir." unless
8861          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8862          * changing this behavior could break more things at this time.
8863          * efs character set effectively does not allow "." to be a version
8864          * delimiter as a further complication about changing this.
8865          */
8866         if (decc_filename_unix_report != 0) {
8867           *(cp1++) = '^';
8868         }
8869         *(cp1++) = *(cp2++);
8870         break;
8871     default:
8872         *(cp1++) = *(cp2++);
8873     }
8874   }
8875   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8876   char *lcp1;
8877     lcp1 = cp1;
8878     lcp1--;
8879      /* Fix me for "^]", but that requires making sure that you do
8880       * not back up past the start of the filename
8881       */
8882     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8883       *cp1++ = '.';
8884   }
8885   *cp1 = '\0';
8886
8887   if (utf8_flag != NULL)
8888     *utf8_flag = 0;
8889   if (vms_debug_fileify) {
8890       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8891   }
8892   return rslt;
8893
8894 }  /* end of int_tovmsspec() */
8895
8896
8897 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8898 static char *mp_do_tovmsspec
8899    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8900   static char __tovmsspec_retbuf[VMS_MAXRSS];
8901     char * vmsspec, *ret_spec, *ret_buf;
8902
8903     vmsspec = NULL;
8904     ret_buf = buf;
8905     if (ret_buf == NULL) {
8906         if (ts) {
8907             Newx(vmsspec, VMS_MAXRSS, char);
8908             if (vmsspec == NULL)
8909                 _ckvmssts(SS$_INSFMEM);
8910             ret_buf = vmsspec;
8911         } else {
8912             ret_buf = __tovmsspec_retbuf;
8913         }
8914     }
8915
8916     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8917
8918     if (ret_spec == NULL) {
8919        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8920        if (vmsspec)
8921            Safefree(vmsspec);
8922     }
8923
8924     return ret_spec;
8925
8926 }  /* end of mp_do_tovmsspec() */
8927 /*}}}*/
8928 /* External entry points */
8929 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8930   { return do_tovmsspec(path,buf,0,NULL); }
8931 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8932   { return do_tovmsspec(path,buf,1,NULL); }
8933 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8934   { return do_tovmsspec(path,buf,0,utf8_fl); }
8935 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8936   { return do_tovmsspec(path,buf,1,utf8_fl); }
8937
8938 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8939 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8940   static char __tovmspath_retbuf[VMS_MAXRSS];
8941   int vmslen;
8942   char *pathified, *vmsified, *cp;
8943
8944   if (path == NULL) return NULL;
8945   pathified = PerlMem_malloc(VMS_MAXRSS);
8946   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8947   if (int_pathify_dirspec(path, pathified) == NULL) {
8948     PerlMem_free(pathified);
8949     return NULL;
8950   }
8951
8952   vmsified = NULL;
8953   if (buf == NULL)
8954      Newx(vmsified, VMS_MAXRSS, char);
8955   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8956     PerlMem_free(pathified);
8957     if (vmsified) Safefree(vmsified);
8958     return NULL;
8959   }
8960   PerlMem_free(pathified);
8961   if (buf) {
8962     return buf;
8963   }
8964   else if (ts) {
8965     vmslen = strlen(vmsified);
8966     Newx(cp,vmslen+1,char);
8967     memcpy(cp,vmsified,vmslen);
8968     cp[vmslen] = '\0';
8969     Safefree(vmsified);
8970     return cp;
8971   }
8972   else {
8973     strcpy(__tovmspath_retbuf,vmsified);
8974     Safefree(vmsified);
8975     return __tovmspath_retbuf;
8976   }
8977
8978 }  /* end of do_tovmspath() */
8979 /*}}}*/
8980 /* External entry points */
8981 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8982   { return do_tovmspath(path,buf,0, NULL); }
8983 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8984   { return do_tovmspath(path,buf,1, NULL); }
8985 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8986   { return do_tovmspath(path,buf,0,utf8_fl); }
8987 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8988   { return do_tovmspath(path,buf,1,utf8_fl); }
8989
8990
8991 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8992 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8993   static char __tounixpath_retbuf[VMS_MAXRSS];
8994   int unixlen;
8995   char *pathified, *unixified, *cp;
8996
8997   if (path == NULL) return NULL;
8998   pathified = PerlMem_malloc(VMS_MAXRSS);
8999   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9000   if (int_pathify_dirspec(path, pathified) == NULL) {
9001     PerlMem_free(pathified);
9002     return NULL;
9003   }
9004
9005   unixified = NULL;
9006   if (buf == NULL) {
9007       Newx(unixified, VMS_MAXRSS, char);
9008   }
9009   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
9010     PerlMem_free(pathified);
9011     if (unixified) Safefree(unixified);
9012     return NULL;
9013   }
9014   PerlMem_free(pathified);
9015   if (buf) {
9016     return buf;
9017   }
9018   else if (ts) {
9019     unixlen = strlen(unixified);
9020     Newx(cp,unixlen+1,char);
9021     memcpy(cp,unixified,unixlen);
9022     cp[unixlen] = '\0';
9023     Safefree(unixified);
9024     return cp;
9025   }
9026   else {
9027     strcpy(__tounixpath_retbuf,unixified);
9028     Safefree(unixified);
9029     return __tounixpath_retbuf;
9030   }
9031
9032 }  /* end of do_tounixpath() */
9033 /*}}}*/
9034 /* External entry points */
9035 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
9036   { return do_tounixpath(path,buf,0,NULL); }
9037 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9038   { return do_tounixpath(path,buf,1,NULL); }
9039 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9040   { return do_tounixpath(path,buf,0,utf8_fl); }
9041 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9042   { return do_tounixpath(path,buf,1,utf8_fl); }
9043
9044 /*
9045  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
9046  *
9047  *****************************************************************************
9048  *                                                                           *
9049  *  Copyright (C) 1989-1994, 2007 by                                         *
9050  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
9051  *                                                                           *
9052  *  Permission is hereby granted for the reproduction of this software       *
9053  *  on condition that this copyright notice is included in source            *
9054  *  distributions of the software.  The code may be modified and             *
9055  *  distributed under the same terms as Perl itself.                         *
9056  *                                                                           *
9057  *  27-Aug-1994 Modified for inclusion in perl5                              *
9058  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
9059  *****************************************************************************
9060  */
9061
9062 /*
9063  * getredirection() is intended to aid in porting C programs
9064  * to VMS (Vax-11 C).  The native VMS environment does not support
9065  * '>' and '<' I/O redirection, or command line wild card expansion,
9066  * or a command line pipe mechanism using the '|' AND background
9067  * command execution '&'.  All of these capabilities are provided to any
9068  * C program which calls this procedure as the first thing in the
9069  * main program.
9070  * The piping mechanism will probably work with almost any 'filter' type
9071  * of program.  With suitable modification, it may useful for other
9072  * portability problems as well.
9073  *
9074  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
9075  */
9076 struct list_item
9077     {
9078     struct list_item *next;
9079     char *value;
9080     };
9081
9082 static void add_item(struct list_item **head,
9083                      struct list_item **tail,
9084                      char *value,
9085                      int *count);
9086
9087 static void mp_expand_wild_cards(pTHX_ char *item,
9088                                 struct list_item **head,
9089                                 struct list_item **tail,
9090                                 int *count);
9091
9092 static int background_process(pTHX_ int argc, char **argv);
9093
9094 static void pipe_and_fork(pTHX_ char **cmargv);
9095
9096 /*{{{ void getredirection(int *ac, char ***av)*/
9097 static void
9098 mp_getredirection(pTHX_ int *ac, char ***av)
9099 /*
9100  * Process vms redirection arg's.  Exit if any error is seen.
9101  * If getredirection() processes an argument, it is erased
9102  * from the vector.  getredirection() returns a new argc and argv value.
9103  * In the event that a background command is requested (by a trailing "&"),
9104  * this routine creates a background subprocess, and simply exits the program.
9105  *
9106  * Warning: do not try to simplify the code for vms.  The code
9107  * presupposes that getredirection() is called before any data is
9108  * read from stdin or written to stdout.
9109  *
9110  * Normal usage is as follows:
9111  *
9112  *      main(argc, argv)
9113  *      int             argc;
9114  *      char            *argv[];
9115  *      {
9116  *              getredirection(&argc, &argv);
9117  *      }
9118  */
9119 {
9120     int                 argc = *ac;     /* Argument Count         */
9121     char                **argv = *av;   /* Argument Vector        */
9122     char                *ap;            /* Argument pointer       */
9123     int                 j;              /* argv[] index           */
9124     int                 item_count = 0; /* Count of Items in List */
9125     struct list_item    *list_head = 0; /* First Item in List       */
9126     struct list_item    *list_tail;     /* Last Item in List        */
9127     char                *in = NULL;     /* Input File Name          */
9128     char                *out = NULL;    /* Output File Name         */
9129     char                *outmode = "w"; /* Mode to Open Output File */
9130     char                *err = NULL;    /* Error File Name          */
9131     char                *errmode = "w"; /* Mode to Open Error File  */
9132     int                 cmargc = 0;     /* Piped Command Arg Count  */
9133     char                **cmargv = NULL;/* Piped Command Arg Vector */
9134
9135     /*
9136      * First handle the case where the last thing on the line ends with
9137      * a '&'.  This indicates the desire for the command to be run in a
9138      * subprocess, so we satisfy that desire.
9139      */
9140     ap = argv[argc-1];
9141     if (0 == strcmp("&", ap))
9142        exit(background_process(aTHX_ --argc, argv));
9143     if (*ap && '&' == ap[strlen(ap)-1])
9144         {
9145         ap[strlen(ap)-1] = '\0';
9146        exit(background_process(aTHX_ argc, argv));
9147         }
9148     /*
9149      * Now we handle the general redirection cases that involve '>', '>>',
9150      * '<', and pipes '|'.
9151      */
9152     for (j = 0; j < argc; ++j)
9153         {
9154         if (0 == strcmp("<", argv[j]))
9155             {
9156             if (j+1 >= argc)
9157                 {
9158                 fprintf(stderr,"No input file after < on command line");
9159                 exit(LIB$_WRONUMARG);
9160                 }
9161             in = argv[++j];
9162             continue;
9163             }
9164         if ('<' == *(ap = argv[j]))
9165             {
9166             in = 1 + ap;
9167             continue;
9168             }
9169         if (0 == strcmp(">", ap))
9170             {
9171             if (j+1 >= argc)
9172                 {
9173                 fprintf(stderr,"No output file after > on command line");
9174                 exit(LIB$_WRONUMARG);
9175                 }
9176             out = argv[++j];
9177             continue;
9178             }
9179         if ('>' == *ap)
9180             {
9181             if ('>' == ap[1])
9182                 {
9183                 outmode = "a";
9184                 if ('\0' == ap[2])
9185                     out = argv[++j];
9186                 else
9187                     out = 2 + ap;
9188                 }
9189             else
9190                 out = 1 + ap;
9191             if (j >= argc)
9192                 {
9193                 fprintf(stderr,"No output file after > or >> on command line");
9194                 exit(LIB$_WRONUMARG);
9195                 }
9196             continue;
9197             }
9198         if (('2' == *ap) && ('>' == ap[1]))
9199             {
9200             if ('>' == ap[2])
9201                 {
9202                 errmode = "a";
9203                 if ('\0' == ap[3])
9204                     err = argv[++j];
9205                 else
9206                     err = 3 + ap;
9207                 }
9208             else
9209                 if ('\0' == ap[2])
9210                     err = argv[++j];
9211                 else
9212                     err = 2 + ap;
9213             if (j >= argc)
9214                 {
9215                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9216                 exit(LIB$_WRONUMARG);
9217                 }
9218             continue;
9219             }
9220         if (0 == strcmp("|", argv[j]))
9221             {
9222             if (j+1 >= argc)
9223                 {
9224                 fprintf(stderr,"No command into which to pipe on command line");
9225                 exit(LIB$_WRONUMARG);
9226                 }
9227             cmargc = argc-(j+1);
9228             cmargv = &argv[j+1];
9229             argc = j;
9230             continue;
9231             }
9232         if ('|' == *(ap = argv[j]))
9233             {
9234             ++argv[j];
9235             cmargc = argc-j;
9236             cmargv = &argv[j];
9237             argc = j;
9238             continue;
9239             }
9240         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9241         }
9242     /*
9243      * Allocate and fill in the new argument vector, Some Unix's terminate
9244      * the list with an extra null pointer.
9245      */
9246     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9247     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9248     *av = argv;
9249     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9250         argv[j] = list_head->value;
9251     *ac = item_count;
9252     if (cmargv != NULL)
9253         {
9254         if (out != NULL)
9255             {
9256             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9257             exit(LIB$_INVARGORD);
9258             }
9259         pipe_and_fork(aTHX_ cmargv);
9260         }
9261
9262     /* Check for input from a pipe (mailbox) */
9263
9264     if (in == NULL && 1 == isapipe(0))
9265         {
9266         char mbxname[L_tmpnam];
9267         long int bufsize;
9268         long int dvi_item = DVI$_DEVBUFSIZ;
9269         $DESCRIPTOR(mbxnam, "");
9270         $DESCRIPTOR(mbxdevnam, "");
9271
9272         /* Input from a pipe, reopen it in binary mode to disable       */
9273         /* carriage control processing.                                 */
9274
9275         fgetname(stdin, mbxname);
9276         mbxnam.dsc$a_pointer = mbxname;
9277         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9278         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9279         mbxdevnam.dsc$a_pointer = mbxname;
9280         mbxdevnam.dsc$w_length = sizeof(mbxname);
9281         dvi_item = DVI$_DEVNAM;
9282         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9283         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9284         set_errno(0);
9285         set_vaxc_errno(1);
9286         freopen(mbxname, "rb", stdin);
9287         if (errno != 0)
9288             {
9289             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9290             exit(vaxc$errno);
9291             }
9292         }
9293     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9294         {
9295         fprintf(stderr,"Can't open input file %s as stdin",in);
9296         exit(vaxc$errno);
9297         }
9298     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9299         {
9300         fprintf(stderr,"Can't open output file %s as stdout",out);
9301         exit(vaxc$errno);
9302         }
9303         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9304
9305     if (err != NULL) {
9306         if (strcmp(err,"&1") == 0) {
9307             dup2(fileno(stdout), fileno(stderr));
9308             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9309         } else {
9310         FILE *tmperr;
9311         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9312             {
9313             fprintf(stderr,"Can't open error file %s as stderr",err);
9314             exit(vaxc$errno);
9315             }
9316             fclose(tmperr);
9317            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9318                 {
9319                 exit(vaxc$errno);
9320                 }
9321             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9322         }
9323         }
9324 #ifdef ARGPROC_DEBUG
9325     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9326     for (j = 0; j < *ac;  ++j)
9327         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9328 #endif
9329    /* Clear errors we may have hit expanding wildcards, so they don't
9330       show up in Perl's $! later */
9331    set_errno(0); set_vaxc_errno(1);
9332 }  /* end of getredirection() */
9333 /*}}}*/
9334
9335 static void add_item(struct list_item **head,
9336                      struct list_item **tail,
9337                      char *value,
9338                      int *count)
9339 {
9340     if (*head == 0)
9341         {
9342         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9343         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9344         *tail = *head;
9345         }
9346     else {
9347         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9348         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9349         *tail = (*tail)->next;
9350         }
9351     (*tail)->value = value;
9352     ++(*count);
9353 }
9354
9355 static void mp_expand_wild_cards(pTHX_ char *item,
9356                               struct list_item **head,
9357                               struct list_item **tail,
9358                               int *count)
9359 {
9360 int expcount = 0;
9361 unsigned long int context = 0;
9362 int isunix = 0;
9363 int item_len = 0;
9364 char *had_version;
9365 char *had_device;
9366 int had_directory;
9367 char *devdir,*cp;
9368 char *vmsspec;
9369 $DESCRIPTOR(filespec, "");
9370 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9371 $DESCRIPTOR(resultspec, "");
9372 unsigned long int lff_flags = 0;
9373 int sts;
9374 int rms_sts;
9375
9376 #ifdef VMS_LONGNAME_SUPPORT
9377     lff_flags = LIB$M_FIL_LONG_NAMES;
9378 #endif
9379
9380     for (cp = item; *cp; cp++) {
9381         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9382         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9383     }
9384     if (!*cp || isspace(*cp))
9385         {
9386         add_item(head, tail, item, count);
9387         return;
9388         }
9389     else
9390         {
9391      /* "double quoted" wild card expressions pass as is */
9392      /* From DCL that means using e.g.:                  */
9393      /* perl program """perl.*"""                        */
9394      item_len = strlen(item);
9395      if ( '"' == *item && '"' == item[item_len-1] )
9396        {
9397        item++;
9398        item[item_len-2] = '\0';
9399        add_item(head, tail, item, count);
9400        return;
9401        }
9402      }
9403     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9404     resultspec.dsc$b_class = DSC$K_CLASS_D;
9405     resultspec.dsc$a_pointer = NULL;
9406     vmsspec = PerlMem_malloc(VMS_MAXRSS);
9407     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9408     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9409       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9410     if (!isunix || !filespec.dsc$a_pointer)
9411       filespec.dsc$a_pointer = item;
9412     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9413     /*
9414      * Only return version specs, if the caller specified a version
9415      */
9416     had_version = strchr(item, ';');
9417     /*
9418      * Only return device and directory specs, if the caller specifed either.
9419      */
9420     had_device = strchr(item, ':');
9421     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9422
9423     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9424                                  (&filespec, &resultspec, &context,
9425                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9426         {
9427         char *string;
9428         char *c;
9429
9430         string = PerlMem_malloc(resultspec.dsc$w_length+1);
9431         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9432         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
9433         string[resultspec.dsc$w_length] = '\0';
9434         if (NULL == had_version)
9435             *(strrchr(string, ';')) = '\0';
9436         if ((!had_directory) && (had_device == NULL))
9437             {
9438             if (NULL == (devdir = strrchr(string, ']')))
9439                 devdir = strrchr(string, '>');
9440             strcpy(string, devdir + 1);
9441             }
9442         /*
9443          * Be consistent with what the C RTL has already done to the rest of
9444          * the argv items and lowercase all of these names.
9445          */
9446         if (!decc_efs_case_preserve) {
9447             for (c = string; *c; ++c)
9448             if (isupper(*c))
9449                 *c = tolower(*c);
9450         }
9451         if (isunix) trim_unixpath(string,item,1);
9452         add_item(head, tail, string, count);
9453         ++expcount;
9454     }
9455     PerlMem_free(vmsspec);
9456     if (sts != RMS$_NMF)
9457         {
9458         set_vaxc_errno(sts);
9459         switch (sts)
9460             {
9461             case RMS$_FNF: case RMS$_DNF:
9462                 set_errno(ENOENT); break;
9463             case RMS$_DIR:
9464                 set_errno(ENOTDIR); break;
9465             case RMS$_DEV:
9466                 set_errno(ENODEV); break;
9467             case RMS$_FNM: case RMS$_SYN:
9468                 set_errno(EINVAL); break;
9469             case RMS$_PRV:
9470                 set_errno(EACCES); break;
9471             default:
9472                 _ckvmssts_noperl(sts);
9473             }
9474         }
9475     if (expcount == 0)
9476         add_item(head, tail, item, count);
9477     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9478     _ckvmssts_noperl(lib$find_file_end(&context));
9479 }
9480
9481 static int child_st[2];/* Event Flag set when child process completes   */
9482
9483 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9484
9485 static unsigned long int exit_handler(int *status)
9486 {
9487 short iosb[4];
9488
9489     if (0 == child_st[0])
9490         {
9491 #ifdef ARGPROC_DEBUG
9492         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9493 #endif
9494         fflush(stdout);     /* Have to flush pipe for binary data to    */
9495                             /* terminate properly -- <tp@mccall.com>    */
9496         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9497         sys$dassgn(child_chan);
9498         fclose(stdout);
9499         sys$synch(0, child_st);
9500         }
9501     return(1);
9502 }
9503
9504 static void sig_child(int chan)
9505 {
9506 #ifdef ARGPROC_DEBUG
9507     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9508 #endif
9509     if (child_st[0] == 0)
9510         child_st[0] = 1;
9511 }
9512
9513 static struct exit_control_block exit_block =
9514     {
9515     0,
9516     exit_handler,
9517     1,
9518     &exit_block.exit_status,
9519     0
9520     };
9521
9522 static void
9523 pipe_and_fork(pTHX_ char **cmargv)
9524 {
9525     PerlIO *fp;
9526     struct dsc$descriptor_s *vmscmd;
9527     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9528     int sts, j, l, ismcr, quote, tquote = 0;
9529
9530     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9531     vms_execfree(vmscmd);
9532
9533     j = l = 0;
9534     p = subcmd;
9535     q = cmargv[0];
9536     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9537               && toupper(*(q+2)) == 'R' && !*(q+3);
9538
9539     while (q && l < MAX_DCL_LINE_LENGTH) {
9540         if (!*q) {
9541             if (j > 0 && quote) {
9542                 *p++ = '"';
9543                 l++;
9544             }
9545             q = cmargv[++j];
9546             if (q) {
9547                 if (ismcr && j > 1) quote = 1;
9548                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9549                 *p++ = ' ';
9550                 l++;
9551                 if (quote || tquote) {
9552                     *p++ = '"';
9553                     l++;
9554                 }
9555             }
9556         } else {
9557             if ((quote||tquote) && *q == '"') {
9558                 *p++ = '"';
9559                 l++;
9560             }
9561             *p++ = *q++;
9562             l++;
9563         }
9564     }
9565     *p = '\0';
9566
9567     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9568     if (fp == NULL) {
9569         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9570     }
9571 }
9572
9573 static int background_process(pTHX_ int argc, char **argv)
9574 {
9575 char command[MAX_DCL_SYMBOL + 1] = "$";
9576 $DESCRIPTOR(value, "");
9577 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9578 static $DESCRIPTOR(null, "NLA0:");
9579 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9580 char pidstring[80];
9581 $DESCRIPTOR(pidstr, "");
9582 int pid;
9583 unsigned long int flags = 17, one = 1, retsts;
9584 int len;
9585
9586     strcat(command, argv[0]);
9587     len = strlen(command);
9588     while (--argc && (len < MAX_DCL_SYMBOL))
9589         {
9590         strcat(command, " \"");
9591         strcat(command, *(++argv));
9592         strcat(command, "\"");
9593         len = strlen(command);
9594         }
9595     value.dsc$a_pointer = command;
9596     value.dsc$w_length = strlen(value.dsc$a_pointer);
9597     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9598     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9599     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9600         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9601     }
9602     else {
9603         _ckvmssts_noperl(retsts);
9604     }
9605 #ifdef ARGPROC_DEBUG
9606     PerlIO_printf(Perl_debug_log, "%s\n", command);
9607 #endif
9608     sprintf(pidstring, "%08X", pid);
9609     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9610     pidstr.dsc$a_pointer = pidstring;
9611     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9612     lib$set_symbol(&pidsymbol, &pidstr);
9613     return(SS$_NORMAL);
9614 }
9615 /*}}}*/
9616 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9617
9618
9619 /* OS-specific initialization at image activation (not thread startup) */
9620 /* Older VAXC header files lack these constants */
9621 #ifndef JPI$_RIGHTS_SIZE
9622 #  define JPI$_RIGHTS_SIZE 817
9623 #endif
9624 #ifndef KGB$M_SUBSYSTEM
9625 #  define KGB$M_SUBSYSTEM 0x8
9626 #endif
9627
9628 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9629
9630 /*{{{void vms_image_init(int *, char ***)*/
9631 void
9632 vms_image_init(int *argcp, char ***argvp)
9633 {
9634   int status;
9635   char eqv[LNM$C_NAMLENGTH+1] = "";
9636   unsigned int len, tabct = 8, tabidx = 0;
9637   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9638   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9639   unsigned short int dummy, rlen;
9640   struct dsc$descriptor_s **tabvec;
9641 #if defined(PERL_IMPLICIT_CONTEXT)
9642   pTHX = NULL;
9643 #endif
9644   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9645                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9646                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9647                                  {          0,                0,    0,      0} };
9648
9649 #ifdef KILL_BY_SIGPRC
9650     Perl_csighandler_init();
9651 #endif
9652
9653     /* This was moved from the pre-image init handler because on threaded */
9654     /* Perl it was always returning 0 for the default value. */
9655     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9656     if (status > 0) {
9657         int s;
9658         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9659         if (s > 0) {
9660             int initial;
9661             initial = decc$feature_get_value(s, 4);
9662             if (initial > 0) {
9663                 /* initial is: 0 if nothing has set the feature */
9664                 /*            -1 if initialized to default */
9665                 /*             1 if set by logical name */
9666                 /*             2 if set by decc$feature_set_value */
9667                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9668
9669                 /* If the value is not valid, force the feature off */
9670                 if (decc_disable_posix_root < 0) {
9671                     decc$feature_set_value(s, 1, 1);
9672                     decc_disable_posix_root = 1;
9673                 }
9674             }
9675             else {
9676                 /* Nothing has asked for it explicitly, so use our own default. */
9677                 decc_disable_posix_root = 1;
9678                 decc$feature_set_value(s, 1, 1);
9679             }
9680         }
9681     }
9682
9683
9684   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9685   _ckvmssts_noperl(iosb[0]);
9686   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9687     if (iprv[i]) {           /* Running image installed with privs? */
9688       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9689       will_taint = TRUE;
9690       break;
9691     }
9692   }
9693   /* Rights identifiers might trigger tainting as well. */
9694   if (!will_taint && (rlen || rsz)) {
9695     while (rlen < rsz) {
9696       /* We didn't get all the identifiers on the first pass.  Allocate a
9697        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9698        * were needed to hold all identifiers at time of last call; we'll
9699        * allocate that many unsigned long ints), and go back and get 'em.
9700        * If it gave us less than it wanted to despite ample buffer space,
9701        * something's broken.  Is your system missing a system identifier?
9702        */
9703       if (rsz <= jpilist[1].buflen) {
9704          /* Perl_croak accvios when used this early in startup. */
9705          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9706                          rsz, (unsigned long) jpilist[1].buflen,
9707                          "Check your rights database for corruption.\n");
9708          exit(SS$_ABORT);
9709       }
9710       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9711       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9712       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9713       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9714       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9715       _ckvmssts_noperl(iosb[0]);
9716     }
9717     mask = jpilist[1].bufadr;
9718     /* Check attribute flags for each identifier (2nd longword); protected
9719      * subsystem identifiers trigger tainting.
9720      */
9721     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9722       if (mask[i] & KGB$M_SUBSYSTEM) {
9723         will_taint = TRUE;
9724         break;
9725       }
9726     }
9727     if (mask != rlst) PerlMem_free(mask);
9728   }
9729
9730   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9731    * logical, some versions of the CRTL will add a phanthom /000000/
9732    * directory.  This needs to be removed.
9733    */
9734   if (decc_filename_unix_report) {
9735   char * zeros;
9736   int ulen;
9737     ulen = strlen(argvp[0][0]);
9738     if (ulen > 7) {
9739       zeros = strstr(argvp[0][0], "/000000/");
9740       if (zeros != NULL) {
9741         int mlen;
9742         mlen = ulen - (zeros - argvp[0][0]) - 7;
9743         memmove(zeros, &zeros[7], mlen);
9744         ulen = ulen - 7;
9745         argvp[0][0][ulen] = '\0';
9746       }
9747     }
9748     /* It also may have a trailing dot that needs to be removed otherwise
9749      * it will be converted to VMS mode incorrectly.
9750      */
9751     ulen--;
9752     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9753       argvp[0][0][ulen] = '\0';
9754   }
9755
9756   /* We need to use this hack to tell Perl it should run with tainting,
9757    * since its tainting flag may be part of the PL_curinterp struct, which
9758    * hasn't been allocated when vms_image_init() is called.
9759    */
9760   if (will_taint) {
9761     char **newargv, **oldargv;
9762     oldargv = *argvp;
9763     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9764     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9765     newargv[0] = oldargv[0];
9766     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9767     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9768     strcpy(newargv[1], "-T");
9769     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9770     (*argcp)++;
9771     newargv[*argcp] = NULL;
9772     /* We orphan the old argv, since we don't know where it's come from,
9773      * so we don't know how to free it.
9774      */
9775     *argvp = newargv;
9776   }
9777   else {  /* Did user explicitly request tainting? */
9778     int i;
9779     char *cp, **av = *argvp;
9780     for (i = 1; i < *argcp; i++) {
9781       if (*av[i] != '-') break;
9782       for (cp = av[i]+1; *cp; cp++) {
9783         if (*cp == 'T') { will_taint = 1; break; }
9784         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9785                   strchr("DFIiMmx",*cp)) break;
9786       }
9787       if (will_taint) break;
9788     }
9789   }
9790
9791   for (tabidx = 0;
9792        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9793        tabidx++) {
9794     if (!tabidx) {
9795       tabvec = (struct dsc$descriptor_s **)
9796             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9797       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9798     }
9799     else if (tabidx >= tabct) {
9800       tabct += 8;
9801       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9802       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9803     }
9804     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9805     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9806     tabvec[tabidx]->dsc$w_length  = 0;
9807     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9808     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9809     tabvec[tabidx]->dsc$a_pointer = NULL;
9810     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9811   }
9812   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9813
9814   getredirection(argcp,argvp);
9815 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9816   {
9817 # include <reentrancy.h>
9818   decc$set_reentrancy(C$C_MULTITHREAD);
9819   }
9820 #endif
9821   return;
9822 }
9823 /*}}}*/
9824
9825
9826 /* trim_unixpath()
9827  * Trim Unix-style prefix off filespec, so it looks like what a shell
9828  * glob expansion would return (i.e. from specified prefix on, not
9829  * full path).  Note that returned filespec is Unix-style, regardless
9830  * of whether input filespec was VMS-style or Unix-style.
9831  *
9832  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9833  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9834  * vector of options; at present, only bit 0 is used, and if set tells
9835  * trim unixpath to try the current default directory as a prefix when
9836  * presented with a possibly ambiguous ... wildcard.
9837  *
9838  * Returns !=0 on success, with trimmed filespec replacing contents of
9839  * fspec, and 0 on failure, with contents of fpsec unchanged.
9840  */
9841 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9842 int
9843 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9844 {
9845   char *unixified, *unixwild,
9846        *template, *base, *end, *cp1, *cp2;
9847   register int tmplen, reslen = 0, dirs = 0;
9848
9849   if (!wildspec || !fspec) return 0;
9850
9851   unixwild = PerlMem_malloc(VMS_MAXRSS);
9852   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9853   template = unixwild;
9854   if (strpbrk(wildspec,"]>:") != NULL) {
9855     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9856         PerlMem_free(unixwild);
9857         return 0;
9858     }
9859   }
9860   else {
9861     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9862     unixwild[VMS_MAXRSS-1] = 0;
9863   }
9864   unixified = PerlMem_malloc(VMS_MAXRSS);
9865   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9866   if (strpbrk(fspec,"]>:") != NULL) {
9867     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9868         PerlMem_free(unixwild);
9869         PerlMem_free(unixified);
9870         return 0;
9871     }
9872     else base = unixified;
9873     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9874      * check to see that final result fits into (isn't longer than) fspec */
9875     reslen = strlen(fspec);
9876   }
9877   else base = fspec;
9878
9879   /* No prefix or absolute path on wildcard, so nothing to remove */
9880   if (!*template || *template == '/') {
9881     PerlMem_free(unixwild);
9882     if (base == fspec) {
9883         PerlMem_free(unixified);
9884         return 1;
9885     }
9886     tmplen = strlen(unixified);
9887     if (tmplen > reslen) {
9888         PerlMem_free(unixified);
9889         return 0;  /* not enough space */
9890     }
9891     /* Copy unixified resultant, including trailing NUL */
9892     memmove(fspec,unixified,tmplen+1);
9893     PerlMem_free(unixified);
9894     return 1;
9895   }
9896
9897   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9898   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9899     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9900     for (cp1 = end ;cp1 >= base; cp1--)
9901       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9902         { cp1++; break; }
9903     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9904     PerlMem_free(unixified);
9905     PerlMem_free(unixwild);
9906     return 1;
9907   }
9908   else {
9909     char *tpl, *lcres;
9910     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9911     int ells = 1, totells, segdirs, match;
9912     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9913                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9914
9915     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9916     totells = ells;
9917     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9918     tpl = PerlMem_malloc(VMS_MAXRSS);
9919     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9920     if (ellipsis == template && opts & 1) {
9921       /* Template begins with an ellipsis.  Since we can't tell how many
9922        * directory names at the front of the resultant to keep for an
9923        * arbitrary starting point, we arbitrarily choose the current
9924        * default directory as a starting point.  If it's there as a prefix,
9925        * clip it off.  If not, fall through and act as if the leading
9926        * ellipsis weren't there (i.e. return shortest possible path that
9927        * could match template).
9928        */
9929       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9930           PerlMem_free(tpl);
9931           PerlMem_free(unixified);
9932           PerlMem_free(unixwild);
9933           return 0;
9934       }
9935       if (!decc_efs_case_preserve) {
9936         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9937           if (_tolower(*cp1) != _tolower(*cp2)) break;
9938       }
9939       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9940       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9941       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9942         memmove(fspec,cp2+1,end - cp2);
9943         PerlMem_free(tpl);
9944         PerlMem_free(unixified);
9945         PerlMem_free(unixwild);
9946         return 1;
9947       }
9948     }
9949     /* First off, back up over constant elements at end of path */
9950     if (dirs) {
9951       for (front = end ; front >= base; front--)
9952          if (*front == '/' && !dirs--) { front++; break; }
9953     }
9954     lcres = PerlMem_malloc(VMS_MAXRSS);
9955     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9956     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9957          cp1++,cp2++) {
9958             if (!decc_efs_case_preserve) {
9959                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9960             }
9961             else {
9962                 *cp2 = *cp1;
9963             }
9964     }
9965     if (cp1 != '\0') {
9966         PerlMem_free(tpl);
9967         PerlMem_free(unixified);
9968         PerlMem_free(unixwild);
9969         PerlMem_free(lcres);
9970         return 0;  /* Path too long. */
9971     }
9972     lcend = cp2;
9973     *cp2 = '\0';  /* Pick up with memcpy later */
9974     lcfront = lcres + (front - base);
9975     /* Now skip over each ellipsis and try to match the path in front of it. */
9976     while (ells--) {
9977       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9978         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9979             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9980       if (cp1 < template) break; /* template started with an ellipsis */
9981       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9982         ellipsis = cp1; continue;
9983       }
9984       wilddsc.dsc$a_pointer = tpl;
9985       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9986       nextell = cp1;
9987       for (segdirs = 0, cp2 = tpl;
9988            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9989            cp1++, cp2++) {
9990          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9991          else {
9992             if (!decc_efs_case_preserve) {
9993               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9994             }
9995             else {
9996               *cp2 = *cp1;  /* else preserve case for match */
9997             }
9998          }
9999          if (*cp2 == '/') segdirs++;
10000       }
10001       if (cp1 != ellipsis - 1) {
10002           PerlMem_free(tpl);
10003           PerlMem_free(unixified);
10004           PerlMem_free(unixwild);
10005           PerlMem_free(lcres);
10006           return 0; /* Path too long */
10007       }
10008       /* Back up at least as many dirs as in template before matching */
10009       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
10010         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
10011       for (match = 0; cp1 > lcres;) {
10012         resdsc.dsc$a_pointer = cp1;
10013         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
10014           match++;
10015           if (match == 1) lcfront = cp1;
10016         }
10017         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
10018       }
10019       if (!match) {
10020         PerlMem_free(tpl);
10021         PerlMem_free(unixified);
10022         PerlMem_free(unixwild);
10023         PerlMem_free(lcres);
10024         return 0;  /* Can't find prefix ??? */
10025       }
10026       if (match > 1 && opts & 1) {
10027         /* This ... wildcard could cover more than one set of dirs (i.e.
10028          * a set of similar dir names is repeated).  If the template
10029          * contains more than 1 ..., upstream elements could resolve the
10030          * ambiguity, but it's not worth a full backtracking setup here.
10031          * As a quick heuristic, clip off the current default directory
10032          * if it's present to find the trimmed spec, else use the
10033          * shortest string that this ... could cover.
10034          */
10035         char def[NAM$C_MAXRSS+1], *st;
10036
10037         if (getcwd(def, sizeof def,0) == NULL) {
10038             PerlMem_free(unixified);
10039             PerlMem_free(unixwild);
10040             PerlMem_free(lcres);
10041             PerlMem_free(tpl);
10042             return 0;
10043         }
10044         if (!decc_efs_case_preserve) {
10045           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10046             if (_tolower(*cp1) != _tolower(*cp2)) break;
10047         }
10048         segdirs = dirs - totells;  /* Min # of dirs we must have left */
10049         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10050         if (*cp1 == '\0' && *cp2 == '/') {
10051           memmove(fspec,cp2+1,end - cp2);
10052           PerlMem_free(tpl);
10053           PerlMem_free(unixified);
10054           PerlMem_free(unixwild);
10055           PerlMem_free(lcres);
10056           return 1;
10057         }
10058         /* Nope -- stick with lcfront from above and keep going. */
10059       }
10060     }
10061     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10062     PerlMem_free(tpl);
10063     PerlMem_free(unixified);
10064     PerlMem_free(unixwild);
10065     PerlMem_free(lcres);
10066     return 1;
10067     ellipsis = nextell;
10068   }
10069
10070 }  /* end of trim_unixpath() */
10071 /*}}}*/
10072
10073
10074 /*
10075  *  VMS readdir() routines.
10076  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10077  *
10078  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
10079  *  Minor modifications to original routines.
10080  */
10081
10082 /* readdir may have been redefined by reentr.h, so make sure we get
10083  * the local version for what we do here.
10084  */
10085 #ifdef readdir
10086 # undef readdir
10087 #endif
10088 #if !defined(PERL_IMPLICIT_CONTEXT)
10089 # define readdir Perl_readdir
10090 #else
10091 # define readdir(a) Perl_readdir(aTHX_ a)
10092 #endif
10093
10094     /* Number of elements in vms_versions array */
10095 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
10096
10097 /*
10098  *  Open a directory, return a handle for later use.
10099  */
10100 /*{{{ DIR *opendir(char*name) */
10101 DIR *
10102 Perl_opendir(pTHX_ const char *name)
10103 {
10104     DIR *dd;
10105     char *dir;
10106     Stat_t sb;
10107
10108     Newx(dir, VMS_MAXRSS, char);
10109     if (do_tovmspath(name,dir,0,NULL) == NULL) {
10110       Safefree(dir);
10111       return NULL;
10112     }
10113     /* Check access before stat; otherwise stat does not
10114      * accurately report whether it's a directory.
10115      */
10116     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10117       /* cando_by_name has already set errno */
10118       Safefree(dir);
10119       return NULL;
10120     }
10121     if (flex_stat(dir,&sb) == -1) return NULL;
10122     if (!S_ISDIR(sb.st_mode)) {
10123       Safefree(dir);
10124       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
10125       return NULL;
10126     }
10127     /* Get memory for the handle, and the pattern. */
10128     Newx(dd,1,DIR);
10129     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10130
10131     /* Fill in the fields; mainly playing with the descriptor. */
10132     sprintf(dd->pattern, "%s*.*",dir);
10133     Safefree(dir);
10134     dd->context = 0;
10135     dd->count = 0;
10136     dd->flags = 0;
10137     /* By saying we always want the result of readdir() in unix format, we
10138      * are really saying we want all the escapes removed.  Otherwise the caller,
10139      * having no way to know whether it's already in VMS format, might send it
10140      * through tovmsspec again, thus double escaping.
10141      */
10142     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
10143     dd->pat.dsc$a_pointer = dd->pattern;
10144     dd->pat.dsc$w_length = strlen(dd->pattern);
10145     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10146     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10147 #if defined(USE_ITHREADS)
10148     Newx(dd->mutex,1,perl_mutex);
10149     MUTEX_INIT( (perl_mutex *) dd->mutex );
10150 #else
10151     dd->mutex = NULL;
10152 #endif
10153
10154     return dd;
10155 }  /* end of opendir() */
10156 /*}}}*/
10157
10158 /*
10159  *  Set the flag to indicate we want versions or not.
10160  */
10161 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10162 void
10163 vmsreaddirversions(DIR *dd, int flag)
10164 {
10165     if (flag)
10166         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10167     else
10168         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10169 }
10170 /*}}}*/
10171
10172 /*
10173  *  Free up an opened directory.
10174  */
10175 /*{{{ void closedir(DIR *dd)*/
10176 void
10177 Perl_closedir(DIR *dd)
10178 {
10179     int sts;
10180
10181     sts = lib$find_file_end(&dd->context);
10182     Safefree(dd->pattern);
10183 #if defined(USE_ITHREADS)
10184     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10185     Safefree(dd->mutex);
10186 #endif
10187     Safefree(dd);
10188 }
10189 /*}}}*/
10190
10191 /*
10192  *  Collect all the version numbers for the current file.
10193  */
10194 static void
10195 collectversions(pTHX_ DIR *dd)
10196 {
10197     struct dsc$descriptor_s     pat;
10198     struct dsc$descriptor_s     res;
10199     struct dirent *e;
10200     char *p, *text, *buff;
10201     int i;
10202     unsigned long context, tmpsts;
10203
10204     /* Convenient shorthand. */
10205     e = &dd->entry;
10206
10207     /* Add the version wildcard, ignoring the "*.*" put on before */
10208     i = strlen(dd->pattern);
10209     Newx(text,i + e->d_namlen + 3,char);
10210     strcpy(text, dd->pattern);
10211     sprintf(&text[i - 3], "%s;*", e->d_name);
10212
10213     /* Set up the pattern descriptor. */
10214     pat.dsc$a_pointer = text;
10215     pat.dsc$w_length = i + e->d_namlen - 1;
10216     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10217     pat.dsc$b_class = DSC$K_CLASS_S;
10218
10219     /* Set up result descriptor. */
10220     Newx(buff, VMS_MAXRSS, char);
10221     res.dsc$a_pointer = buff;
10222     res.dsc$w_length = VMS_MAXRSS - 1;
10223     res.dsc$b_dtype = DSC$K_DTYPE_T;
10224     res.dsc$b_class = DSC$K_CLASS_S;
10225
10226     /* Read files, collecting versions. */
10227     for (context = 0, e->vms_verscount = 0;
10228          e->vms_verscount < VERSIZE(e);
10229          e->vms_verscount++) {
10230         unsigned long rsts;
10231         unsigned long flags = 0;
10232
10233 #ifdef VMS_LONGNAME_SUPPORT
10234         flags = LIB$M_FIL_LONG_NAMES;
10235 #endif
10236         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10237         if (tmpsts == RMS$_NMF || context == 0) break;
10238         _ckvmssts(tmpsts);
10239         buff[VMS_MAXRSS - 1] = '\0';
10240         if ((p = strchr(buff, ';')))
10241             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10242         else
10243             e->vms_versions[e->vms_verscount] = -1;
10244     }
10245
10246     _ckvmssts(lib$find_file_end(&context));
10247     Safefree(text);
10248     Safefree(buff);
10249
10250 }  /* end of collectversions() */
10251
10252 /*
10253  *  Read the next entry from the directory.
10254  */
10255 /*{{{ struct dirent *readdir(DIR *dd)*/
10256 struct dirent *
10257 Perl_readdir(pTHX_ DIR *dd)
10258 {
10259     struct dsc$descriptor_s     res;
10260     char *p, *buff;
10261     unsigned long int tmpsts;
10262     unsigned long rsts;
10263     unsigned long flags = 0;
10264     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10265     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10266
10267     /* Set up result descriptor, and get next file. */
10268     Newx(buff, VMS_MAXRSS, char);
10269     res.dsc$a_pointer = buff;
10270     res.dsc$w_length = VMS_MAXRSS - 1;
10271     res.dsc$b_dtype = DSC$K_DTYPE_T;
10272     res.dsc$b_class = DSC$K_CLASS_S;
10273
10274 #ifdef VMS_LONGNAME_SUPPORT
10275     flags = LIB$M_FIL_LONG_NAMES;
10276 #endif
10277
10278     tmpsts = lib$find_file
10279         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10280     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
10281     if (!(tmpsts & 1)) {
10282       set_vaxc_errno(tmpsts);
10283       switch (tmpsts) {
10284         case RMS$_PRV:
10285           set_errno(EACCES); break;
10286         case RMS$_DEV:
10287           set_errno(ENODEV); break;
10288         case RMS$_DIR:
10289           set_errno(ENOTDIR); break;
10290         case RMS$_FNF: case RMS$_DNF:
10291           set_errno(ENOENT); break;
10292         default:
10293           set_errno(EVMSERR);
10294       }
10295       Safefree(buff);
10296       return NULL;
10297     }
10298     dd->count++;
10299     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10300     buff[res.dsc$w_length] = '\0';
10301     p = buff + res.dsc$w_length;
10302     while (--p >= buff) if (!isspace(*p)) break;
10303     *p = '\0';
10304     if (!decc_efs_case_preserve) {
10305       for (p = buff; *p; p++) *p = _tolower(*p);
10306     }
10307
10308     /* Skip any directory component and just copy the name. */
10309     sts = vms_split_path
10310        (buff,
10311         &v_spec,
10312         &v_len,
10313         &r_spec,
10314         &r_len,
10315         &d_spec,
10316         &d_len,
10317         &n_spec,
10318         &n_len,
10319         &e_spec,
10320         &e_len,
10321         &vs_spec,
10322         &vs_len);
10323
10324     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10325
10326         /* In Unix report mode, remove the ".dir;1" from the name */
10327         /* if it is a real directory. */
10328         if (decc_filename_unix_report || decc_efs_charset) {
10329             if ((e_len == 4) && (vs_len == 2) && (vs_spec[1] == '1')) {
10330                 if ((toupper(e_spec[1]) == 'D') &&
10331                     (toupper(e_spec[2]) == 'I') &&
10332                     (toupper(e_spec[3]) == 'R')) {
10333                     Stat_t statbuf;
10334                     int ret_sts;
10335
10336                     ret_sts = stat(buff, (stat_t *)&statbuf);
10337                     if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10338                         e_len = 0;
10339                         e_spec[0] = 0;
10340                     }
10341                 }
10342             }
10343         }
10344
10345         /* Drop NULL extensions on UNIX file specification */
10346         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10347             e_len = 0;
10348             e_spec[0] = '\0';
10349         }
10350     }
10351
10352     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
10353     dd->entry.d_name[n_len + e_len] = '\0';
10354     dd->entry.d_namlen = strlen(dd->entry.d_name);
10355
10356     /* Convert the filename to UNIX format if needed */
10357     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10358
10359         /* Translate the encoded characters. */
10360         /* Fixme: Unicode handling could result in embedded 0 characters */
10361         if (strchr(dd->entry.d_name, '^') != NULL) {
10362             char new_name[256];
10363             char * q;
10364             p = dd->entry.d_name;
10365             q = new_name;
10366             while (*p != 0) {
10367                 int inchars_read, outchars_added;
10368                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10369                 p += inchars_read;
10370                 q += outchars_added;
10371                 /* fix-me */
10372                 /* if outchars_added > 1, then this is a wide file specification */
10373                 /* Wide file specifications need to be passed in Perl */
10374                 /* counted strings apparently with a Unicode flag */
10375             }
10376             *q = 0;
10377             strcpy(dd->entry.d_name, new_name);
10378             dd->entry.d_namlen = strlen(dd->entry.d_name);
10379         }
10380     }
10381
10382     dd->entry.vms_verscount = 0;
10383     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10384     Safefree(buff);
10385     return &dd->entry;
10386
10387 }  /* end of readdir() */
10388 /*}}}*/
10389
10390 /*
10391  *  Read the next entry from the directory -- thread-safe version.
10392  */
10393 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10394 int
10395 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10396 {
10397     int retval;
10398
10399     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10400
10401     entry = readdir(dd);
10402     *result = entry;
10403     retval = ( *result == NULL ? errno : 0 );
10404
10405     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10406
10407     return retval;
10408
10409 }  /* end of readdir_r() */
10410 /*}}}*/
10411
10412 /*
10413  *  Return something that can be used in a seekdir later.
10414  */
10415 /*{{{ long telldir(DIR *dd)*/
10416 long
10417 Perl_telldir(DIR *dd)
10418 {
10419     return dd->count;
10420 }
10421 /*}}}*/
10422
10423 /*
10424  *  Return to a spot where we used to be.  Brute force.
10425  */
10426 /*{{{ void seekdir(DIR *dd,long count)*/
10427 void
10428 Perl_seekdir(pTHX_ DIR *dd, long count)
10429 {
10430     int old_flags;
10431
10432     /* If we haven't done anything yet... */
10433     if (dd->count == 0)
10434         return;
10435
10436     /* Remember some state, and clear it. */
10437     old_flags = dd->flags;
10438     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10439     _ckvmssts(lib$find_file_end(&dd->context));
10440     dd->context = 0;
10441
10442     /* The increment is in readdir(). */
10443     for (dd->count = 0; dd->count < count; )
10444         readdir(dd);
10445
10446     dd->flags = old_flags;
10447
10448 }  /* end of seekdir() */
10449 /*}}}*/
10450
10451 /* VMS subprocess management
10452  *
10453  * my_vfork() - just a vfork(), after setting a flag to record that
10454  * the current script is trying a Unix-style fork/exec.
10455  *
10456  * vms_do_aexec() and vms_do_exec() are called in response to the
10457  * perl 'exec' function.  If this follows a vfork call, then they
10458  * call out the regular perl routines in doio.c which do an
10459  * execvp (for those who really want to try this under VMS).
10460  * Otherwise, they do exactly what the perl docs say exec should
10461  * do - terminate the current script and invoke a new command
10462  * (See below for notes on command syntax.)
10463  *
10464  * do_aspawn() and do_spawn() implement the VMS side of the perl
10465  * 'system' function.
10466  *
10467  * Note on command arguments to perl 'exec' and 'system': When handled
10468  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10469  * are concatenated to form a DCL command string.  If the first non-numeric
10470  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10471  * the command string is handed off to DCL directly.  Otherwise,
10472  * the first token of the command is taken as the filespec of an image
10473  * to run.  The filespec is expanded using a default type of '.EXE' and
10474  * the process defaults for device, directory, etc., and if found, the resultant
10475  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10476  * the command string as parameters.  This is perhaps a bit complicated,
10477  * but I hope it will form a happy medium between what VMS folks expect
10478  * from lib$spawn and what Unix folks expect from exec.
10479  */
10480
10481 static int vfork_called;
10482
10483 /*{{{int my_vfork()*/
10484 int
10485 my_vfork()
10486 {
10487   vfork_called++;
10488   return vfork();
10489 }
10490 /*}}}*/
10491
10492
10493 static void
10494 vms_execfree(struct dsc$descriptor_s *vmscmd)
10495 {
10496   if (vmscmd) {
10497       if (vmscmd->dsc$a_pointer) {
10498           PerlMem_free(vmscmd->dsc$a_pointer);
10499       }
10500       PerlMem_free(vmscmd);
10501   }
10502 }
10503
10504 static char *
10505 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10506 {
10507   char *junk, *tmps = NULL;
10508   register size_t cmdlen = 0;
10509   size_t rlen;
10510   register SV **idx;
10511   STRLEN n_a;
10512
10513   idx = mark;
10514   if (really) {
10515     tmps = SvPV(really,rlen);
10516     if (*tmps) {
10517       cmdlen += rlen + 1;
10518       idx++;
10519     }
10520   }
10521
10522   for (idx++; idx <= sp; idx++) {
10523     if (*idx) {
10524       junk = SvPVx(*idx,rlen);
10525       cmdlen += rlen ? rlen + 1 : 0;
10526     }
10527   }
10528   Newx(PL_Cmd, cmdlen+1, char);
10529
10530   if (tmps && *tmps) {
10531     strcpy(PL_Cmd,tmps);
10532     mark++;
10533   }
10534   else *PL_Cmd = '\0';
10535   while (++mark <= sp) {
10536     if (*mark) {
10537       char *s = SvPVx(*mark,n_a);
10538       if (!*s) continue;
10539       if (*PL_Cmd) strcat(PL_Cmd," ");
10540       strcat(PL_Cmd,s);
10541     }
10542   }
10543   return PL_Cmd;
10544
10545 }  /* end of setup_argstr() */
10546
10547
10548 static unsigned long int
10549 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10550                    struct dsc$descriptor_s **pvmscmd)
10551 {
10552   char * vmsspec;
10553   char * resspec;
10554   char image_name[NAM$C_MAXRSS+1];
10555   char image_argv[NAM$C_MAXRSS+1];
10556   $DESCRIPTOR(defdsc,".EXE");
10557   $DESCRIPTOR(defdsc2,".");
10558   struct dsc$descriptor_s resdsc;
10559   struct dsc$descriptor_s *vmscmd;
10560   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10561   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10562   register char *s, *rest, *cp, *wordbreak;
10563   char * cmd;
10564   int cmdlen;
10565   register int isdcl;
10566
10567   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10568   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10569
10570   /* vmsspec is a DCL command buffer, not just a filename */
10571   vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10572   if (vmsspec == NULL)
10573       _ckvmssts_noperl(SS$_INSFMEM);
10574
10575   resspec = PerlMem_malloc(VMS_MAXRSS);
10576   if (resspec == NULL)
10577       _ckvmssts_noperl(SS$_INSFMEM);
10578
10579   /* Make a copy for modification */
10580   cmdlen = strlen(incmd);
10581   cmd = PerlMem_malloc(cmdlen+1);
10582   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10583   strncpy(cmd, incmd, cmdlen);
10584   cmd[cmdlen] = 0;
10585   image_name[0] = 0;
10586   image_argv[0] = 0;
10587
10588   resdsc.dsc$a_pointer = resspec;
10589   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10590   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10591   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10592
10593   vmscmd->dsc$a_pointer = NULL;
10594   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10595   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10596   vmscmd->dsc$w_length = 0;
10597   if (pvmscmd) *pvmscmd = vmscmd;
10598
10599   if (suggest_quote) *suggest_quote = 0;
10600
10601   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10602     PerlMem_free(cmd);
10603     PerlMem_free(vmsspec);
10604     PerlMem_free(resspec);
10605     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10606   }
10607
10608   s = cmd;
10609
10610   while (*s && isspace(*s)) s++;
10611
10612   if (*s == '@' || *s == '$') {
10613     vmsspec[0] = *s;  rest = s + 1;
10614     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10615   }
10616   else { cp = vmsspec; rest = s; }
10617   if (*rest == '.' || *rest == '/') {
10618     char *cp2;
10619     for (cp2 = resspec;
10620          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10621          rest++, cp2++) *cp2 = *rest;
10622     *cp2 = '\0';
10623     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10624       s = vmsspec;
10625
10626       /* When a UNIX spec with no file type is translated to VMS, */
10627       /* A trailing '.' is appended under ODS-5 rules.            */
10628       /* Here we do not want that trailing "." as it prevents     */
10629       /* Looking for a implied ".exe" type. */
10630       if (decc_efs_charset) {
10631           int i;
10632           i = strlen(vmsspec);
10633           if (vmsspec[i-1] == '.') {
10634               vmsspec[i-1] = '\0';
10635           }
10636       }
10637
10638       if (*rest) {
10639         for (cp2 = vmsspec + strlen(vmsspec);
10640              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10641              rest++, cp2++) *cp2 = *rest;
10642         *cp2 = '\0';
10643       }
10644     }
10645   }
10646   /* Intuit whether verb (first word of cmd) is a DCL command:
10647    *   - if first nonspace char is '@', it's a DCL indirection
10648    * otherwise
10649    *   - if verb contains a filespec separator, it's not a DCL command
10650    *   - if it doesn't, caller tells us whether to default to a DCL
10651    *     command, or to a local image unless told it's DCL (by leading '$')
10652    */
10653   if (*s == '@') {
10654       isdcl = 1;
10655       if (suggest_quote) *suggest_quote = 1;
10656   } else {
10657     register char *filespec = strpbrk(s,":<[.;");
10658     rest = wordbreak = strpbrk(s," \"\t/");
10659     if (!wordbreak) wordbreak = s + strlen(s);
10660     if (*s == '$') check_img = 0;
10661     if (filespec && (filespec < wordbreak)) isdcl = 0;
10662     else isdcl = !check_img;
10663   }
10664
10665   if (!isdcl) {
10666     int rsts;
10667     imgdsc.dsc$a_pointer = s;
10668     imgdsc.dsc$w_length = wordbreak - s;
10669     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10670     if (!(retsts&1)) {
10671         _ckvmssts_noperl(lib$find_file_end(&cxt));
10672         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10673       if (!(retsts & 1) && *s == '$') {
10674         _ckvmssts_noperl(lib$find_file_end(&cxt));
10675         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10676         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10677         if (!(retsts&1)) {
10678           _ckvmssts_noperl(lib$find_file_end(&cxt));
10679           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10680         }
10681       }
10682     }
10683     _ckvmssts_noperl(lib$find_file_end(&cxt));
10684
10685     if (retsts & 1) {
10686       FILE *fp;
10687       s = resspec;
10688       while (*s && !isspace(*s)) s++;
10689       *s = '\0';
10690
10691       /* check that it's really not DCL with no file extension */
10692       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10693       if (fp) {
10694         char b[256] = {0,0,0,0};
10695         read(fileno(fp), b, 256);
10696         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10697         if (isdcl) {
10698           int shebang_len;
10699
10700           /* Check for script */
10701           shebang_len = 0;
10702           if ((b[0] == '#') && (b[1] == '!'))
10703              shebang_len = 2;
10704 #ifdef ALTERNATE_SHEBANG
10705           else {
10706             shebang_len = strlen(ALTERNATE_SHEBANG);
10707             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10708               char * perlstr;
10709                 perlstr = strstr("perl",b);
10710                 if (perlstr == NULL)
10711                   shebang_len = 0;
10712             }
10713             else
10714               shebang_len = 0;
10715           }
10716 #endif
10717
10718           if (shebang_len > 0) {
10719           int i;
10720           int j;
10721           char tmpspec[NAM$C_MAXRSS + 1];
10722
10723             i = shebang_len;
10724              /* Image is following after white space */
10725             /*--------------------------------------*/
10726             while (isprint(b[i]) && isspace(b[i]))
10727                 i++;
10728
10729             j = 0;
10730             while (isprint(b[i]) && !isspace(b[i])) {
10731                 tmpspec[j++] = b[i++];
10732                 if (j >= NAM$C_MAXRSS)
10733                    break;
10734             }
10735             tmpspec[j] = '\0';
10736
10737              /* There may be some default parameters to the image */
10738             /*---------------------------------------------------*/
10739             j = 0;
10740             while (isprint(b[i])) {
10741                 image_argv[j++] = b[i++];
10742                 if (j >= NAM$C_MAXRSS)
10743                    break;
10744             }
10745             while ((j > 0) && !isprint(image_argv[j-1]))
10746                 j--;
10747             image_argv[j] = 0;
10748
10749             /* It will need to be converted to VMS format and validated */
10750             if (tmpspec[0] != '\0') {
10751               char * iname;
10752
10753                /* Try to find the exact program requested to be run */
10754               /*---------------------------------------------------*/
10755               iname = int_rmsexpand
10756                  (tmpspec, image_name, ".exe",
10757                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10758               if (iname != NULL) {
10759                 if (cando_by_name_int
10760                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10761                   /* MCR prefix needed */
10762                   isdcl = 0;
10763                 }
10764                 else {
10765                    /* Try again with a null type */
10766                   /*----------------------------*/
10767                   iname = int_rmsexpand
10768                     (tmpspec, image_name, ".",
10769                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10770                   if (iname != NULL) {
10771                     if (cando_by_name_int
10772                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10773                       /* MCR prefix needed */
10774                       isdcl = 0;
10775                     }
10776                   }
10777                 }
10778
10779                  /* Did we find the image to run the script? */
10780                 /*------------------------------------------*/
10781                 if (isdcl) {
10782                   char *tchr;
10783
10784                    /* Assume DCL or foreign command exists */
10785                   /*--------------------------------------*/
10786                   tchr = strrchr(tmpspec, '/');
10787                   if (tchr != NULL) {
10788                     tchr++;
10789                   }
10790                   else {
10791                     tchr = tmpspec;
10792                   }
10793                   strcpy(image_name, tchr);
10794                 }
10795               }
10796             }
10797           }
10798         }
10799         fclose(fp);
10800       }
10801       if (check_img && isdcl) {
10802           PerlMem_free(cmd);
10803           PerlMem_free(resspec);
10804           PerlMem_free(vmsspec);
10805           return RMS$_FNF;
10806       }
10807
10808       if (cando_by_name(S_IXUSR,0,resspec)) {
10809         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10810         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10811         if (!isdcl) {
10812             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10813             if (image_name[0] != 0) {
10814                 strcat(vmscmd->dsc$a_pointer, image_name);
10815                 strcat(vmscmd->dsc$a_pointer, " ");
10816             }
10817         } else if (image_name[0] != 0) {
10818             strcpy(vmscmd->dsc$a_pointer, image_name);
10819             strcat(vmscmd->dsc$a_pointer, " ");
10820         } else {
10821             strcpy(vmscmd->dsc$a_pointer,"@");
10822         }
10823         if (suggest_quote) *suggest_quote = 1;
10824
10825         /* If there is an image name, use original command */
10826         if (image_name[0] == 0)
10827             strcat(vmscmd->dsc$a_pointer,resspec);
10828         else {
10829             rest = cmd;
10830             while (*rest && isspace(*rest)) rest++;
10831         }
10832
10833         if (image_argv[0] != 0) {
10834           strcat(vmscmd->dsc$a_pointer,image_argv);
10835           strcat(vmscmd->dsc$a_pointer, " ");
10836         }
10837         if (rest) {
10838            int rest_len;
10839            int vmscmd_len;
10840
10841            rest_len = strlen(rest);
10842            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10843            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10844               strcat(vmscmd->dsc$a_pointer,rest);
10845            else
10846              retsts = CLI$_BUFOVF;
10847         }
10848         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10849         PerlMem_free(cmd);
10850         PerlMem_free(vmsspec);
10851         PerlMem_free(resspec);
10852         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10853       }
10854       else
10855         retsts = RMS$_PRV;
10856     }
10857   }
10858   /* It's either a DCL command or we couldn't find a suitable image */
10859   vmscmd->dsc$w_length = strlen(cmd);
10860
10861   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10862   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10863   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10864
10865   PerlMem_free(cmd);
10866   PerlMem_free(resspec);
10867   PerlMem_free(vmsspec);
10868
10869   /* check if it's a symbol (for quoting purposes) */
10870   if (suggest_quote && !*suggest_quote) {
10871     int iss;
10872     char equiv[LNM$C_NAMLENGTH];
10873     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10874     eqvdsc.dsc$a_pointer = equiv;
10875
10876     iss = lib$get_symbol(vmscmd,&eqvdsc);
10877     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10878   }
10879   if (!(retsts & 1)) {
10880     /* just hand off status values likely to be due to user error */
10881     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10882         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10883        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10884     else { _ckvmssts_noperl(retsts); }
10885   }
10886
10887   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10888
10889 }  /* end of setup_cmddsc() */
10890
10891
10892 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10893 bool
10894 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10895 {
10896 bool exec_sts;
10897 char * cmd;
10898
10899   if (sp > mark) {
10900     if (vfork_called) {           /* this follows a vfork - act Unixish */
10901       vfork_called--;
10902       if (vfork_called < 0) {
10903         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10904         vfork_called = 0;
10905       }
10906       else return do_aexec(really,mark,sp);
10907     }
10908                                            /* no vfork - act VMSish */
10909     cmd = setup_argstr(aTHX_ really,mark,sp);
10910     exec_sts = vms_do_exec(cmd);
10911     Safefree(cmd);  /* Clean up from setup_argstr() */
10912     return exec_sts;
10913   }
10914
10915   return FALSE;
10916 }  /* end of vms_do_aexec() */
10917 /*}}}*/
10918
10919 /* {{{bool vms_do_exec(char *cmd) */
10920 bool
10921 Perl_vms_do_exec(pTHX_ const char *cmd)
10922 {
10923   struct dsc$descriptor_s *vmscmd;
10924
10925   if (vfork_called) {             /* this follows a vfork - act Unixish */
10926     vfork_called--;
10927     if (vfork_called < 0) {
10928       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10929       vfork_called = 0;
10930     }
10931     else return do_exec(cmd);
10932   }
10933
10934   {                               /* no vfork - act VMSish */
10935     unsigned long int retsts;
10936
10937     TAINT_ENV();
10938     TAINT_PROPER("exec");
10939     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10940       retsts = lib$do_command(vmscmd);
10941
10942     switch (retsts) {
10943       case RMS$_FNF: case RMS$_DNF:
10944         set_errno(ENOENT); break;
10945       case RMS$_DIR:
10946         set_errno(ENOTDIR); break;
10947       case RMS$_DEV:
10948         set_errno(ENODEV); break;
10949       case RMS$_PRV:
10950         set_errno(EACCES); break;
10951       case RMS$_SYN:
10952         set_errno(EINVAL); break;
10953       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10954         set_errno(E2BIG); break;
10955       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10956         _ckvmssts_noperl(retsts); /* fall through */
10957       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10958         set_errno(EVMSERR);
10959     }
10960     set_vaxc_errno(retsts);
10961     if (ckWARN(WARN_EXEC)) {
10962       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10963              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10964     }
10965     vms_execfree(vmscmd);
10966   }
10967
10968   return FALSE;
10969
10970 }  /* end of vms_do_exec() */
10971 /*}}}*/
10972
10973 int do_spawn2(pTHX_ const char *, int);
10974
10975 int
10976 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10977 {
10978 unsigned long int sts;
10979 char * cmd;
10980 int flags = 0;
10981
10982   if (sp > mark) {
10983
10984     /* We'll copy the (undocumented?) Win32 behavior and allow a
10985      * numeric first argument.  But the only value we'll support
10986      * through do_aspawn is a value of 1, which means spawn without
10987      * waiting for completion -- other values are ignored.
10988      */
10989     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10990         ++mark;
10991         flags = SvIVx(*mark);
10992     }
10993
10994     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10995         flags = CLI$M_NOWAIT;
10996     else
10997         flags = 0;
10998
10999     cmd = setup_argstr(aTHX_ really, mark, sp);
11000     sts = do_spawn2(aTHX_ cmd, flags);
11001     /* pp_sys will clean up cmd */
11002     return sts;
11003   }
11004   return SS$_ABORT;
11005 }  /* end of do_aspawn() */
11006 /*}}}*/
11007
11008
11009 /* {{{int do_spawn(char* cmd) */
11010 int
11011 Perl_do_spawn(pTHX_ char* cmd)
11012 {
11013     PERL_ARGS_ASSERT_DO_SPAWN;
11014
11015     return do_spawn2(aTHX_ cmd, 0);
11016 }
11017 /*}}}*/
11018
11019 /* {{{int do_spawn_nowait(char* cmd) */
11020 int
11021 Perl_do_spawn_nowait(pTHX_ char* cmd)
11022 {
11023     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11024
11025     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11026 }
11027 /*}}}*/
11028
11029 /* {{{int do_spawn2(char *cmd) */
11030 int
11031 do_spawn2(pTHX_ const char *cmd, int flags)
11032 {
11033   unsigned long int sts, substs;
11034
11035   /* The caller of this routine expects to Safefree(PL_Cmd) */
11036   Newx(PL_Cmd,10,char);
11037
11038   TAINT_ENV();
11039   TAINT_PROPER("spawn");
11040   if (!cmd || !*cmd) {
11041     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11042     if (!(sts & 1)) {
11043       switch (sts) {
11044         case RMS$_FNF:  case RMS$_DNF:
11045           set_errno(ENOENT); break;
11046         case RMS$_DIR:
11047           set_errno(ENOTDIR); break;
11048         case RMS$_DEV:
11049           set_errno(ENODEV); break;
11050         case RMS$_PRV:
11051           set_errno(EACCES); break;
11052         case RMS$_SYN:
11053           set_errno(EINVAL); break;
11054         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11055           set_errno(E2BIG); break;
11056         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11057           _ckvmssts_noperl(sts); /* fall through */
11058         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11059           set_errno(EVMSERR);
11060       }
11061       set_vaxc_errno(sts);
11062       if (ckWARN(WARN_EXEC)) {
11063         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11064                     Strerror(errno));
11065       }
11066     }
11067     sts = substs;
11068   }
11069   else {
11070     char mode[3];
11071     PerlIO * fp;
11072     if (flags & CLI$M_NOWAIT)
11073         strcpy(mode, "n");
11074     else
11075         strcpy(mode, "nW");
11076
11077     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11078     if (fp != NULL)
11079       my_pclose(fp);
11080     /* sts will be the pid in the nowait case */
11081   }
11082   return sts;
11083 }  /* end of do_spawn2() */
11084 /*}}}*/
11085
11086
11087 static unsigned int *sockflags, sockflagsize;
11088
11089 /*
11090  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11091  * routines found in some versions of the CRTL can't deal with sockets.
11092  * We don't shim the other file open routines since a socket isn't
11093  * likely to be opened by a name.
11094  */
11095 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11096 FILE *my_fdopen(int fd, const char *mode)
11097 {
11098   FILE *fp = fdopen(fd, mode);
11099
11100   if (fp) {
11101     unsigned int fdoff = fd / sizeof(unsigned int);
11102     Stat_t sbuf; /* native stat; we don't need flex_stat */
11103     if (!sockflagsize || fdoff > sockflagsize) {
11104       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11105       else           Newx  (sockflags,fdoff+2,unsigned int);
11106       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11107       sockflagsize = fdoff + 2;
11108     }
11109     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
11110       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11111   }
11112   return fp;
11113
11114 }
11115 /*}}}*/
11116
11117
11118 /*
11119  * Clear the corresponding bit when the (possibly) socket stream is closed.
11120  * There still a small hole: we miss an implicit close which might occur
11121  * via freopen().  >> Todo
11122  */
11123 /*{{{ int my_fclose(FILE *fp)*/
11124 int my_fclose(FILE *fp) {
11125   if (fp) {
11126     unsigned int fd = fileno(fp);
11127     unsigned int fdoff = fd / sizeof(unsigned int);
11128
11129     if (sockflagsize && fdoff < sockflagsize)
11130       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11131   }
11132   return fclose(fp);
11133 }
11134 /*}}}*/
11135
11136
11137 /*
11138  * A simple fwrite replacement which outputs itmsz*nitm chars without
11139  * introducing record boundaries every itmsz chars.
11140  * We are using fputs, which depends on a terminating null.  We may
11141  * well be writing binary data, so we need to accommodate not only
11142  * data with nulls sprinkled in the middle but also data with no null
11143  * byte at the end.
11144  */
11145 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11146 int
11147 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11148 {
11149   register char *cp, *end, *cpd, *data;
11150   register unsigned int fd = fileno(dest);
11151   register unsigned int fdoff = fd / sizeof(unsigned int);
11152   int retval;
11153   int bufsize = itmsz * nitm + 1;
11154
11155   if (fdoff < sockflagsize &&
11156       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11157     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11158     return nitm;
11159   }
11160
11161   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11162   memcpy( data, src, itmsz*nitm );
11163   data[itmsz*nitm] = '\0';
11164
11165   end = data + itmsz * nitm;
11166   retval = (int) nitm; /* on success return # items written */
11167
11168   cpd = data;
11169   while (cpd <= end) {
11170     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11171     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11172     if (cp < end)
11173       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11174     cpd = cp + 1;
11175   }
11176
11177   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11178   return retval;
11179
11180 }  /* end of my_fwrite() */
11181 /*}}}*/
11182
11183 /*{{{ int my_flush(FILE *fp)*/
11184 int
11185 Perl_my_flush(pTHX_ FILE *fp)
11186 {
11187     int res;
11188     if ((res = fflush(fp)) == 0 && fp) {
11189 #ifdef VMS_DO_SOCKETS
11190         Stat_t s;
11191         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11192 #endif
11193             res = fsync(fileno(fp));
11194     }
11195 /*
11196  * If the flush succeeded but set end-of-file, we need to clear
11197  * the error because our caller may check ferror().  BTW, this
11198  * probably means we just flushed an empty file.
11199  */
11200     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11201
11202     return res;
11203 }
11204 /*}}}*/
11205
11206 /*
11207  * Here are replacements for the following Unix routines in the VMS environment:
11208  *      getpwuid    Get information for a particular UIC or UID
11209  *      getpwnam    Get information for a named user
11210  *      getpwent    Get information for each user in the rights database
11211  *      setpwent    Reset search to the start of the rights database
11212  *      endpwent    Finish searching for users in the rights database
11213  *
11214  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11215  * (defined in pwd.h), which contains the following fields:-
11216  *      struct passwd {
11217  *              char        *pw_name;    Username (in lower case)
11218  *              char        *pw_passwd;  Hashed password
11219  *              unsigned int pw_uid;     UIC
11220  *              unsigned int pw_gid;     UIC group  number
11221  *              char        *pw_unixdir; Default device/directory (VMS-style)
11222  *              char        *pw_gecos;   Owner name
11223  *              char        *pw_dir;     Default device/directory (Unix-style)
11224  *              char        *pw_shell;   Default CLI name (eg. DCL)
11225  *      };
11226  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11227  *
11228  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11229  * not the UIC member number (eg. what's returned by getuid()),
11230  * getpwuid() can accept either as input (if uid is specified, the caller's
11231  * UIC group is used), though it won't recognise gid=0.
11232  *
11233  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11234  * information about other users in your group or in other groups, respectively.
11235  * If the required privilege is not available, then these routines fill only
11236  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11237  * string).
11238  *
11239  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11240  */
11241
11242 /* sizes of various UAF record fields */
11243 #define UAI$S_USERNAME 12
11244 #define UAI$S_IDENT    31
11245 #define UAI$S_OWNER    31
11246 #define UAI$S_DEFDEV   31
11247 #define UAI$S_DEFDIR   63
11248 #define UAI$S_DEFCLI   31
11249 #define UAI$S_PWD       8
11250
11251 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11252                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11253                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11254
11255 static char __empty[]= "";
11256 static struct passwd __passwd_empty=
11257     {(char *) __empty, (char *) __empty, 0, 0,
11258      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11259 static int contxt= 0;
11260 static struct passwd __pwdcache;
11261 static char __pw_namecache[UAI$S_IDENT+1];
11262
11263 /*
11264  * This routine does most of the work extracting the user information.
11265  */
11266 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11267 {
11268     static struct {
11269         unsigned char length;
11270         char pw_gecos[UAI$S_OWNER+1];
11271     } owner;
11272     static union uicdef uic;
11273     static struct {
11274         unsigned char length;
11275         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11276     } defdev;
11277     static struct {
11278         unsigned char length;
11279         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11280     } defdir;
11281     static struct {
11282         unsigned char length;
11283         char pw_shell[UAI$S_DEFCLI+1];
11284     } defcli;
11285     static char pw_passwd[UAI$S_PWD+1];
11286
11287     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11288     struct dsc$descriptor_s name_desc;
11289     unsigned long int sts;
11290
11291     static struct itmlst_3 itmlst[]= {
11292         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11293         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11294         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11295         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11296         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11297         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11298         {0,                0,           NULL,    NULL}};
11299
11300     name_desc.dsc$w_length=  strlen(name);
11301     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11302     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11303     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11304
11305 /*  Note that sys$getuai returns many fields as counted strings. */
11306     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11307     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11308       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11309     }
11310     else { _ckvmssts(sts); }
11311     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11312
11313     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11314     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11315     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11316     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11317     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11318     owner.pw_gecos[lowner]=            '\0';
11319     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11320     defcli.pw_shell[ldefcli]=          '\0';
11321     if (valid_uic(uic)) {
11322         pwd->pw_uid= uic.uic$l_uic;
11323         pwd->pw_gid= uic.uic$v_group;
11324     }
11325     else
11326       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11327     pwd->pw_passwd=  pw_passwd;
11328     pwd->pw_gecos=   owner.pw_gecos;
11329     pwd->pw_dir=     defdev.pw_dir;
11330     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11331     pwd->pw_shell=   defcli.pw_shell;
11332     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11333         int ldir;
11334         ldir= strlen(pwd->pw_unixdir) - 1;
11335         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11336     }
11337     else
11338         strcpy(pwd->pw_unixdir, pwd->pw_dir);
11339     if (!decc_efs_case_preserve)
11340         __mystrtolower(pwd->pw_unixdir);
11341     return 1;
11342 }
11343
11344 /*
11345  * Get information for a named user.
11346 */
11347 /*{{{struct passwd *getpwnam(char *name)*/
11348 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11349 {
11350     struct dsc$descriptor_s name_desc;
11351     union uicdef uic;
11352     unsigned long int status, sts;
11353
11354     __pwdcache = __passwd_empty;
11355     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11356       /* We still may be able to determine pw_uid and pw_gid */
11357       name_desc.dsc$w_length=  strlen(name);
11358       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11359       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11360       name_desc.dsc$a_pointer= (char *) name;
11361       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11362         __pwdcache.pw_uid= uic.uic$l_uic;
11363         __pwdcache.pw_gid= uic.uic$v_group;
11364       }
11365       else {
11366         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11367           set_vaxc_errno(sts);
11368           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11369           return NULL;
11370         }
11371         else { _ckvmssts(sts); }
11372       }
11373     }
11374     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
11375     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
11376     __pwdcache.pw_name= __pw_namecache;
11377     return &__pwdcache;
11378 }  /* end of my_getpwnam() */
11379 /*}}}*/
11380
11381 /*
11382  * Get information for a particular UIC or UID.
11383  * Called by my_getpwent with uid=-1 to list all users.
11384 */
11385 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11386 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11387 {
11388     const $DESCRIPTOR(name_desc,__pw_namecache);
11389     unsigned short lname;
11390     union uicdef uic;
11391     unsigned long int status;
11392
11393     if (uid == (unsigned int) -1) {
11394       do {
11395         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11396         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11397           set_vaxc_errno(status);
11398           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11399           my_endpwent();
11400           return NULL;
11401         }
11402         else { _ckvmssts(status); }
11403       } while (!valid_uic (uic));
11404     }
11405     else {
11406       uic.uic$l_uic= uid;
11407       if (!uic.uic$v_group)
11408         uic.uic$v_group= PerlProc_getgid();
11409       if (valid_uic(uic))
11410         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11411       else status = SS$_IVIDENT;
11412       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11413           status == RMS$_PRV) {
11414         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11415         return NULL;
11416       }
11417       else { _ckvmssts(status); }
11418     }
11419     __pw_namecache[lname]= '\0';
11420     __mystrtolower(__pw_namecache);
11421
11422     __pwdcache = __passwd_empty;
11423     __pwdcache.pw_name = __pw_namecache;
11424
11425 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11426     The identifier's value is usually the UIC, but it doesn't have to be,
11427     so if we can, we let fillpasswd update this. */
11428     __pwdcache.pw_uid =  uic.uic$l_uic;
11429     __pwdcache.pw_gid =  uic.uic$v_group;
11430
11431     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11432     return &__pwdcache;
11433
11434 }  /* end of my_getpwuid() */
11435 /*}}}*/
11436
11437 /*
11438  * Get information for next user.
11439 */
11440 /*{{{struct passwd *my_getpwent()*/
11441 struct passwd *Perl_my_getpwent(pTHX)
11442 {
11443     return (my_getpwuid((unsigned int) -1));
11444 }
11445 /*}}}*/
11446
11447 /*
11448  * Finish searching rights database for users.
11449 */
11450 /*{{{void my_endpwent()*/
11451 void Perl_my_endpwent(pTHX)
11452 {
11453     if (contxt) {
11454       _ckvmssts(sys$finish_rdb(&contxt));
11455       contxt= 0;
11456     }
11457 }
11458 /*}}}*/
11459
11460 #ifdef HOMEGROWN_POSIX_SIGNALS
11461   /* Signal handling routines, pulled into the core from POSIX.xs.
11462    *
11463    * We need these for threads, so they've been rolled into the core,
11464    * rather than left in POSIX.xs.
11465    *
11466    * (DRS, Oct 23, 1997)
11467    */
11468
11469   /* sigset_t is atomic under VMS, so these routines are easy */
11470 /*{{{int my_sigemptyset(sigset_t *) */
11471 int my_sigemptyset(sigset_t *set) {
11472     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11473     *set = 0; return 0;
11474 }
11475 /*}}}*/
11476
11477
11478 /*{{{int my_sigfillset(sigset_t *)*/
11479 int my_sigfillset(sigset_t *set) {
11480     int i;
11481     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11482     for (i = 0; i < NSIG; i++) *set |= (1 << i);
11483     return 0;
11484 }
11485 /*}}}*/
11486
11487
11488 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
11489 int my_sigaddset(sigset_t *set, int sig) {
11490     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11491     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11492     *set |= (1 << (sig - 1));
11493     return 0;
11494 }
11495 /*}}}*/
11496
11497
11498 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
11499 int my_sigdelset(sigset_t *set, int sig) {
11500     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11501     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11502     *set &= ~(1 << (sig - 1));
11503     return 0;
11504 }
11505 /*}}}*/
11506
11507
11508 /*{{{int my_sigismember(sigset_t *set, int sig)*/
11509 int my_sigismember(sigset_t *set, int sig) {
11510     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11511     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11512     return *set & (1 << (sig - 1));
11513 }
11514 /*}}}*/
11515
11516
11517 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
11518 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
11519     sigset_t tempmask;
11520
11521     /* If set and oset are both null, then things are badly wrong. Bail out. */
11522     if ((oset == NULL) && (set == NULL)) {
11523       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
11524       return -1;
11525     }
11526
11527     /* If set's null, then we're just handling a fetch. */
11528     if (set == NULL) {
11529         tempmask = sigblock(0);
11530     }
11531     else {
11532       switch (how) {
11533       case SIG_SETMASK:
11534         tempmask = sigsetmask(*set);
11535         break;
11536       case SIG_BLOCK:
11537         tempmask = sigblock(*set);
11538         break;
11539       case SIG_UNBLOCK:
11540         tempmask = sigblock(0);
11541         sigsetmask(*oset & ~tempmask);
11542         break;
11543       default:
11544         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11545         return -1;
11546       }
11547     }
11548
11549     /* Did they pass us an oset? If so, stick our holding mask into it */
11550     if (oset)
11551       *oset = tempmask;
11552
11553     return 0;
11554 }
11555 /*}}}*/
11556 #endif  /* HOMEGROWN_POSIX_SIGNALS */
11557
11558
11559 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11560  * my_utime(), and flex_stat(), all of which operate on UTC unless
11561  * VMSISH_TIMES is true.
11562  */
11563 /* method used to handle UTC conversions:
11564  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11565  */
11566 static int gmtime_emulation_type;
11567 /* number of secs to add to UTC POSIX-style time to get local time */
11568 static long int utc_offset_secs;
11569
11570 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11571  * in vmsish.h.  #undef them here so we can call the CRTL routines
11572  * directly.
11573  */
11574 #undef gmtime
11575 #undef localtime
11576 #undef time
11577
11578
11579 /*
11580  * DEC C previous to 6.0 corrupts the behavior of the /prefix
11581  * qualifier with the extern prefix pragma.  This provisional
11582  * hack circumvents this prefix pragma problem in previous
11583  * precompilers.
11584  */
11585 #if defined(__VMS_VER) && __VMS_VER >= 70000000
11586 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11587 #    pragma __extern_prefix save
11588 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
11589 #    define gmtime decc$__utctz_gmtime
11590 #    define localtime decc$__utctz_localtime
11591 #    define time decc$__utc_time
11592 #    pragma __extern_prefix restore
11593
11594      struct tm *gmtime(), *localtime();
11595
11596 #  endif
11597 #endif
11598
11599
11600 static time_t toutc_dst(time_t loc) {
11601   struct tm *rsltmp;
11602
11603   if ((rsltmp = localtime(&loc)) == NULL) return -1;
11604   loc -= utc_offset_secs;
11605   if (rsltmp->tm_isdst) loc -= 3600;
11606   return loc;
11607 }
11608 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11609        ((gmtime_emulation_type || my_time(NULL)), \
11610        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11611        ((secs) - utc_offset_secs))))
11612
11613 static time_t toloc_dst(time_t utc) {
11614   struct tm *rsltmp;
11615
11616   utc += utc_offset_secs;
11617   if ((rsltmp = localtime(&utc)) == NULL) return -1;
11618   if (rsltmp->tm_isdst) utc += 3600;
11619   return utc;
11620 }
11621 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11622        ((gmtime_emulation_type || my_time(NULL)), \
11623        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11624        ((secs) + utc_offset_secs))))
11625
11626 #ifndef RTL_USES_UTC
11627 /*
11628
11629     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
11630         DST starts on 1st sun of april      at 02:00  std time
11631             ends on last sun of october     at 02:00  dst time
11632     see the UCX management command reference, SET CONFIG TIMEZONE
11633     for formatting info.
11634
11635     No, it's not as general as it should be, but then again, NOTHING
11636     will handle UK times in a sensible way.
11637 */
11638
11639
11640 /*
11641     parse the DST start/end info:
11642     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11643 */
11644
11645 static char *
11646 tz_parse_startend(char *s, struct tm *w, int *past)
11647 {
11648     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11649     int ly, dozjd, d, m, n, hour, min, sec, j, k;
11650     time_t g;
11651
11652     if (!s)    return 0;
11653     if (!w) return 0;
11654     if (!past) return 0;
11655
11656     ly = 0;
11657     if (w->tm_year % 4        == 0) ly = 1;
11658     if (w->tm_year % 100      == 0) ly = 0;
11659     if (w->tm_year+1900 % 400 == 0) ly = 1;
11660     if (ly) dinm[1]++;
11661
11662     dozjd = isdigit(*s);
11663     if (*s == 'J' || *s == 'j' || dozjd) {
11664         if (!dozjd && !isdigit(*++s)) return 0;
11665         d = *s++ - '0';
11666         if (isdigit(*s)) {
11667             d = d*10 + *s++ - '0';
11668             if (isdigit(*s)) {
11669                 d = d*10 + *s++ - '0';
11670             }
11671         }
11672         if (d == 0) return 0;
11673         if (d > 366) return 0;
11674         d--;
11675         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
11676         g = d * 86400;
11677         dozjd = 1;
11678     } else if (*s == 'M' || *s == 'm') {
11679         if (!isdigit(*++s)) return 0;
11680         m = *s++ - '0';
11681         if (isdigit(*s)) m = 10*m + *s++ - '0';
11682         if (*s != '.') return 0;
11683         if (!isdigit(*++s)) return 0;
11684         n = *s++ - '0';
11685         if (n < 1 || n > 5) return 0;
11686         if (*s != '.') return 0;
11687         if (!isdigit(*++s)) return 0;
11688         d = *s++ - '0';
11689         if (d > 6) return 0;
11690     }
11691
11692     if (*s == '/') {
11693         if (!isdigit(*++s)) return 0;
11694         hour = *s++ - '0';
11695         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11696         if (*s == ':') {
11697             if (!isdigit(*++s)) return 0;
11698             min = *s++ - '0';
11699             if (isdigit(*s)) min = 10*min + *s++ - '0';
11700             if (*s == ':') {
11701                 if (!isdigit(*++s)) return 0;
11702                 sec = *s++ - '0';
11703                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11704             }
11705         }
11706     } else {
11707         hour = 2;
11708         min = 0;
11709         sec = 0;
11710     }
11711
11712     if (dozjd) {
11713         if (w->tm_yday < d) goto before;
11714         if (w->tm_yday > d) goto after;
11715     } else {
11716         if (w->tm_mon+1 < m) goto before;
11717         if (w->tm_mon+1 > m) goto after;
11718
11719         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
11720         k = d - j; /* mday of first d */
11721         if (k <= 0) k += 7;
11722         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
11723         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11724         if (w->tm_mday < k) goto before;
11725         if (w->tm_mday > k) goto after;
11726     }
11727
11728     if (w->tm_hour < hour) goto before;
11729     if (w->tm_hour > hour) goto after;
11730     if (w->tm_min  < min)  goto before;
11731     if (w->tm_min  > min)  goto after;
11732     if (w->tm_sec  < sec)  goto before;
11733     goto after;
11734
11735 before:
11736     *past = 0;
11737     return s;
11738 after:
11739     *past = 1;
11740     return s;
11741 }
11742
11743
11744
11745
11746 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
11747
11748 static char *
11749 tz_parse_offset(char *s, int *offset)
11750 {
11751     int hour = 0, min = 0, sec = 0;
11752     int neg = 0;
11753     if (!s) return 0;
11754     if (!offset) return 0;
11755
11756     if (*s == '-') {neg++; s++;}
11757     if (*s == '+') s++;
11758     if (!isdigit(*s)) return 0;
11759     hour = *s++ - '0';
11760     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11761     if (hour > 24) return 0;
11762     if (*s == ':') {
11763         if (!isdigit(*++s)) return 0;
11764         min = *s++ - '0';
11765         if (isdigit(*s)) min = min*10 + (*s++ - '0');
11766         if (min > 59) return 0;
11767         if (*s == ':') {
11768             if (!isdigit(*++s)) return 0;
11769             sec = *s++ - '0';
11770             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11771             if (sec > 59) return 0;
11772         }
11773     }
11774
11775     *offset = (hour*60+min)*60 + sec;
11776     if (neg) *offset = -*offset;
11777     return s;
11778 }
11779
11780 /*
11781     input time is w, whatever type of time the CRTL localtime() uses.
11782     sets dst, the zone, and the gmtoff (seconds)
11783
11784     caches the value of TZ and UCX$TZ env variables; note that
11785     my_setenv looks for these and sets a flag if they're changed
11786     for efficiency.
11787
11788     We have to watch out for the "australian" case (dst starts in
11789     october, ends in april)...flagged by "reverse" and checked by
11790     scanning through the months of the previous year.
11791
11792 */
11793
11794 static int
11795 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11796 {
11797     time_t when;
11798     struct tm *w2;
11799     char *s,*s2;
11800     char *dstzone, *tz, *s_start, *s_end;
11801     int std_off, dst_off, isdst;
11802     int y, dststart, dstend;
11803     static char envtz[1025];  /* longer than any logical, symbol, ... */
11804     static char ucxtz[1025];
11805     static char reversed = 0;
11806
11807     if (!w) return 0;
11808
11809     if (tz_updated) {
11810         tz_updated = 0;
11811         reversed = -1;  /* flag need to check  */
11812         envtz[0] = ucxtz[0] = '\0';
11813         tz = my_getenv("TZ",0);
11814         if (tz) strcpy(envtz, tz);
11815         tz = my_getenv("UCX$TZ",0);
11816         if (tz) strcpy(ucxtz, tz);
11817         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
11818     }
11819     tz = envtz;
11820     if (!*tz) tz = ucxtz;
11821
11822     s = tz;
11823     while (isalpha(*s)) s++;
11824     s = tz_parse_offset(s, &std_off);
11825     if (!s) return 0;
11826     if (!*s) {                  /* no DST, hurray we're done! */
11827         isdst = 0;
11828         goto done;
11829     }
11830
11831     dstzone = s;
11832     while (isalpha(*s)) s++;
11833     s2 = tz_parse_offset(s, &dst_off);
11834     if (s2) {
11835         s = s2;
11836     } else {
11837         dst_off = std_off - 3600;
11838     }
11839
11840     if (!*s) {      /* default dst start/end?? */
11841         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
11842             s = strchr(ucxtz,',');
11843         }
11844         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
11845     }
11846     if (*s != ',') return 0;
11847
11848     when = *w;
11849     when = _toutc(when);      /* convert to utc */
11850     when = when - std_off;    /* convert to pseudolocal time*/
11851
11852     w2 = localtime(&when);
11853     y = w2->tm_year;
11854     s_start = s+1;
11855     s = tz_parse_startend(s_start,w2,&dststart);
11856     if (!s) return 0;
11857     if (*s != ',') return 0;
11858
11859     when = *w;
11860     when = _toutc(when);      /* convert to utc */
11861     when = when - dst_off;    /* convert to pseudolocal time*/
11862     w2 = localtime(&when);
11863     if (w2->tm_year != y) {   /* spans a year, just check one time */
11864         when += dst_off - std_off;
11865         w2 = localtime(&when);
11866     }
11867     s_end = s+1;
11868     s = tz_parse_startend(s_end,w2,&dstend);
11869     if (!s) return 0;
11870
11871     if (reversed == -1) {  /* need to check if start later than end */
11872         int j, ds, de;
11873
11874         when = *w;
11875         if (when < 2*365*86400) {
11876             when += 2*365*86400;
11877         } else {
11878             when -= 365*86400;
11879         }
11880         w2 =localtime(&when);
11881         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
11882
11883         for (j = 0; j < 12; j++) {
11884             w2 =localtime(&when);
11885             tz_parse_startend(s_start,w2,&ds);
11886             tz_parse_startend(s_end,w2,&de);
11887             if (ds != de) break;
11888             when += 30*86400;
11889         }
11890         reversed = 0;
11891         if (de && !ds) reversed = 1;
11892     }
11893
11894     isdst = dststart && !dstend;
11895     if (reversed) isdst = dststart  || !dstend;
11896
11897 done:
11898     if (dst)    *dst = isdst;
11899     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11900     if (isdst)  tz = dstzone;
11901     if (zone) {
11902         while(isalpha(*tz))  *zone++ = *tz++;
11903         *zone = '\0';
11904     }
11905     return 1;
11906 }
11907
11908 #endif /* !RTL_USES_UTC */
11909
11910 /* my_time(), my_localtime(), my_gmtime()
11911  * By default traffic in UTC time values, using CRTL gmtime() or
11912  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11913  * Note: We need to use these functions even when the CRTL has working
11914  * UTC support, since they also handle C<use vmsish qw(times);>
11915  *
11916  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11917  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11918  */
11919
11920 /*{{{time_t my_time(time_t *timep)*/
11921 time_t Perl_my_time(pTHX_ time_t *timep)
11922 {
11923   time_t when;
11924   struct tm *tm_p;
11925
11926   if (gmtime_emulation_type == 0) {
11927     int dstnow;
11928     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11929                               /* results of calls to gmtime() and localtime() */
11930                               /* for same &base */
11931
11932     gmtime_emulation_type++;
11933     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11934       char off[LNM$C_NAMLENGTH+1];;
11935
11936       gmtime_emulation_type++;
11937       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11938         gmtime_emulation_type++;
11939         utc_offset_secs = 0;
11940         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11941       }
11942       else { utc_offset_secs = atol(off); }
11943     }
11944     else { /* We've got a working gmtime() */
11945       struct tm gmt, local;
11946
11947       gmt = *tm_p;
11948       tm_p = localtime(&base);
11949       local = *tm_p;
11950       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11951       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11952       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11953       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11954     }
11955   }
11956
11957   when = time(NULL);
11958 # ifdef VMSISH_TIME
11959 # ifdef RTL_USES_UTC
11960   if (VMSISH_TIME) when = _toloc(when);
11961 # else
11962   if (!VMSISH_TIME) when = _toutc(when);
11963 # endif
11964 # endif
11965   if (timep != NULL) *timep = when;
11966   return when;
11967
11968 }  /* end of my_time() */
11969 /*}}}*/
11970
11971
11972 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11973 struct tm *
11974 Perl_my_gmtime(pTHX_ const time_t *timep)
11975 {
11976   char *p;
11977   time_t when;
11978   struct tm *rsltmp;
11979
11980   if (timep == NULL) {
11981     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11982     return NULL;
11983   }
11984   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11985
11986   when = *timep;
11987 # ifdef VMSISH_TIME
11988   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11989 #  endif
11990 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
11991   return gmtime(&when);
11992 # else
11993   /* CRTL localtime() wants local time as input, so does no tz correction */
11994   rsltmp = localtime(&when);
11995   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
11996   return rsltmp;
11997 #endif
11998 }  /* end of my_gmtime() */
11999 /*}}}*/
12000
12001
12002 /*{{{struct tm *my_localtime(const time_t *timep)*/
12003 struct tm *
12004 Perl_my_localtime(pTHX_ const time_t *timep)
12005 {
12006   time_t when, whenutc;
12007   struct tm *rsltmp;
12008   int dst, offset;
12009
12010   if (timep == NULL) {
12011     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12012     return NULL;
12013   }
12014   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
12015   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
12016
12017   when = *timep;
12018 # ifdef RTL_USES_UTC
12019 # ifdef VMSISH_TIME
12020   if (VMSISH_TIME) when = _toutc(when);
12021 # endif
12022   /* CRTL localtime() wants UTC as input, does tz correction itself */
12023   return localtime(&when);
12024
12025 # else /* !RTL_USES_UTC */
12026   whenutc = when;
12027 # ifdef VMSISH_TIME
12028   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
12029   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
12030 # endif
12031   dst = -1;
12032 #ifndef RTL_USES_UTC
12033   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
12034       when = whenutc - offset;                   /* pseudolocal time*/
12035   }
12036 # endif
12037   /* CRTL localtime() wants local time as input, so does no tz correction */
12038   rsltmp = localtime(&when);
12039   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
12040   return rsltmp;
12041 # endif
12042
12043 } /*  end of my_localtime() */
12044 /*}}}*/
12045
12046 /* Reset definitions for later calls */
12047 #define gmtime(t)    my_gmtime(t)
12048 #define localtime(t) my_localtime(t)
12049 #define time(t)      my_time(t)
12050
12051
12052 /* my_utime - update modification/access time of a file
12053  *
12054  * VMS 7.3 and later implementation
12055  * Only the UTC translation is home-grown. The rest is handled by the
12056  * CRTL utime(), which will take into account the relevant feature
12057  * logicals and ODS-5 volume characteristics for true access times.
12058  *
12059  * pre VMS 7.3 implementation:
12060  * The calling sequence is identical to POSIX utime(), but under
12061  * VMS with ODS-2, only the modification time is changed; ODS-2 does
12062  * not maintain access times.  Restrictions differ from the POSIX
12063  * definition in that the time can be changed as long as the
12064  * caller has permission to execute the necessary IO$_MODIFY $QIO;
12065  * no separate checks are made to insure that the caller is the
12066  * owner of the file or has special privs enabled.
12067  * Code here is based on Joe Meadows' FILE utility.
12068  *
12069  */
12070
12071 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
12072  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
12073  * in 100 ns intervals.
12074  */
12075 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
12076
12077 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
12078 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
12079 {
12080 #if __CRTL_VER >= 70300000
12081   struct utimbuf utc_utimes, *utc_utimesp;
12082
12083   if (utimes != NULL) {
12084     utc_utimes.actime = utimes->actime;
12085     utc_utimes.modtime = utimes->modtime;
12086 # ifdef VMSISH_TIME
12087     /* If input was local; convert to UTC for sys svc */
12088     if (VMSISH_TIME) {
12089       utc_utimes.actime = _toutc(utimes->actime);
12090       utc_utimes.modtime = _toutc(utimes->modtime);
12091     }
12092 # endif
12093     utc_utimesp = &utc_utimes;
12094   }
12095   else {
12096     utc_utimesp = NULL;
12097   }
12098
12099   return utime(file, utc_utimesp);
12100
12101 #else /* __CRTL_VER < 70300000 */
12102
12103   register int i;
12104   int sts;
12105   long int bintime[2], len = 2, lowbit, unixtime,
12106            secscale = 10000000; /* seconds --> 100 ns intervals */
12107   unsigned long int chan, iosb[2], retsts;
12108   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
12109   struct FAB myfab = cc$rms_fab;
12110   struct NAM mynam = cc$rms_nam;
12111 #if defined (__DECC) && defined (__VAX)
12112   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
12113    * at least through VMS V6.1, which causes a type-conversion warning.
12114    */
12115 #  pragma message save
12116 #  pragma message disable cvtdiftypes
12117 #endif
12118   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
12119   struct fibdef myfib;
12120 #if defined (__DECC) && defined (__VAX)
12121   /* This should be right after the declaration of myatr, but due
12122    * to a bug in VAX DEC C, this takes effect a statement early.
12123    */
12124 #  pragma message restore
12125 #endif
12126   /* cast ok for read only parameter */
12127   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
12128                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
12129                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
12130
12131   if (file == NULL || *file == '\0') {
12132     SETERRNO(ENOENT, LIB$_INVARG);
12133     return -1;
12134   }
12135
12136   /* Convert to VMS format ensuring that it will fit in 255 characters */
12137   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
12138       SETERRNO(ENOENT, LIB$_INVARG);
12139       return -1;
12140   }
12141   if (utimes != NULL) {
12142     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
12143      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
12144      * Since time_t is unsigned long int, and lib$emul takes a signed long int
12145      * as input, we force the sign bit to be clear by shifting unixtime right
12146      * one bit, then multiplying by an extra factor of 2 in lib$emul().
12147      */
12148     lowbit = (utimes->modtime & 1) ? secscale : 0;
12149     unixtime = (long int) utimes->modtime;
12150 #   ifdef VMSISH_TIME
12151     /* If input was UTC; convert to local for sys svc */
12152     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
12153 #   endif
12154     unixtime >>= 1;  secscale <<= 1;
12155     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
12156     if (!(retsts & 1)) {
12157       SETERRNO(EVMSERR, retsts);
12158       return -1;
12159     }
12160     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
12161     if (!(retsts & 1)) {
12162       SETERRNO(EVMSERR, retsts);
12163       return -1;
12164     }
12165   }
12166   else {
12167     /* Just get the current time in VMS format directly */
12168     retsts = sys$gettim(bintime);
12169     if (!(retsts & 1)) {
12170       SETERRNO(EVMSERR, retsts);
12171       return -1;
12172     }
12173   }
12174
12175   myfab.fab$l_fna = vmsspec;
12176   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
12177   myfab.fab$l_nam = &mynam;
12178   mynam.nam$l_esa = esa;
12179   mynam.nam$b_ess = (unsigned char) sizeof esa;
12180   mynam.nam$l_rsa = rsa;
12181   mynam.nam$b_rss = (unsigned char) sizeof rsa;
12182   if (decc_efs_case_preserve)
12183       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
12184
12185   /* Look for the file to be affected, letting RMS parse the file
12186    * specification for us as well.  I have set errno using only
12187    * values documented in the utime() man page for VMS POSIX.
12188    */
12189   retsts = sys$parse(&myfab,0,0);
12190   if (!(retsts & 1)) {
12191     set_vaxc_errno(retsts);
12192     if      (retsts == RMS$_PRV) set_errno(EACCES);
12193     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
12194     else                         set_errno(EVMSERR);
12195     return -1;
12196   }
12197   retsts = sys$search(&myfab,0,0);
12198   if (!(retsts & 1)) {
12199     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12200     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12201     set_vaxc_errno(retsts);
12202     if      (retsts == RMS$_PRV) set_errno(EACCES);
12203     else if (retsts == RMS$_FNF) set_errno(ENOENT);
12204     else                         set_errno(EVMSERR);
12205     return -1;
12206   }
12207
12208   devdsc.dsc$w_length = mynam.nam$b_dev;
12209   /* cast ok for read only parameter */
12210   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
12211
12212   retsts = sys$assign(&devdsc,&chan,0,0);
12213   if (!(retsts & 1)) {
12214     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12215     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12216     set_vaxc_errno(retsts);
12217     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
12218     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
12219     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
12220     else                               set_errno(EVMSERR);
12221     return -1;
12222   }
12223
12224   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
12225   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
12226
12227   memset((void *) &myfib, 0, sizeof myfib);
12228 #if defined(__DECC) || defined(__DECCXX)
12229   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
12230   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
12231   /* This prevents the revision time of the file being reset to the current
12232    * time as a result of our IO$_MODIFY $QIO. */
12233   myfib.fib$l_acctl = FIB$M_NORECORD;
12234 #else
12235   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
12236   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
12237   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
12238 #endif
12239   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
12240   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12241   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12242   _ckvmssts(sys$dassgn(chan));
12243   if (retsts & 1) retsts = iosb[0];
12244   if (!(retsts & 1)) {
12245     set_vaxc_errno(retsts);
12246     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12247     else                      set_errno(EVMSERR);
12248     return -1;
12249   }
12250
12251   return 0;
12252
12253 #endif /* #if __CRTL_VER >= 70300000 */
12254
12255 }  /* end of my_utime() */
12256 /*}}}*/
12257
12258 /*
12259  * flex_stat, flex_lstat, flex_fstat
12260  * basic stat, but gets it right when asked to stat
12261  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
12262  */
12263
12264 #ifndef _USE_STD_STAT
12265 /* encode_dev packs a VMS device name string into an integer to allow
12266  * simple comparisons. This can be used, for example, to check whether two
12267  * files are located on the same device, by comparing their encoded device
12268  * names. Even a string comparison would not do, because stat() reuses the
12269  * device name buffer for each call; so without encode_dev, it would be
12270  * necessary to save the buffer and use strcmp (this would mean a number of
12271  * changes to the standard Perl code, to say nothing of what a Perl script
12272  * would have to do.
12273  *
12274  * The device lock id, if it exists, should be unique (unless perhaps compared
12275  * with lock ids transferred from other nodes). We have a lock id if the disk is
12276  * mounted cluster-wide, which is when we tend to get long (host-qualified)
12277  * device names. Thus we use the lock id in preference, and only if that isn't
12278  * available, do we try to pack the device name into an integer (flagged by
12279  * the sign bit (LOCKID_MASK) being set).
12280  *
12281  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
12282  * name and its encoded form, but it seems very unlikely that we will find
12283  * two files on different disks that share the same encoded device names,
12284  * and even more remote that they will share the same file id (if the test
12285  * is to check for the same file).
12286  *
12287  * A better method might be to use sys$device_scan on the first call, and to
12288  * search for the device, returning an index into the cached array.
12289  * The number returned would be more intelligible.
12290  * This is probably not worth it, and anyway would take quite a bit longer
12291  * on the first call.
12292  */
12293 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
12294 static mydev_t encode_dev (pTHX_ const char *dev)
12295 {
12296   int i;
12297   unsigned long int f;
12298   mydev_t enc;
12299   char c;
12300   const char *q;
12301
12302   if (!dev || !dev[0]) return 0;
12303
12304 #if LOCKID_MASK
12305   {
12306     struct dsc$descriptor_s dev_desc;
12307     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
12308
12309     /* For cluster-mounted disks, the disk lock identifier is unique, so we
12310        can try that first. */
12311     dev_desc.dsc$w_length =  strlen (dev);
12312     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
12313     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
12314     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
12315     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
12316     if (!$VMS_STATUS_SUCCESS(status)) {
12317       switch (status) {
12318         case SS$_NOSUCHDEV:
12319           SETERRNO(ENODEV, status);
12320           return 0;
12321         default:
12322           _ckvmssts(status);
12323       }
12324     }
12325     if (lockid) return (lockid & ~LOCKID_MASK);
12326   }
12327 #endif
12328
12329   /* Otherwise we try to encode the device name */
12330   enc = 0;
12331   f = 1;
12332   i = 0;
12333   for (q = dev + strlen(dev); q--; q >= dev) {
12334     if (*q == ':')
12335         break;
12336     if (isdigit (*q))
12337       c= (*q) - '0';
12338     else if (isalpha (toupper (*q)))
12339       c= toupper (*q) - 'A' + (char)10;
12340     else
12341       continue; /* Skip '$'s */
12342     i++;
12343     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
12344     if (i>1) f *= 36;
12345     enc += f * (unsigned long int) c;
12346   }
12347   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
12348
12349 }  /* end of encode_dev() */
12350 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12351         device_no = encode_dev(aTHX_ devname)
12352 #else
12353 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12354         device_no = new_dev_no
12355 #endif
12356
12357 static int
12358 is_null_device(name)
12359     const char *name;
12360 {
12361   if (decc_bug_devnull != 0) {
12362     if (strncmp("/dev/null", name, 9) == 0)
12363       return 1;
12364   }
12365     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
12366        The underscore prefix, controller letter, and unit number are
12367        independently optional; for our purposes, the colon punctuation
12368        is not.  The colon can be trailed by optional directory and/or
12369        filename, but two consecutive colons indicates a nodename rather
12370        than a device.  [pr]  */
12371   if (*name == '_') ++name;
12372   if (tolower(*name++) != 'n') return 0;
12373   if (tolower(*name++) != 'l') return 0;
12374   if (tolower(*name) == 'a') ++name;
12375   if (*name == '0') ++name;
12376   return (*name++ == ':') && (*name != ':');
12377 }
12378
12379
12380 static I32
12381 Perl_cando_by_name_int
12382    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
12383 {
12384   char usrname[L_cuserid];
12385   struct dsc$descriptor_s usrdsc =
12386          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
12387   char *vmsname = NULL, *fileified = NULL;
12388   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
12389   unsigned short int retlen, trnlnm_iter_count;
12390   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12391   union prvdef curprv;
12392   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
12393          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
12394          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
12395   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
12396          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
12397          {0,0,0,0}};
12398   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
12399          {0,0,0,0}};
12400   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12401   Stat_t st;
12402   static int profile_context = -1;
12403
12404   if (!fname || !*fname) return FALSE;
12405
12406   /* Make sure we expand logical names, since sys$check_access doesn't */
12407   fileified = PerlMem_malloc(VMS_MAXRSS);
12408   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12409   if (!strpbrk(fname,"/]>:")) {
12410       strcpy(fileified,fname);
12411       trnlnm_iter_count = 0;
12412       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
12413         trnlnm_iter_count++;
12414         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
12415       }
12416       fname = fileified;
12417   }
12418
12419   vmsname = PerlMem_malloc(VMS_MAXRSS);
12420   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12421   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
12422     /* Don't know if already in VMS format, so make sure */
12423     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
12424       PerlMem_free(fileified);
12425       PerlMem_free(vmsname);
12426       return FALSE;
12427     }
12428   }
12429   else {
12430     strcpy(vmsname,fname);
12431   }
12432
12433   /* sys$check_access needs a file spec, not a directory spec.
12434    * Don't use flex_stat here, as that depends on thread context
12435    * having been initialized, and we may get here during startup.
12436    */
12437
12438   retlen = namdsc.dsc$w_length = strlen(vmsname);
12439   if (vmsname[retlen-1] == ']'
12440       || vmsname[retlen-1] == '>'
12441       || vmsname[retlen-1] == ':'
12442       || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
12443
12444       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
12445         PerlMem_free(fileified);
12446         PerlMem_free(vmsname);
12447         return FALSE;
12448       }
12449       fname = fileified;
12450   }
12451   else {
12452       fname = vmsname;
12453   }
12454
12455   retlen = namdsc.dsc$w_length = strlen(fname);
12456   namdsc.dsc$a_pointer = (char *)fname;
12457
12458   switch (bit) {
12459     case S_IXUSR: case S_IXGRP: case S_IXOTH:
12460       access = ARM$M_EXECUTE;
12461       flags = CHP$M_READ;
12462       break;
12463     case S_IRUSR: case S_IRGRP: case S_IROTH:
12464       access = ARM$M_READ;
12465       flags = CHP$M_READ | CHP$M_USEREADALL;
12466       break;
12467     case S_IWUSR: case S_IWGRP: case S_IWOTH:
12468       access = ARM$M_WRITE;
12469       flags = CHP$M_READ | CHP$M_WRITE;
12470       break;
12471     case S_IDUSR: case S_IDGRP: case S_IDOTH:
12472       access = ARM$M_DELETE;
12473       flags = CHP$M_READ | CHP$M_WRITE;
12474       break;
12475     default:
12476       if (fileified != NULL)
12477         PerlMem_free(fileified);
12478       if (vmsname != NULL)
12479         PerlMem_free(vmsname);
12480       return FALSE;
12481   }
12482
12483   /* Before we call $check_access, create a user profile with the current
12484    * process privs since otherwise it just uses the default privs from the
12485    * UAF and might give false positives or negatives.  This only works on
12486    * VMS versions v6.0 and later since that's when sys$create_user_profile
12487    * became available.
12488    */
12489
12490   /* get current process privs and username */
12491   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12492   _ckvmssts_noperl(iosb[0]);
12493
12494 #if defined(__VMS_VER) && __VMS_VER >= 60000000
12495
12496   /* find out the space required for the profile */
12497   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12498                                     &usrprodsc.dsc$w_length,&profile_context));
12499
12500   /* allocate space for the profile and get it filled in */
12501   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
12502   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12503   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12504                                     &usrprodsc.dsc$w_length,&profile_context));
12505
12506   /* use the profile to check access to the file; free profile & analyze results */
12507   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12508   PerlMem_free(usrprodsc.dsc$a_pointer);
12509   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12510
12511 #else
12512
12513   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
12514
12515 #endif
12516
12517   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12518       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12519       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12520     set_vaxc_errno(retsts);
12521     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12522     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12523     else set_errno(ENOENT);
12524     if (fileified != NULL)
12525       PerlMem_free(fileified);
12526     if (vmsname != NULL)
12527       PerlMem_free(vmsname);
12528     return FALSE;
12529   }
12530   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12531     if (fileified != NULL)
12532       PerlMem_free(fileified);
12533     if (vmsname != NULL)
12534       PerlMem_free(vmsname);
12535     return TRUE;
12536   }
12537   _ckvmssts_noperl(retsts);
12538
12539   if (fileified != NULL)
12540     PerlMem_free(fileified);
12541   if (vmsname != NULL)
12542     PerlMem_free(vmsname);
12543   return FALSE;  /* Should never get here */
12544
12545 }
12546
12547 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12548 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12549  * subset of the applicable information.
12550  */
12551 bool
12552 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12553 {
12554   return cando_by_name_int
12555         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12556 }  /* end of cando() */
12557 /*}}}*/
12558
12559
12560 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12561 I32
12562 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12563 {
12564    return cando_by_name_int(bit, effective, fname, 0);
12565
12566 }  /* end of cando_by_name() */
12567 /*}}}*/
12568
12569
12570 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12571 int
12572 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12573 {
12574   if (!fstat(fd,(stat_t *) statbufp)) {
12575     char *cptr;
12576     char *vms_filename;
12577     vms_filename = PerlMem_malloc(VMS_MAXRSS);
12578     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12579
12580     /* Save name for cando by name in VMS format */
12581     cptr = getname(fd, vms_filename, 1);
12582
12583     /* This should not happen, but just in case */
12584     if (cptr == NULL) {
12585         statbufp->st_devnam[0] = 0;
12586     }
12587     else {
12588         /* Make sure that the saved name fits in 255 characters */
12589         cptr = int_rmsexpand_vms
12590                        (vms_filename,
12591                         statbufp->st_devnam,
12592                         0);
12593         if (cptr == NULL)
12594             statbufp->st_devnam[0] = 0;
12595     }
12596     PerlMem_free(vms_filename);
12597
12598     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12599     VMS_DEVICE_ENCODE
12600         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12601
12602 #   ifdef RTL_USES_UTC
12603 #   ifdef VMSISH_TIME
12604     if (VMSISH_TIME) {
12605       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12606       statbufp->st_atime = _toloc(statbufp->st_atime);
12607       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12608     }
12609 #   endif
12610 #   else
12611 #   ifdef VMSISH_TIME
12612     if (!VMSISH_TIME) { /* Return UTC instead of local time */
12613 #   else
12614     if (1) {
12615 #   endif
12616       statbufp->st_mtime = _toutc(statbufp->st_mtime);
12617       statbufp->st_atime = _toutc(statbufp->st_atime);
12618       statbufp->st_ctime = _toutc(statbufp->st_ctime);
12619     }
12620 #endif
12621     return 0;
12622   }
12623   return -1;
12624
12625 }  /* end of flex_fstat() */
12626 /*}}}*/
12627
12628 #if !defined(__VAX) && __CRTL_VER >= 80200000
12629 #ifdef lstat
12630 #undef lstat
12631 #endif
12632 #else
12633 #ifdef lstat
12634 #undef lstat
12635 #endif
12636 #define lstat(_x, _y) stat(_x, _y)
12637 #endif
12638
12639 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
12640
12641 static int
12642 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12643 {
12644     char fileified[VMS_MAXRSS];
12645     char temp_fspec[VMS_MAXRSS];
12646     char *save_spec;
12647     int retval = -1;
12648     dSAVEDERRNO;
12649
12650     if (!fspec) return retval;
12651     SAVE_ERRNO;
12652     strcpy(temp_fspec, fspec);
12653
12654     if (decc_bug_devnull != 0) {
12655       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
12656         memset(statbufp,0,sizeof *statbufp);
12657         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12658         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12659         statbufp->st_uid = 0x00010001;
12660         statbufp->st_gid = 0x0001;
12661         time((time_t *)&statbufp->st_mtime);
12662         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12663         return 0;
12664       }
12665     }
12666
12667     /* Try for a directory name first.  If fspec contains a filename without
12668      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12669      * and sea:[wine.dark]water. exist, we prefer the directory here.
12670      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12671      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12672      * the file with null type, specify this by calling flex_stat() with
12673      * a '.' at the end of fspec.
12674      *
12675      * If we are in Posix filespec mode, accept the filename as is.
12676      */
12677
12678
12679 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12680   /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
12681    * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
12682    */
12683   if (!decc_efs_charset)
12684     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
12685 #endif
12686
12687 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12688   if (decc_posix_compliant_pathnames == 0) {
12689 #endif
12690     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
12691       if (lstat_flag == 0)
12692         retval = stat(fileified,(stat_t *) statbufp);
12693       else
12694         retval = lstat(fileified,(stat_t *) statbufp);
12695       save_spec = fileified;
12696     }
12697     if (retval) {
12698       if (lstat_flag == 0)
12699         retval = stat(temp_fspec,(stat_t *) statbufp);
12700       else
12701         retval = lstat(temp_fspec,(stat_t *) statbufp);
12702       save_spec = temp_fspec;
12703     }
12704 /*
12705  * In debugging, on 8.3 Alpha, I found a case where stat was returning a
12706  * file not found error for a directory named foo:[bar.t] or /foo/bar/t
12707  * and lstat was working correctly for the same file.
12708  * The only syntax that was working for stat was "foo:[bar]t.dir".
12709  *
12710  * Other directories with the same syntax worked fine.
12711  * So work around the problem when it shows up here.
12712  */
12713     if (retval) {
12714         int save_errno = errno;
12715         if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
12716             if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
12717                 retval = stat(fileified, (stat_t *) statbufp);
12718                 save_spec = fileified;
12719             }
12720         }
12721         /* Restore the errno value if third stat does not succeed */
12722         if (retval != 0)
12723             errno = save_errno;
12724     }
12725 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12726   } else {
12727     if (lstat_flag == 0)
12728       retval = stat(temp_fspec,(stat_t *) statbufp);
12729     else
12730       retval = lstat(temp_fspec,(stat_t *) statbufp);
12731       save_spec = temp_fspec;
12732   }
12733 #endif
12734
12735 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12736   /* As you were... */
12737   if (!decc_efs_charset)
12738     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12739 #endif
12740
12741     if (!retval) {
12742     char * cptr;
12743     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12744
12745       /* If this is an lstat, do not follow the link */
12746       if (lstat_flag)
12747         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12748
12749       cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags);
12750       if (cptr == NULL)
12751         statbufp->st_devnam[0] = 0;
12752
12753       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12754       VMS_DEVICE_ENCODE
12755         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12756 #     ifdef RTL_USES_UTC
12757 #     ifdef VMSISH_TIME
12758       if (VMSISH_TIME) {
12759         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12760         statbufp->st_atime = _toloc(statbufp->st_atime);
12761         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12762       }
12763 #     endif
12764 #     else
12765 #     ifdef VMSISH_TIME
12766       if (!VMSISH_TIME) { /* Return UTC instead of local time */
12767 #     else
12768       if (1) {
12769 #     endif
12770         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12771         statbufp->st_atime = _toutc(statbufp->st_atime);
12772         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12773       }
12774 #     endif
12775     }
12776     /* If we were successful, leave errno where we found it */
12777     if (retval == 0) RESTORE_ERRNO;
12778     return retval;
12779
12780 }  /* end of flex_stat_int() */
12781
12782
12783 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12784 int
12785 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12786 {
12787    return flex_stat_int(fspec, statbufp, 0);
12788 }
12789 /*}}}*/
12790
12791 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12792 int
12793 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12794 {
12795    return flex_stat_int(fspec, statbufp, 1);
12796 }
12797 /*}}}*/
12798
12799
12800 /*{{{char *my_getlogin()*/
12801 /* VMS cuserid == Unix getlogin, except calling sequence */
12802 char *
12803 my_getlogin(void)
12804 {
12805     static char user[L_cuserid];
12806     return cuserid(user);
12807 }
12808 /*}}}*/
12809
12810
12811 /*  rmscopy - copy a file using VMS RMS routines
12812  *
12813  *  Copies contents and attributes of spec_in to spec_out, except owner
12814  *  and protection information.  Name and type of spec_in are used as
12815  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12816  *  should try to propagate timestamps from the input file to the output file.
12817  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12818  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12819  *  propagated to the output file at creation iff the output file specification
12820  *  did not contain an explicit name or type, and the revision date is always
12821  *  updated at the end of the copy operation.  If it is greater than 0, then
12822  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12823  *  other than the revision date should be propagated, and bit 1 indicates
12824  *  that the revision date should be propagated.
12825  *
12826  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12827  *
12828  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12829  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12830  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12831  * as part of the Perl standard distribution under the terms of the
12832  * GNU General Public License or the Perl Artistic License.  Copies
12833  * of each may be found in the Perl standard distribution.
12834  */ /* FIXME */
12835 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12836 int
12837 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12838 {
12839     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12840          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12841     unsigned long int i, sts, sts2;
12842     int dna_len;
12843     struct FAB fab_in, fab_out;
12844     struct RAB rab_in, rab_out;
12845     rms_setup_nam(nam);
12846     rms_setup_nam(nam_out);
12847     struct XABDAT xabdat;
12848     struct XABFHC xabfhc;
12849     struct XABRDT xabrdt;
12850     struct XABSUM xabsum;
12851
12852     vmsin = PerlMem_malloc(VMS_MAXRSS);
12853     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12854     vmsout = PerlMem_malloc(VMS_MAXRSS);
12855     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12856     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12857         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12858       PerlMem_free(vmsin);
12859       PerlMem_free(vmsout);
12860       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12861       return 0;
12862     }
12863
12864     esa = PerlMem_malloc(VMS_MAXRSS);
12865     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12866     esal = NULL;
12867 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12868     esal = PerlMem_malloc(VMS_MAXRSS);
12869     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12870 #endif
12871     fab_in = cc$rms_fab;
12872     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12873     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12874     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12875     fab_in.fab$l_fop = FAB$M_SQO;
12876     rms_bind_fab_nam(fab_in, nam);
12877     fab_in.fab$l_xab = (void *) &xabdat;
12878
12879     rsa = PerlMem_malloc(VMS_MAXRSS);
12880     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12881     rsal = NULL;
12882 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12883     rsal = PerlMem_malloc(VMS_MAXRSS);
12884     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12885 #endif
12886     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12887     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12888     rms_nam_esl(nam) = 0;
12889     rms_nam_rsl(nam) = 0;
12890     rms_nam_esll(nam) = 0;
12891     rms_nam_rsll(nam) = 0;
12892 #ifdef NAM$M_NO_SHORT_UPCASE
12893     if (decc_efs_case_preserve)
12894         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12895 #endif
12896
12897     xabdat = cc$rms_xabdat;        /* To get creation date */
12898     xabdat.xab$l_nxt = (void *) &xabfhc;
12899
12900     xabfhc = cc$rms_xabfhc;        /* To get record length */
12901     xabfhc.xab$l_nxt = (void *) &xabsum;
12902
12903     xabsum = cc$rms_xabsum;        /* To get key and area information */
12904
12905     if (!((sts = sys$open(&fab_in)) & 1)) {
12906       PerlMem_free(vmsin);
12907       PerlMem_free(vmsout);
12908       PerlMem_free(esa);
12909       if (esal != NULL)
12910         PerlMem_free(esal);
12911       PerlMem_free(rsa);
12912       if (rsal != NULL)
12913         PerlMem_free(rsal);
12914       set_vaxc_errno(sts);
12915       switch (sts) {
12916         case RMS$_FNF: case RMS$_DNF:
12917           set_errno(ENOENT); break;
12918         case RMS$_DIR:
12919           set_errno(ENOTDIR); break;
12920         case RMS$_DEV:
12921           set_errno(ENODEV); break;
12922         case RMS$_SYN:
12923           set_errno(EINVAL); break;
12924         case RMS$_PRV:
12925           set_errno(EACCES); break;
12926         default:
12927           set_errno(EVMSERR);
12928       }
12929       return 0;
12930     }
12931
12932     nam_out = nam;
12933     fab_out = fab_in;
12934     fab_out.fab$w_ifi = 0;
12935     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12936     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12937     fab_out.fab$l_fop = FAB$M_SQO;
12938     rms_bind_fab_nam(fab_out, nam_out);
12939     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12940     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12941     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12942     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12943     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12944     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12945     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12946     esal_out = NULL;
12947     rsal_out = NULL;
12948 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12949     esal_out = PerlMem_malloc(VMS_MAXRSS);
12950     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12951     rsal_out = PerlMem_malloc(VMS_MAXRSS);
12952     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12953 #endif
12954     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12955     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12956
12957     if (preserve_dates == 0) {  /* Act like DCL COPY */
12958       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12959       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12960       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12961         PerlMem_free(vmsin);
12962         PerlMem_free(vmsout);
12963         PerlMem_free(esa);
12964         if (esal != NULL)
12965             PerlMem_free(esal);
12966         PerlMem_free(rsa);
12967         if (rsal != NULL)
12968             PerlMem_free(rsal);
12969         PerlMem_free(esa_out);
12970         if (esal_out != NULL)
12971             PerlMem_free(esal_out);
12972         PerlMem_free(rsa_out);
12973         if (rsal_out != NULL)
12974             PerlMem_free(rsal_out);
12975         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12976         set_vaxc_errno(sts);
12977         return 0;
12978       }
12979       fab_out.fab$l_xab = (void *) &xabdat;
12980       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12981         preserve_dates = 1;
12982     }
12983     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12984       preserve_dates =0;      /* bitmask from this point forward   */
12985
12986     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12987     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12988       PerlMem_free(vmsin);
12989       PerlMem_free(vmsout);
12990       PerlMem_free(esa);
12991       if (esal != NULL)
12992           PerlMem_free(esal);
12993       PerlMem_free(rsa);
12994       if (rsal != NULL)
12995           PerlMem_free(rsal);
12996       PerlMem_free(esa_out);
12997       if (esal_out != NULL)
12998           PerlMem_free(esal_out);
12999       PerlMem_free(rsa_out);
13000       if (rsal_out != NULL)
13001           PerlMem_free(rsal_out);
13002       set_vaxc_errno(sts);
13003       switch (sts) {
13004         case RMS$_DNF:
13005           set_errno(ENOENT); break;
13006         case RMS$_DIR:
13007           set_errno(ENOTDIR); break;
13008         case RMS$_DEV:
13009           set_errno(ENODEV); break;
13010         case RMS$_SYN:
13011           set_errno(EINVAL); break;
13012         case RMS$_PRV:
13013           set_errno(EACCES); break;
13014         default:
13015           set_errno(EVMSERR);
13016       }
13017       return 0;
13018     }
13019     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
13020     if (preserve_dates & 2) {
13021       /* sys$close() will process xabrdt, not xabdat */
13022       xabrdt = cc$rms_xabrdt;
13023 #ifndef __GNUC__
13024       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
13025 #else
13026       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
13027        * is unsigned long[2], while DECC & VAXC use a struct */
13028       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
13029 #endif
13030       fab_out.fab$l_xab = (void *) &xabrdt;
13031     }
13032
13033     ubf = PerlMem_malloc(32256);
13034     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13035     rab_in = cc$rms_rab;
13036     rab_in.rab$l_fab = &fab_in;
13037     rab_in.rab$l_rop = RAB$M_BIO;
13038     rab_in.rab$l_ubf = ubf;
13039     rab_in.rab$w_usz = 32256;
13040     if (!((sts = sys$connect(&rab_in)) & 1)) {
13041       sys$close(&fab_in); sys$close(&fab_out);
13042       PerlMem_free(vmsin);
13043       PerlMem_free(vmsout);
13044       PerlMem_free(ubf);
13045       PerlMem_free(esa);
13046       if (esal != NULL)
13047           PerlMem_free(esal);
13048       PerlMem_free(rsa);
13049       if (rsal != NULL)
13050           PerlMem_free(rsal);
13051       PerlMem_free(esa_out);
13052       if (esal_out != NULL)
13053           PerlMem_free(esal_out);
13054       PerlMem_free(rsa_out);
13055       if (rsal_out != NULL)
13056           PerlMem_free(rsal_out);
13057       set_errno(EVMSERR); set_vaxc_errno(sts);
13058       return 0;
13059     }
13060
13061     rab_out = cc$rms_rab;
13062     rab_out.rab$l_fab = &fab_out;
13063     rab_out.rab$l_rbf = ubf;
13064     if (!((sts = sys$connect(&rab_out)) & 1)) {
13065       sys$close(&fab_in); sys$close(&fab_out);
13066       PerlMem_free(vmsin);
13067       PerlMem_free(vmsout);
13068       PerlMem_free(ubf);
13069       PerlMem_free(esa);
13070       if (esal != NULL)
13071           PerlMem_free(esal);
13072       PerlMem_free(rsa);
13073       if (rsal != NULL)
13074           PerlMem_free(rsal);
13075       PerlMem_free(esa_out);
13076       if (esal_out != NULL)
13077           PerlMem_free(esal_out);
13078       PerlMem_free(rsa_out);
13079       if (rsal_out != NULL)
13080           PerlMem_free(rsal_out);
13081       set_errno(EVMSERR); set_vaxc_errno(sts);
13082       return 0;
13083     }
13084
13085     while ((sts = sys$read(&rab_in))) {  /* always true  */
13086       if (sts == RMS$_EOF) break;
13087       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
13088       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
13089         sys$close(&fab_in); sys$close(&fab_out);
13090         PerlMem_free(vmsin);
13091         PerlMem_free(vmsout);
13092         PerlMem_free(ubf);
13093         PerlMem_free(esa);
13094         if (esal != NULL)
13095             PerlMem_free(esal);
13096         PerlMem_free(rsa);
13097         if (rsal != NULL)
13098             PerlMem_free(rsal);
13099         PerlMem_free(esa_out);
13100         if (esal_out != NULL)
13101             PerlMem_free(esal_out);
13102         PerlMem_free(rsa_out);
13103         if (rsal_out != NULL)
13104             PerlMem_free(rsal_out);
13105         set_errno(EVMSERR); set_vaxc_errno(sts);
13106         return 0;
13107       }
13108     }
13109
13110
13111     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
13112     sys$close(&fab_in);  sys$close(&fab_out);
13113     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
13114
13115     PerlMem_free(vmsin);
13116     PerlMem_free(vmsout);
13117     PerlMem_free(ubf);
13118     PerlMem_free(esa);
13119     if (esal != NULL)
13120         PerlMem_free(esal);
13121     PerlMem_free(rsa);
13122     if (rsal != NULL)
13123         PerlMem_free(rsal);
13124     PerlMem_free(esa_out);
13125     if (esal_out != NULL)
13126         PerlMem_free(esal_out);
13127     PerlMem_free(rsa_out);
13128     if (rsal_out != NULL)
13129         PerlMem_free(rsal_out);
13130
13131     if (!(sts & 1)) {
13132       set_errno(EVMSERR); set_vaxc_errno(sts);
13133       return 0;
13134     }
13135
13136     return 1;
13137
13138 }  /* end of rmscopy() */
13139 /*}}}*/
13140
13141
13142 /***  The following glue provides 'hooks' to make some of the routines
13143  * from this file available from Perl.  These routines are sufficiently
13144  * basic, and are required sufficiently early in the build process,
13145  * that's it's nice to have them available to miniperl as well as the
13146  * full Perl, so they're set up here instead of in an extension.  The
13147  * Perl code which handles importation of these names into a given
13148  * package lives in [.VMS]Filespec.pm in @INC.
13149  */
13150
13151 void
13152 rmsexpand_fromperl(pTHX_ CV *cv)
13153 {
13154   dXSARGS;
13155   char *fspec, *defspec = NULL, *rslt;
13156   STRLEN n_a;
13157   int fs_utf8, dfs_utf8;
13158
13159   fs_utf8 = 0;
13160   dfs_utf8 = 0;
13161   if (!items || items > 2)
13162     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
13163   fspec = SvPV(ST(0),n_a);
13164   fs_utf8 = SvUTF8(ST(0));
13165   if (!fspec || !*fspec) XSRETURN_UNDEF;
13166   if (items == 2) {
13167     defspec = SvPV(ST(1),n_a);
13168     dfs_utf8 = SvUTF8(ST(1));
13169   }
13170   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
13171   ST(0) = sv_newmortal();
13172   if (rslt != NULL) {
13173     sv_usepvn(ST(0),rslt,strlen(rslt));
13174     if (fs_utf8) {
13175         SvUTF8_on(ST(0));
13176     }
13177   }
13178   XSRETURN(1);
13179 }
13180
13181 void
13182 vmsify_fromperl(pTHX_ CV *cv)
13183 {
13184   dXSARGS;
13185   char *vmsified;
13186   STRLEN n_a;
13187   int utf8_fl;
13188
13189   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
13190   utf8_fl = SvUTF8(ST(0));
13191   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13192   ST(0) = sv_newmortal();
13193   if (vmsified != NULL) {
13194     sv_usepvn(ST(0),vmsified,strlen(vmsified));
13195     if (utf8_fl) {
13196         SvUTF8_on(ST(0));
13197     }
13198   }
13199   XSRETURN(1);
13200 }
13201
13202 void
13203 unixify_fromperl(pTHX_ CV *cv)
13204 {
13205   dXSARGS;
13206   char *unixified;
13207   STRLEN n_a;
13208   int utf8_fl;
13209
13210   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
13211   utf8_fl = SvUTF8(ST(0));
13212   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13213   ST(0) = sv_newmortal();
13214   if (unixified != NULL) {
13215     sv_usepvn(ST(0),unixified,strlen(unixified));
13216     if (utf8_fl) {
13217         SvUTF8_on(ST(0));
13218     }
13219   }
13220   XSRETURN(1);
13221 }
13222
13223 void
13224 fileify_fromperl(pTHX_ CV *cv)
13225 {
13226   dXSARGS;
13227   char *fileified;
13228   STRLEN n_a;
13229   int utf8_fl;
13230
13231   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
13232   utf8_fl = SvUTF8(ST(0));
13233   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13234   ST(0) = sv_newmortal();
13235   if (fileified != NULL) {
13236     sv_usepvn(ST(0),fileified,strlen(fileified));
13237     if (utf8_fl) {
13238         SvUTF8_on(ST(0));
13239     }
13240   }
13241   XSRETURN(1);
13242 }
13243
13244 void
13245 pathify_fromperl(pTHX_ CV *cv)
13246 {
13247   dXSARGS;
13248   char *pathified;
13249   STRLEN n_a;
13250   int utf8_fl;
13251
13252   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
13253   utf8_fl = SvUTF8(ST(0));
13254   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13255   ST(0) = sv_newmortal();
13256   if (pathified != NULL) {
13257     sv_usepvn(ST(0),pathified,strlen(pathified));
13258     if (utf8_fl) {
13259         SvUTF8_on(ST(0));
13260     }
13261   }
13262   XSRETURN(1);
13263 }
13264
13265 void
13266 vmspath_fromperl(pTHX_ CV *cv)
13267 {
13268   dXSARGS;
13269   char *vmspath;
13270   STRLEN n_a;
13271   int utf8_fl;
13272
13273   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
13274   utf8_fl = SvUTF8(ST(0));
13275   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13276   ST(0) = sv_newmortal();
13277   if (vmspath != NULL) {
13278     sv_usepvn(ST(0),vmspath,strlen(vmspath));
13279     if (utf8_fl) {
13280         SvUTF8_on(ST(0));
13281     }
13282   }
13283   XSRETURN(1);
13284 }
13285
13286 void
13287 unixpath_fromperl(pTHX_ CV *cv)
13288 {
13289   dXSARGS;
13290   char *unixpath;
13291   STRLEN n_a;
13292   int utf8_fl;
13293
13294   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
13295   utf8_fl = SvUTF8(ST(0));
13296   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13297   ST(0) = sv_newmortal();
13298   if (unixpath != NULL) {
13299     sv_usepvn(ST(0),unixpath,strlen(unixpath));
13300     if (utf8_fl) {
13301         SvUTF8_on(ST(0));
13302     }
13303   }
13304   XSRETURN(1);
13305 }
13306
13307 void
13308 candelete_fromperl(pTHX_ CV *cv)
13309 {
13310   dXSARGS;
13311   char *fspec, *fsp;
13312   SV *mysv;
13313   IO *io;
13314   STRLEN n_a;
13315
13316   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
13317
13318   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13319   Newx(fspec, VMS_MAXRSS, char);
13320   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
13321   if (SvTYPE(mysv) == SVt_PVGV) {
13322     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
13323       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13324       ST(0) = &PL_sv_no;
13325       Safefree(fspec);
13326       XSRETURN(1);
13327     }
13328     fsp = fspec;
13329   }
13330   else {
13331     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
13332       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13333       ST(0) = &PL_sv_no;
13334       Safefree(fspec);
13335       XSRETURN(1);
13336     }
13337   }
13338
13339   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
13340   Safefree(fspec);
13341   XSRETURN(1);
13342 }
13343
13344 void
13345 rmscopy_fromperl(pTHX_ CV *cv)
13346 {
13347   dXSARGS;
13348   char *inspec, *outspec, *inp, *outp;
13349   int date_flag;
13350   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
13351                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13352   unsigned long int sts;
13353   SV *mysv;
13354   IO *io;
13355   STRLEN n_a;
13356
13357   if (items < 2 || items > 3)
13358     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
13359
13360   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13361   Newx(inspec, VMS_MAXRSS, char);
13362   if (SvTYPE(mysv) == SVt_PVGV) {
13363     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
13364       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13365       ST(0) = &PL_sv_no;
13366       Safefree(inspec);
13367       XSRETURN(1);
13368     }
13369     inp = inspec;
13370   }
13371   else {
13372     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
13373       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13374       ST(0) = &PL_sv_no;
13375       Safefree(inspec);
13376       XSRETURN(1);
13377     }
13378   }
13379   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
13380   Newx(outspec, VMS_MAXRSS, char);
13381   if (SvTYPE(mysv) == SVt_PVGV) {
13382     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
13383       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13384       ST(0) = &PL_sv_no;
13385       Safefree(inspec);
13386       Safefree(outspec);
13387       XSRETURN(1);
13388     }
13389     outp = outspec;
13390   }
13391   else {
13392     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
13393       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13394       ST(0) = &PL_sv_no;
13395       Safefree(inspec);
13396       Safefree(outspec);
13397       XSRETURN(1);
13398     }
13399   }
13400   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
13401
13402   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
13403   Safefree(inspec);
13404   Safefree(outspec);
13405   XSRETURN(1);
13406 }
13407
13408 /* The mod2fname is limited to shorter filenames by design, so it should
13409  * not be modified to support longer EFS pathnames
13410  */
13411 void
13412 mod2fname(pTHX_ CV *cv)
13413 {
13414   dXSARGS;
13415   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13416        workbuff[NAM$C_MAXRSS*1 + 1];
13417   int total_namelen = 3, counter, num_entries;
13418   /* ODS-5 ups this, but we want to be consistent, so... */
13419   int max_name_len = 39;
13420   AV *in_array = (AV *)SvRV(ST(0));
13421
13422   num_entries = av_len(in_array);
13423
13424   /* All the names start with PL_. */
13425   strcpy(ultimate_name, "PL_");
13426
13427   /* Clean up our working buffer */
13428   Zero(work_name, sizeof(work_name), char);
13429
13430   /* Run through the entries and build up a working name */
13431   for(counter = 0; counter <= num_entries; counter++) {
13432     /* If it's not the first name then tack on a __ */
13433     if (counter) {
13434       strcat(work_name, "__");
13435     }
13436     strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
13437   }
13438
13439   /* Check to see if we actually have to bother...*/
13440   if (strlen(work_name) + 3 <= max_name_len) {
13441     strcat(ultimate_name, work_name);
13442   } else {
13443     /* It's too darned big, so we need to go strip. We use the same */
13444     /* algorithm as xsubpp does. First, strip out doubled __ */
13445     char *source, *dest, last;
13446     dest = workbuff;
13447     last = 0;
13448     for (source = work_name; *source; source++) {
13449       if (last == *source && last == '_') {
13450         continue;
13451       }
13452       *dest++ = *source;
13453       last = *source;
13454     }
13455     /* Go put it back */
13456     strcpy(work_name, workbuff);
13457     /* Is it still too big? */
13458     if (strlen(work_name) + 3 > max_name_len) {
13459       /* Strip duplicate letters */
13460       last = 0;
13461       dest = workbuff;
13462       for (source = work_name; *source; source++) {
13463         if (last == toupper(*source)) {
13464         continue;
13465         }
13466         *dest++ = *source;
13467         last = toupper(*source);
13468       }
13469       strcpy(work_name, workbuff);
13470     }
13471
13472     /* Is it *still* too big? */
13473     if (strlen(work_name) + 3 > max_name_len) {
13474       /* Too bad, we truncate */
13475       work_name[max_name_len - 2] = 0;
13476     }
13477     strcat(ultimate_name, work_name);
13478   }
13479
13480   /* Okay, return it */
13481   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13482   XSRETURN(1);
13483 }
13484
13485 void
13486 hushexit_fromperl(pTHX_ CV *cv)
13487 {
13488     dXSARGS;
13489
13490     if (items > 0) {
13491         VMSISH_HUSHED = SvTRUE(ST(0));
13492     }
13493     ST(0) = boolSV(VMSISH_HUSHED);
13494     XSRETURN(1);
13495 }
13496
13497
13498 PerlIO *
13499 Perl_vms_start_glob
13500    (pTHX_ SV *tmpglob,
13501     IO *io)
13502 {
13503     PerlIO *fp;
13504     struct vs_str_st *rslt;
13505     char *vmsspec;
13506     char *rstr;
13507     char *begin, *cp;
13508     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13509     PerlIO *tmpfp;
13510     STRLEN i;
13511     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13512     struct dsc$descriptor_vs rsdsc;
13513     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13514     unsigned long hasver = 0, isunix = 0;
13515     unsigned long int lff_flags = 0;
13516     int rms_sts;
13517     int vms_old_glob = 1;
13518
13519     if (!SvOK(tmpglob)) {
13520         SETERRNO(ENOENT,RMS$_FNF);
13521         return NULL;
13522     }
13523
13524     vms_old_glob = !decc_filename_unix_report;
13525
13526 #ifdef VMS_LONGNAME_SUPPORT
13527     lff_flags = LIB$M_FIL_LONG_NAMES;
13528 #endif
13529     /* The Newx macro will not allow me to assign a smaller array
13530      * to the rslt pointer, so we will assign it to the begin char pointer
13531      * and then copy the value into the rslt pointer.
13532      */
13533     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13534     rslt = (struct vs_str_st *)begin;
13535     rslt->length = 0;
13536     rstr = &rslt->str[0];
13537     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13538     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13539     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13540     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13541
13542     Newx(vmsspec, VMS_MAXRSS, char);
13543
13544         /* We could find out if there's an explicit dev/dir or version
13545            by peeking into lib$find_file's internal context at
13546            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13547            but that's unsupported, so I don't want to do it now and
13548            have it bite someone in the future. */
13549         /* Fix-me: vms_split_path() is the only way to do this, the
13550            existing method will fail with many legal EFS or UNIX specifications
13551          */
13552
13553     cp = SvPV(tmpglob,i);
13554
13555     for (; i; i--) {
13556         if (cp[i] == ';') hasver = 1;
13557         if (cp[i] == '.') {
13558             if (sts) hasver = 1;
13559             else sts = 1;
13560         }
13561         if (cp[i] == '/') {
13562             hasdir = isunix = 1;
13563             break;
13564         }
13565         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13566             hasdir = 1;
13567             break;
13568         }
13569     }
13570
13571     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13572     if ((hasdir == 0) && decc_filename_unix_report) {
13573         isunix = 1;
13574     }
13575
13576     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13577         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13578         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13579         int wildstar = 0;
13580         int wildquery = 0;
13581         int found = 0;
13582         Stat_t st;
13583         int stat_sts;
13584         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13585         if (!stat_sts && S_ISDIR(st.st_mode)) {
13586             char * vms_dir;
13587             const char * fname;
13588             STRLEN fname_len;
13589
13590             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13591             /* path delimiter of ':>]', if so, then the old behavior has */
13592             /* obviously been specificially requested */
13593
13594             fname = SvPVX_const(tmpglob);
13595             fname_len = strlen(fname);
13596             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13597             if (vms_old_glob || (vms_dir != NULL)) {
13598                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13599                                             SvPVX(tmpglob),vmsspec,NULL);
13600                 ok = (wilddsc.dsc$a_pointer != NULL);
13601                 /* maybe passed 'foo' rather than '[.foo]', thus not
13602                    detected above */
13603                 hasdir = 1;
13604             } else {
13605                 /* Operate just on the directory, the special stat/fstat for */
13606                 /* leaves the fileified  specification in the st_devnam */
13607                 /* member. */
13608                 wilddsc.dsc$a_pointer = st.st_devnam;
13609                 ok = 1;
13610             }
13611         }
13612         else {
13613             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13614             ok = (wilddsc.dsc$a_pointer != NULL);
13615         }
13616         if (ok)
13617             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13618
13619         /* If not extended character set, replace ? with % */
13620         /* With extended character set, ? is a wildcard single character */
13621         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13622             if (*cp == '?') {
13623                 wildquery = 1;
13624                 if (!decc_efs_case_preserve)
13625                     *cp = '%';
13626             } else if (*cp == '%') {
13627                 wildquery = 1;
13628             } else if (*cp == '*') {
13629                 wildstar = 1;
13630             }
13631         }
13632
13633         if (ok) {
13634             wv_sts = vms_split_path(
13635                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13636                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13637                 &wvs_spec, &wvs_len);
13638         } else {
13639             wn_spec = NULL;
13640             wn_len = 0;
13641             we_spec = NULL;
13642             we_len = 0;
13643         }
13644
13645         sts = SS$_NORMAL;
13646         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13647          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13648          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13649          int valid_find;
13650
13651             valid_find = 0;
13652             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13653                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13654             if (!$VMS_STATUS_SUCCESS(sts))
13655                 break;
13656
13657             /* with varying string, 1st word of buffer contains result length */
13658             rstr[rslt->length] = '\0';
13659
13660              /* Find where all the components are */
13661              v_sts = vms_split_path
13662                        (rstr,
13663                         &v_spec,
13664                         &v_len,
13665                         &r_spec,
13666                         &r_len,
13667                         &d_spec,
13668                         &d_len,
13669                         &n_spec,
13670                         &n_len,
13671                         &e_spec,
13672                         &e_len,
13673                         &vs_spec,
13674                         &vs_len);
13675
13676             /* If no version on input, truncate the version on output */
13677             if (!hasver && (vs_len > 0)) {
13678                 *vs_spec = '\0';
13679                 vs_len = 0;
13680             }
13681
13682             if (isunix) {
13683
13684                 /* In Unix report mode, remove the ".dir;1" from the name */
13685                 /* if it is a real directory */
13686                 if (decc_filename_unix_report || decc_efs_charset) {
13687                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13688                         Stat_t statbuf;
13689                         int ret_sts;
13690
13691                         ret_sts = flex_lstat(rstr, &statbuf);
13692                         if ((ret_sts == 0) &&
13693                             S_ISDIR(statbuf.st_mode)) {
13694                             e_len = 0;
13695                             e_spec[0] = 0;
13696                         }
13697                     }
13698                 }
13699
13700                 /* No version & a null extension on UNIX handling */
13701                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13702                     e_len = 0;
13703                     *e_spec = '\0';
13704                 }
13705             }
13706
13707             if (!decc_efs_case_preserve) {
13708                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13709             }
13710
13711             /* Find File treats a Null extension as return all extensions */
13712             /* This is contrary to Perl expectations */
13713
13714             if (wildstar || wildquery || vms_old_glob) {
13715                 /* really need to see if the returned file name matched */
13716                 /* but for now will assume that it matches */
13717                 valid_find = 1;
13718             } else {
13719                 /* Exact Match requested */
13720                 /* How are directories handled? - like a file */
13721                 if ((e_len == we_len) && (n_len == wn_len)) {
13722                     int t1;
13723                     t1 = e_len;
13724                     if (t1 > 0)
13725                         t1 = strncmp(e_spec, we_spec, e_len);
13726                     if (t1 == 0) {
13727                        t1 = n_len;
13728                        if (t1 > 0)
13729                            t1 = strncmp(n_spec, we_spec, n_len);
13730                        if (t1 == 0)
13731                            valid_find = 1;
13732                     }
13733                 }
13734             }
13735
13736             if (valid_find) {
13737                 found++;
13738
13739                 if (hasdir) {
13740                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13741                     begin = rstr;
13742                 }
13743                 else {
13744                     /* Start with the name */
13745                     begin = n_spec;
13746                 }
13747                 strcat(begin,"\n");
13748                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13749             }
13750         }
13751         if (cxt) (void)lib$find_file_end(&cxt);
13752
13753         if (!found) {
13754             /* Be POSIXish: return the input pattern when no matches */
13755             strcpy(rstr,SvPVX(tmpglob));
13756             strcat(rstr,"\n");
13757             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13758         }
13759
13760         if (ok && sts != RMS$_NMF &&
13761             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13762         if (!ok) {
13763             if (!(sts & 1)) {
13764                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13765             }
13766             PerlIO_close(tmpfp);
13767             fp = NULL;
13768         }
13769         else {
13770             PerlIO_rewind(tmpfp);
13771             IoTYPE(io) = IoTYPE_RDONLY;
13772             IoIFP(io) = fp = tmpfp;
13773             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13774         }
13775     }
13776     Safefree(vmsspec);
13777     Safefree(rslt);
13778     return fp;
13779 }
13780
13781
13782 static char *
13783 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13784                    int *utf8_fl);
13785
13786 void
13787 unixrealpath_fromperl(pTHX_ CV *cv)
13788 {
13789     dXSARGS;
13790     char *fspec, *rslt_spec, *rslt;
13791     STRLEN n_a;
13792
13793     if (!items || items != 1)
13794         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13795
13796     fspec = SvPV(ST(0),n_a);
13797     if (!fspec || !*fspec) XSRETURN_UNDEF;
13798
13799     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13800     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13801
13802     ST(0) = sv_newmortal();
13803     if (rslt != NULL)
13804         sv_usepvn(ST(0),rslt,strlen(rslt));
13805     else
13806         Safefree(rslt_spec);
13807         XSRETURN(1);
13808 }
13809
13810 static char *
13811 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13812                    int *utf8_fl);
13813
13814 void
13815 vmsrealpath_fromperl(pTHX_ CV *cv)
13816 {
13817     dXSARGS;
13818     char *fspec, *rslt_spec, *rslt;
13819     STRLEN n_a;
13820
13821     if (!items || items != 1)
13822         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13823
13824     fspec = SvPV(ST(0),n_a);
13825     if (!fspec || !*fspec) XSRETURN_UNDEF;
13826
13827     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13828     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13829
13830     ST(0) = sv_newmortal();
13831     if (rslt != NULL)
13832         sv_usepvn(ST(0),rslt,strlen(rslt));
13833     else
13834         Safefree(rslt_spec);
13835         XSRETURN(1);
13836 }
13837
13838 #ifdef HAS_SYMLINK
13839 /*
13840  * A thin wrapper around decc$symlink to make sure we follow the
13841  * standard and do not create a symlink with a zero-length name.
13842  *
13843  * Also in ODS-2 mode, existing tests assume that the link target
13844  * will be converted to UNIX format.
13845  */
13846 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13847 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
13848   if (!link_name || !*link_name) {
13849     SETERRNO(ENOENT, SS$_NOSUCHFILE);
13850     return -1;
13851   }
13852
13853   if (decc_efs_charset) {
13854       return symlink(contents, link_name);
13855   } else {
13856       int sts;
13857       char * utarget;
13858
13859       /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
13860       /* because in order to work, the symlink target must be in UNIX format */
13861
13862       /* As symbolic links can hold things other than files, we will only do */
13863       /* the conversion in in ODS-2 mode */
13864
13865       Newx(utarget, VMS_MAXRSS + 1, char);
13866       if (int_tounixspec(contents, utarget, NULL) == NULL) {
13867
13868           /* This should not fail, as an untranslatable filename */
13869           /* should be passed through */
13870           utarget = (char *)contents;
13871       }
13872       sts = symlink(utarget, link_name);
13873       Safefree(utarget);
13874       return sts;
13875   }
13876
13877 }
13878 /*}}}*/
13879
13880 #endif /* HAS_SYMLINK */
13881
13882 int do_vms_case_tolerant(void);
13883
13884 void
13885 case_tolerant_process_fromperl(pTHX_ CV *cv)
13886 {
13887   dXSARGS;
13888   ST(0) = boolSV(do_vms_case_tolerant());
13889   XSRETURN(1);
13890 }
13891
13892 #ifdef USE_ITHREADS
13893
13894 void
13895 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13896                           struct interp_intern *dst)
13897 {
13898     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13899
13900     memcpy(dst,src,sizeof(struct interp_intern));
13901 }
13902
13903 #endif
13904
13905 void
13906 Perl_sys_intern_clear(pTHX)
13907 {
13908 }
13909
13910 void
13911 Perl_sys_intern_init(pTHX)
13912 {
13913     unsigned int ix = RAND_MAX;
13914     double x;
13915
13916     VMSISH_HUSHED = 0;
13917
13918     MY_POSIX_EXIT = vms_posix_exit;
13919
13920     x = (float)ix;
13921     MY_INV_RAND_MAX = 1./x;
13922 }
13923
13924 void
13925 init_os_extras(void)
13926 {
13927   dTHX;
13928   char* file = __FILE__;
13929   if (decc_disable_to_vms_logname_translation) {
13930     no_translate_barewords = TRUE;
13931   } else {
13932     no_translate_barewords = FALSE;
13933   }
13934
13935   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13936   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13937   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13938   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13939   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13940   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13941   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13942   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13943   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13944   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13945   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13946   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13947   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13948   newXSproto("VMS::Filespec::case_tolerant_process",
13949       case_tolerant_process_fromperl,file,"");
13950
13951   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13952
13953   return;
13954 }
13955
13956 #if __CRTL_VER == 80200000
13957 /* This missed getting in to the DECC SDK for 8.2 */
13958 char *realpath(const char *file_name, char * resolved_name, ...);
13959 #endif
13960
13961 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13962 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13963  * The perl fallback routine to provide realpath() is not as efficient
13964  * on OpenVMS.
13965  */
13966
13967 /* Hack, use old stat() as fastest way of getting ino_t and device */
13968 int decc$stat(const char *name, void * statbuf);
13969
13970
13971 /* Realpath is fragile.  In 8.3 it does not work if the feature
13972  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13973  * links are implemented in RMS, not the CRTL. It also can fail if the
13974  * user does not have read/execute access to some of the directories.
13975  * So in order for Do What I Mean mode to work, if realpath() fails,
13976  * fall back to looking up the filename by the device name and FID.
13977  */
13978
13979 int vms_fid_to_name(char * outname, int outlen, const char * name)
13980 {
13981 struct statbuf_t {
13982     char           * st_dev;
13983     unsigned short st_ino[3];
13984     unsigned short padw;
13985     unsigned long  padl[30];  /* plenty of room */
13986 } statbuf;
13987 int sts;
13988 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13989 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13990
13991     sts = decc$stat(name, &statbuf);
13992     if (sts == 0) {
13993
13994         dvidsc.dsc$a_pointer=statbuf.st_dev;
13995        dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13996
13997         specdsc.dsc$a_pointer = outname;
13998         specdsc.dsc$w_length = outlen-1;
13999
14000        sts = lib$fid_to_name
14001             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
14002        if ($VMS_STATUS_SUCCESS(sts)) {
14003             outname[specdsc.dsc$w_length] = 0;
14004             return 0;
14005         }
14006     }
14007     return sts;
14008 }
14009
14010
14011
14012 static char *
14013 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
14014                    int *utf8_fl)
14015 {
14016     char * rslt = NULL;
14017
14018 #ifdef HAS_SYMLINK
14019     if (decc_posix_compliant_pathnames > 0 ) {
14020         /* realpath currently only works if posix compliant pathnames are
14021          * enabled.  It may start working when they are not, but in that
14022          * case we still want the fallback behavior for backwards compatibility
14023          */
14024         rslt = realpath(filespec, outbuf);
14025     }
14026 #endif
14027
14028     if (rslt == NULL) {
14029         char * vms_spec;
14030         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14031         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14032         int file_len;
14033
14034         /* Fall back to fid_to_name */
14035
14036         Newx(vms_spec, VMS_MAXRSS + 1, char);
14037
14038         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
14039         if (sts == 0) {
14040
14041
14042             /* Now need to trim the version off */
14043             sts = vms_split_path
14044                   (vms_spec,
14045                    &v_spec,
14046                    &v_len,
14047                    &r_spec,
14048                    &r_len,
14049                    &d_spec,
14050                    &d_len,
14051                    &n_spec,
14052                    &n_len,
14053                    &e_spec,
14054                    &e_len,
14055                    &vs_spec,
14056                    &vs_len);
14057
14058
14059                 if (sts == 0) {
14060                     int haslower = 0;
14061                     const char *cp;
14062
14063                     /* Trim off the version */
14064                     int file_len = v_len + r_len + d_len + n_len + e_len;
14065                     vms_spec[file_len] = 0;
14066
14067                     /* The result is expected to be in UNIX format */
14068                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
14069
14070                     /* Downcase if input had any lower case letters and
14071                      * case preservation is not in effect.
14072                      */
14073                     if (!decc_efs_case_preserve) {
14074                         for (cp = filespec; *cp; cp++)
14075                             if (islower(*cp)) { haslower = 1; break; }
14076
14077                         if (haslower) __mystrtolower(rslt);
14078                     }
14079                 }
14080         } else {
14081
14082             /* Now for some hacks to deal with backwards and forward */
14083             /* compatibilty */
14084             if (!decc_efs_charset) {
14085
14086                 /* 1. ODS-2 mode wants to do a syntax only translation */
14087                 rslt = int_rmsexpand(filespec, outbuf,
14088                                     NULL, 0, NULL, utf8_fl);
14089
14090             } else {
14091                 if (decc_filename_unix_report) {
14092                     char * dir_name;
14093                     char * vms_dir_name;
14094                     char * file_name;
14095
14096                     /* 2. ODS-5 / UNIX report mode should return a failure */
14097                     /*    if the parent directory also does not exist */
14098                     /*    Otherwise, get the real path for the parent */
14099                     /*    and add the child to it.
14100
14101                     /* basename / dirname only available for VMS 7.0+ */
14102                     /* So we may need to implement them as common routines */
14103
14104                     Newx(dir_name, VMS_MAXRSS + 1, char);
14105                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
14106                     dir_name[0] = '\0';
14107                     file_name = NULL;
14108
14109                     /* First try a VMS parse */
14110                     sts = vms_split_path
14111                           (filespec,
14112                            &v_spec,
14113                            &v_len,
14114                            &r_spec,
14115                            &r_len,
14116                            &d_spec,
14117                            &d_len,
14118                            &n_spec,
14119                            &n_len,
14120                            &e_spec,
14121                            &e_len,
14122                            &vs_spec,
14123                            &vs_len);
14124
14125                     if (sts == 0) {
14126                         /* This is VMS */
14127
14128                         int dir_len = v_len + r_len + d_len + n_len;
14129                         if (dir_len > 0) {
14130                            strncpy(dir_name, filespec, dir_len);
14131                            dir_name[dir_len] = '\0';
14132                            file_name = (char *)&filespec[dir_len + 1];
14133                         }
14134                     } else {
14135                         /* This must be UNIX */
14136                         char * tchar;
14137
14138                         tchar = strrchr(filespec, '/');
14139
14140                         if (tchar != NULL) {
14141                             int dir_len = tchar - filespec;
14142                             strncpy(dir_name, filespec, dir_len);
14143                             dir_name[dir_len] = '\0';
14144                             file_name = (char *) &filespec[dir_len + 1];
14145                         }
14146                     }
14147
14148                     /* Dir name is defaulted */
14149                     if (dir_name[0] == 0) {
14150                         dir_name[0] = '.';
14151                         dir_name[1] = '\0';
14152                     }
14153
14154                     /* Need realpath for the directory */
14155                     sts = vms_fid_to_name(vms_dir_name,
14156                                           VMS_MAXRSS + 1,
14157                                           dir_name);
14158
14159                     if (sts == 0) {
14160                         /* Now need to pathify it.
14161                         char *tdir = int_pathify_dirspec(vms_dir_name,
14162                                                          outbuf);
14163
14164                         /* And now add the original filespec to it */
14165                         if (file_name != NULL) {
14166                             strcat(outbuf, file_name);
14167                         }
14168                         return outbuf;
14169                     }
14170                     Safefree(vms_dir_name);
14171                     Safefree(dir_name);
14172                 }
14173             }
14174         }
14175         Safefree(vms_spec);
14176     }
14177     return rslt;
14178 }
14179
14180 static char *
14181 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
14182                    int *utf8_fl)
14183 {
14184     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14185     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14186     int file_len;
14187
14188     /* Fall back to fid_to_name */
14189
14190     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
14191     if (sts != 0) {
14192         return NULL;
14193     }
14194     else {
14195
14196
14197         /* Now need to trim the version off */
14198         sts = vms_split_path
14199                   (outbuf,
14200                    &v_spec,
14201                    &v_len,
14202                    &r_spec,
14203                    &r_len,
14204                    &d_spec,
14205                    &d_len,
14206                    &n_spec,
14207                    &n_len,
14208                    &e_spec,
14209                    &e_len,
14210                    &vs_spec,
14211                    &vs_len);
14212
14213
14214         if (sts == 0) {
14215             int haslower = 0;
14216             const char *cp;
14217
14218             /* Trim off the version */
14219             int file_len = v_len + r_len + d_len + n_len + e_len;
14220             outbuf[file_len] = 0;
14221
14222             /* Downcase if input had any lower case letters and
14223              * case preservation is not in effect.
14224              */
14225             if (!decc_efs_case_preserve) {
14226                 for (cp = filespec; *cp; cp++)
14227                     if (islower(*cp)) { haslower = 1; break; }
14228
14229                 if (haslower) __mystrtolower(outbuf);
14230             }
14231         }
14232     }
14233     return outbuf;
14234 }
14235
14236
14237 /*}}}*/
14238 /* External entry points */
14239 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14240 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
14241
14242 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14243 { return do_vms_realname(filespec, outbuf, utf8_fl); }
14244
14245 /* case_tolerant */
14246
14247 /*{{{int do_vms_case_tolerant(void)*/
14248 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
14249  * controlled by a process setting.
14250  */
14251 int do_vms_case_tolerant(void)
14252 {
14253     return vms_process_case_tolerant;
14254 }
14255 /*}}}*/
14256 /* External entry points */
14257 #if __CRTL_VER >= 70301000 && !defined(__VAX)
14258 int Perl_vms_case_tolerant(void)
14259 { return do_vms_case_tolerant(); }
14260 #else
14261 int Perl_vms_case_tolerant(void)
14262 { return vms_process_case_tolerant; }
14263 #endif
14264
14265
14266  /* Start of DECC RTL Feature handling */
14267
14268 static int sys_trnlnm
14269    (const char * logname,
14270     char * value,
14271     int value_len)
14272 {
14273     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
14274     const unsigned long attr = LNM$M_CASE_BLIND;
14275     struct dsc$descriptor_s name_dsc;
14276     int status;
14277     unsigned short result;
14278     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
14279                                 {0, 0, 0, 0}};
14280
14281     name_dsc.dsc$w_length = strlen(logname);
14282     name_dsc.dsc$a_pointer = (char *)logname;
14283     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14284     name_dsc.dsc$b_class = DSC$K_CLASS_S;
14285
14286     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
14287
14288     if ($VMS_STATUS_SUCCESS(status)) {
14289
14290          /* Null terminate and return the string */
14291         /*--------------------------------------*/
14292         value[result] = 0;
14293     }
14294
14295     return status;
14296 }
14297
14298 static int sys_crelnm
14299    (const char * logname,
14300     const char * value)
14301 {
14302     int ret_val;
14303     const char * proc_table = "LNM$PROCESS_TABLE";
14304     struct dsc$descriptor_s proc_table_dsc;
14305     struct dsc$descriptor_s logname_dsc;
14306     struct itmlst_3 item_list[2];
14307
14308     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
14309     proc_table_dsc.dsc$w_length = strlen(proc_table);
14310     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14311     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
14312
14313     logname_dsc.dsc$a_pointer = (char *) logname;
14314     logname_dsc.dsc$w_length = strlen(logname);
14315     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14316     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
14317
14318     item_list[0].buflen = strlen(value);
14319     item_list[0].itmcode = LNM$_STRING;
14320     item_list[0].bufadr = (char *)value;
14321     item_list[0].retlen = NULL;
14322
14323     item_list[1].buflen = 0;
14324     item_list[1].itmcode = 0;
14325
14326     ret_val = sys$crelnm
14327                        (NULL,
14328                         (const struct dsc$descriptor_s *)&proc_table_dsc,
14329                         (const struct dsc$descriptor_s *)&logname_dsc,
14330                         NULL,
14331                         (const struct item_list_3 *) item_list);
14332
14333     return ret_val;
14334 }
14335
14336 /* C RTL Feature settings */
14337
14338 static int set_features
14339    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
14340     int (* cli_routine)(void),  /* Not documented */
14341     void *image_info)           /* Not documented */
14342 {
14343     int status;
14344     int s;
14345     char* str;
14346     char val_str[10];
14347 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
14348     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
14349     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
14350     unsigned long case_perm;
14351     unsigned long case_image;
14352 #endif
14353
14354     /* Allow an exception to bring Perl into the VMS debugger */
14355     vms_debug_on_exception = 0;
14356     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
14357     if ($VMS_STATUS_SUCCESS(status)) {
14358        val_str[0] = _toupper(val_str[0]);
14359        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14360          vms_debug_on_exception = 1;
14361        else
14362          vms_debug_on_exception = 0;
14363     }
14364
14365     /* Debug unix/vms file translation routines */
14366     vms_debug_fileify = 0;
14367     status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14368     if ($VMS_STATUS_SUCCESS(status)) {
14369         val_str[0] = _toupper(val_str[0]);
14370         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14371             vms_debug_fileify = 1;
14372         else
14373             vms_debug_fileify = 0;
14374     }
14375
14376
14377     /* Historically PERL has been doing vmsify / stat differently than */
14378     /* the CRTL.  In particular, under some conditions the CRTL will   */
14379     /* remove some illegal characters like spaces from filenames       */
14380     /* resulting in some differences.  The stat()/lstat() wrapper has  */
14381     /* been reporting such file names as invalid and fails to stat them */
14382     /* fixing this bug so that stat()/lstat() accept these like the     */
14383     /* CRTL does will result in several tests failing.                  */
14384     /* This should really be fixed, but for now, set up a feature to    */
14385     /* enable it so that the impact can be studied.                     */
14386     vms_bug_stat_filename = 0;
14387     status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14388     if ($VMS_STATUS_SUCCESS(status)) {
14389         val_str[0] = _toupper(val_str[0]);
14390         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14391             vms_bug_stat_filename = 1;
14392         else
14393             vms_bug_stat_filename = 0;
14394     }
14395
14396
14397     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14398     vms_vtf7_filenames = 0;
14399     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14400     if ($VMS_STATUS_SUCCESS(status)) {
14401        val_str[0] = _toupper(val_str[0]);
14402        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14403          vms_vtf7_filenames = 1;
14404        else
14405          vms_vtf7_filenames = 0;
14406     }
14407
14408     /* unlink all versions on unlink() or rename() */
14409     vms_unlink_all_versions = 0;
14410     status = sys_trnlnm
14411         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14412     if ($VMS_STATUS_SUCCESS(status)) {
14413        val_str[0] = _toupper(val_str[0]);
14414        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14415          vms_unlink_all_versions = 1;
14416        else
14417          vms_unlink_all_versions = 0;
14418     }
14419
14420     /* Dectect running under GNV Bash or other UNIX like shell */
14421 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14422     gnv_unix_shell = 0;
14423     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14424     if ($VMS_STATUS_SUCCESS(status)) {
14425          gnv_unix_shell = 1;
14426          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14427          set_feature_default("DECC$EFS_CHARSET", 1);
14428          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14429          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14430          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14431          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14432          vms_unlink_all_versions = 1;
14433          vms_posix_exit = 1;
14434     }
14435 #endif
14436
14437     /* hacks to see if known bugs are still present for testing */
14438
14439     /* PCP mode requires creating /dev/null special device file */
14440     decc_bug_devnull = 0;
14441     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14442     if ($VMS_STATUS_SUCCESS(status)) {
14443        val_str[0] = _toupper(val_str[0]);
14444        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14445           decc_bug_devnull = 1;
14446        else
14447           decc_bug_devnull = 0;
14448     }
14449
14450     /* UNIX directory names with no paths are broken in a lot of places */
14451     decc_dir_barename = 1;
14452     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14453     if ($VMS_STATUS_SUCCESS(status)) {
14454       val_str[0] = _toupper(val_str[0]);
14455       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14456         decc_dir_barename = 1;
14457       else
14458         decc_dir_barename = 0;
14459     }
14460
14461 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14462     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14463     if (s >= 0) {
14464         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14465         if (decc_disable_to_vms_logname_translation < 0)
14466             decc_disable_to_vms_logname_translation = 0;
14467     }
14468
14469     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14470     if (s >= 0) {
14471         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14472         if (decc_efs_case_preserve < 0)
14473             decc_efs_case_preserve = 0;
14474     }
14475
14476     s = decc$feature_get_index("DECC$EFS_CHARSET");
14477     decc_efs_charset_index = s;
14478     if (s >= 0) {
14479         decc_efs_charset = decc$feature_get_value(s, 1);
14480         if (decc_efs_charset < 0)
14481             decc_efs_charset = 0;
14482     }
14483
14484     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14485     if (s >= 0) {
14486         decc_filename_unix_report = decc$feature_get_value(s, 1);
14487         if (decc_filename_unix_report > 0) {
14488             decc_filename_unix_report = 1;
14489             vms_posix_exit = 1;
14490         }
14491         else
14492             decc_filename_unix_report = 0;
14493     }
14494
14495     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14496     if (s >= 0) {
14497         decc_filename_unix_only = decc$feature_get_value(s, 1);
14498         if (decc_filename_unix_only > 0) {
14499             decc_filename_unix_only = 1;
14500         }
14501         else {
14502             decc_filename_unix_only = 0;
14503         }
14504     }
14505
14506     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14507     if (s >= 0) {
14508         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14509         if (decc_filename_unix_no_version < 0)
14510             decc_filename_unix_no_version = 0;
14511     }
14512
14513     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14514     if (s >= 0) {
14515         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14516         if (decc_readdir_dropdotnotype < 0)
14517             decc_readdir_dropdotnotype = 0;
14518     }
14519
14520 #if __CRTL_VER >= 80200000
14521     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14522     if (s >= 0) {
14523         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14524         if (decc_posix_compliant_pathnames < 0)
14525             decc_posix_compliant_pathnames = 0;
14526         if (decc_posix_compliant_pathnames > 4)
14527             decc_posix_compliant_pathnames = 0;
14528     }
14529
14530 #endif
14531 #else
14532     status = sys_trnlnm
14533         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14534     if ($VMS_STATUS_SUCCESS(status)) {
14535         val_str[0] = _toupper(val_str[0]);
14536         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14537            decc_disable_to_vms_logname_translation = 1;
14538         }
14539     }
14540
14541 #ifndef __VAX
14542     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14543     if ($VMS_STATUS_SUCCESS(status)) {
14544         val_str[0] = _toupper(val_str[0]);
14545         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14546            decc_efs_case_preserve = 1;
14547         }
14548     }
14549 #endif
14550
14551     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14552     if ($VMS_STATUS_SUCCESS(status)) {
14553         val_str[0] = _toupper(val_str[0]);
14554         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14555            decc_filename_unix_report = 1;
14556         }
14557     }
14558     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14559     if ($VMS_STATUS_SUCCESS(status)) {
14560         val_str[0] = _toupper(val_str[0]);
14561         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14562            decc_filename_unix_only = 1;
14563            decc_filename_unix_report = 1;
14564         }
14565     }
14566     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14567     if ($VMS_STATUS_SUCCESS(status)) {
14568         val_str[0] = _toupper(val_str[0]);
14569         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14570            decc_filename_unix_no_version = 1;
14571         }
14572     }
14573     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14574     if ($VMS_STATUS_SUCCESS(status)) {
14575         val_str[0] = _toupper(val_str[0]);
14576         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14577            decc_readdir_dropdotnotype = 1;
14578         }
14579     }
14580 #endif
14581
14582 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14583
14584      /* Report true case tolerance */
14585     /*----------------------------*/
14586     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14587     if (!$VMS_STATUS_SUCCESS(status))
14588         case_perm = PPROP$K_CASE_BLIND;
14589     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14590     if (!$VMS_STATUS_SUCCESS(status))
14591         case_image = PPROP$K_CASE_BLIND;
14592     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14593         (case_image == PPROP$K_CASE_SENSITIVE))
14594         vms_process_case_tolerant = 0;
14595
14596 #endif
14597
14598     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14599     /* for strict backward compatibilty */
14600     status = sys_trnlnm
14601         ("PERL_VMS_POSIX_EXIT", 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_posix_exit = 1;
14606        else
14607          vms_posix_exit = 0;
14608     }
14609
14610
14611     /* CRTL can be initialized past this point, but not before. */
14612 /*    DECC$CRTL_INIT(); */
14613
14614     return SS$_NORMAL;
14615 }
14616
14617 #ifdef __DECC
14618 #pragma nostandard
14619 #pragma extern_model save
14620 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14621         const __align (LONGWORD) int spare[8] = {0};
14622
14623 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14624 #if __DECC_VER >= 60560002
14625 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14626 #else
14627 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14628 #endif
14629 #endif /* __DECC */
14630
14631 const long vms_cc_features = (const long)set_features;
14632
14633 /*
14634 ** Force a reference to LIB$INITIALIZE to ensure it
14635 ** exists in the image.
14636 */
14637 int lib$initialize(void);
14638 #ifdef __DECC
14639 #pragma extern_model strict_refdef
14640 #endif
14641     int lib_init_ref = (int) lib$initialize;
14642
14643 #ifdef __DECC
14644 #pragma extern_model restore
14645 #pragma standard
14646 #endif
14647
14648 /*  End of vms.c */