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 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
 308
 309 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 310 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 311
 312 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 313  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 314  * the Perl facility.
 315  */
 316 #define PERL_LNM_MAX_ITER 10
 317
 318   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 319 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 320 #define MAX_DCL_SYMBOL          (8192)
 321 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 322 #else
 323 #define MAX_DCL_SYMBOL          (1024)
 324 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 325 #endif
 326
 327 static char *__mystrtolower(char *str)
 328 {
 329   if (str) for (; *str; ++str) *str= tolower(*str);
 330   return str;
 331 }
 332
 333 static struct dsc$descriptor_s fildevdsc =
 334   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 335 static struct dsc$descriptor_s crtlenvdsc =
 336   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 337 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 338 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 339 static struct dsc$descriptor_s **env_tables = defenv;
 340 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 341
 342 /* True if we shouldn't treat barewords as logicals during directory */
 343 /* munching */
 344 static int no_translate_barewords;
 345
 346 #ifndef RTL_USES_UTC
 347 static int tz_updated = 1;
 348 #endif
 349
 350 /* DECC Features that may need to affect how Perl interprets
 351  * displays filename information
 352  */
 353 static int decc_disable_to_vms_logname_translation = 1;
 354 static int decc_disable_posix_root = 1;
 355 int decc_efs_case_preserve = 0;
 356 static int decc_efs_charset = 0;
 357 static int decc_efs_charset_index = -1;
 358 static int decc_filename_unix_no_version = 0;
 359 static int decc_filename_unix_only = 0;
 360 int decc_filename_unix_report = 0;
 361 int decc_posix_compliant_pathnames = 0;
 362 int decc_readdir_dropdotnotype = 0;
 363 static int vms_process_case_tolerant = 1;
 364 int vms_vtf7_filenames = 0;
 365 int gnv_unix_shell = 0;
 366 static int vms_unlink_all_versions = 0;
 367 static int vms_posix_exit = 0;
 368
 369 /* bug workarounds if needed */
 370 int decc_bug_devnull = 1;
 371 int decc_dir_barename = 0;
 372 int vms_bug_stat_filename = 0;
 373
 374 static int vms_debug_on_exception = 0;
 375 static int vms_debug_fileify = 0;
 376
 377 /* Simple logical name translation */
 378 static int simple_trnlnm
 379    (const char * logname,
 380     char * value,
 381     int value_len)
 382 {
 383     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
 384     const unsigned long attr = LNM$M_CASE_BLIND;
 385     struct dsc$descriptor_s name_dsc;
 386     int status;
 387     unsigned short result;
 388     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
 389                                 {0, 0, 0, 0}};
 390
 391     name_dsc.dsc$w_length = strlen(logname);
 392     name_dsc.dsc$a_pointer = (char *)logname;
 393     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
 394     name_dsc.dsc$b_class = DSC$K_CLASS_S;
 395
 396     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
 397
 398     if ($VMS_STATUS_SUCCESS(status)) {
 399
 400          /* Null terminate and return the string */
 401         /*--------------------------------------*/
 402         value[result] = 0;
 403         return result;
 404     }
 405
 406     return 0;
 407 }
 408
 409
 410 /* Is this a UNIX file specification?
 411  *   No longer a simple check with EFS file specs
 412  *   For now, not a full check, but need to
 413  *   handle POSIX ^UP^ specifications
 414  *   Fixing to handle ^/ cases would require
 415  *   changes to many other conversion routines.
 416  */
 417
 418 static int is_unix_filespec(const char *path)
 419 {
 420 int ret_val;
 421 const char * pch1;
 422
 423     ret_val = 0;
 424     if (strncmp(path,"\"^UP^",5) != 0) {
 425         pch1 = strchr(path, '/');
 426         if (pch1 != NULL)
 427             ret_val = 1;
 428         else {
 429
 430             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 431             if (decc_filename_unix_report || decc_filename_unix_only) {
 432             if (strcmp(path,".") == 0)
 433                 ret_val = 1;
 434             }
 435         }
 436     }
 437     return ret_val;
 438 }
 439
 440 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 441  */
 442
 443 static void ucs2_to_vtf7
 444    (char *outspec,
 445     unsigned long ucs2_char,
 446     int * output_cnt)
 447 {
 448 unsigned char * ucs_ptr;
 449 int hex;
 450
 451     ucs_ptr = (unsigned char *)&ucs2_char;
 452
 453     outspec[0] = '^';
 454     outspec[1] = 'U';
 455     hex = (ucs_ptr[1] >> 4) & 0xf;
 456     if (hex < 0xA)
 457         outspec[2] = hex + '0';
 458     else
 459         outspec[2] = (hex - 9) + 'A';
 460     hex = ucs_ptr[1] & 0xF;
 461     if (hex < 0xA)
 462         outspec[3] = hex + '0';
 463     else {
 464         outspec[3] = (hex - 9) + 'A';
 465     }
 466     hex = (ucs_ptr[0] >> 4) & 0xf;
 467     if (hex < 0xA)
 468         outspec[4] = hex + '0';
 469     else
 470         outspec[4] = (hex - 9) + 'A';
 471     hex = ucs_ptr[1] & 0xF;
 472     if (hex < 0xA)
 473         outspec[5] = hex + '0';
 474     else {
 475         outspec[5] = (hex - 9) + 'A';
 476     }
 477     *output_cnt = 6;
 478 }
 479
 480
 481 /* This handles the conversion of a UNIX extended character set to a ^
 482  * escaped VMS character.
 483  * in a UNIX file specification.
 484  *
 485  * The output count variable contains the number of characters added
 486  * to the output string.
 487  *
 488  * The return value is the number of characters read from the input string
 489  */
 490 static int copy_expand_unix_filename_escape
 491   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 492 {
 493 int count;
 494 int scnt;
 495 int utf8_flag;
 496
 497     utf8_flag = 0;
 498     if (utf8_fl)
 499       utf8_flag = *utf8_fl;
 500
 501     count = 0;
 502     *output_cnt = 0;
 503     if (*inspec >= 0x80) {
 504         if (utf8_fl && vms_vtf7_filenames) {
 505         unsigned long ucs_char;
 506
 507             ucs_char = 0;
 508
 509             if ((*inspec & 0xE0) == 0xC0) {
 510                 /* 2 byte Unicode */
 511                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 512                 if (ucs_char >= 0x80) {
 513                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 514                     return 2;
 515                 }
 516             } else if ((*inspec & 0xF0) == 0xE0) {
 517                 /* 3 byte Unicode */
 518                 ucs_char = ((inspec[0] & 0xF) << 12) +
 519                    ((inspec[1] & 0x3f) << 6) +
 520                    (inspec[2] & 0x3f);
 521                 if (ucs_char >= 0x800) {
 522                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 523                     return 3;
 524                 }
 525
 526 #if 0 /* I do not see longer sequences supported by OpenVMS */
 527       /* Maybe some one can fix this later */
 528             } else if ((*inspec & 0xF8) == 0xF0) {
 529                 /* 4 byte Unicode */
 530                 /* UCS-4 to UCS-2 */
 531             } else if ((*inspec & 0xFC) == 0xF8) {
 532                 /* 5 byte Unicode */
 533                 /* UCS-4 to UCS-2 */
 534             } else if ((*inspec & 0xFE) == 0xFC) {
 535                 /* 6 byte Unicode */
 536                 /* UCS-4 to UCS-2 */
 537 #endif
 538             }
 539         }
 540
 541         /* High bit set, but not a Unicode character! */
 542
 543         /* Non printing DECMCS or ISO Latin-1 character? */
 544         if (*inspec <= 0x9F) {
 545         int hex;
 546             outspec[0] = '^';
 547             outspec++;
 548             hex = (*inspec >> 4) & 0xF;
 549             if (hex < 0xA)
 550                 outspec[1] = hex + '0';
 551             else {
 552                 outspec[1] = (hex - 9) + 'A';
 553             }
 554             hex = *inspec & 0xF;
 555             if (hex < 0xA)
 556                 outspec[2] = hex + '0';
 557             else {
 558                 outspec[2] = (hex - 9) + 'A';
 559             }
 560             *output_cnt = 3;
 561             return 1;
 562         } else if (*inspec == 0xA0) {
 563             outspec[0] = '^';
 564             outspec[1] = 'A';
 565             outspec[2] = '0';
 566             *output_cnt = 3;
 567             return 1;
 568         } else if (*inspec == 0xFF) {
 569             outspec[0] = '^';
 570             outspec[1] = 'F';
 571             outspec[2] = 'F';
 572             *output_cnt = 3;
 573             return 1;
 574         }
 575         *outspec = *inspec;
 576         *output_cnt = 1;
 577         return 1;
 578     }
 579
 580     /* Is this a macro that needs to be passed through?
 581      * Macros start with $( and an alpha character, followed
 582      * by a string of alpha numeric characters ending with a )
 583      * If this does not match, then encode it as ODS-5.
 584      */
 585     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 586     int tcnt;
 587
 588         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 589             tcnt = 3;
 590             outspec[0] = inspec[0];
 591             outspec[1] = inspec[1];
 592             outspec[2] = inspec[2];
 593
 594             while(isalnum(inspec[tcnt]) ||
 595                   (inspec[2] == '.') || (inspec[2] == '_')) {
 596                 outspec[tcnt] = inspec[tcnt];
 597                 tcnt++;
 598             }
 599             if (inspec[tcnt] == ')') {
 600                 outspec[tcnt] = inspec[tcnt];
 601                 tcnt++;
 602                 *output_cnt = tcnt;
 603                 return tcnt;
 604             }
 605         }
 606     }
 607
 608     switch (*inspec) {
 609     case 0x7f:
 610         outspec[0] = '^';
 611         outspec[1] = '7';
 612         outspec[2] = 'F';
 613         *output_cnt = 3;
 614         return 1;
 615         break;
 616     case '?':
 617         if (decc_efs_charset == 0)
 618           outspec[0] = '%';
 619         else
 620           outspec[0] = '?';
 621         *output_cnt = 1;
 622         return 1;
 623         break;
 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     case '\\':
 644         /* Don't escape again if following character is
 645          * already something we escape.
 646          */
 647         if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
 648             *outspec = *inspec;
 649             *output_cnt = 1;
 650             return 1;
 651             break;
 652         }
 653         /* But otherwise fall through and escape it. */
 654     case '=':
 655         /* Assume that this is to be escaped */
 656         outspec[0] = '^';
 657         outspec[1] = *inspec;
 658         *output_cnt = 2;
 659         return 1;
 660         break;
 661     case ' ': /* space */
 662         /* Assume that this is to be escaped */
 663         outspec[0] = '^';
 664         outspec[1] = '_';
 665         *output_cnt = 2;
 666         return 1;
 667         break;
 668     default:
 669         *outspec = *inspec;
 670         *output_cnt = 1;
 671         return 1;
 672         break;
 673     }
 674 }
 675
 676
 677 /* This handles the expansion of a '^' prefix to the proper character
 678  * in a UNIX file specification.
 679  *
 680  * The output count variable contains the number of characters added
 681  * to the output string.
 682  *
 683  * The return value is the number of characters read from the input
 684  * string
 685  */
 686 static int copy_expand_vms_filename_escape
 687   (char *outspec, const char *inspec, int *output_cnt)
 688 {
 689 int count;
 690 int scnt;
 691
 692     count = 0;
 693     *output_cnt = 0;
 694     if (*inspec == '^') {
 695         inspec++;
 696         switch (*inspec) {
 697         /* Spaces and non-trailing dots should just be passed through,
 698          * but eat the escape character.
 699          */
 700         case '.':
 701             *outspec = *inspec;
 702             count += 2;
 703             (*output_cnt)++;
 704             break;
 705         case '_': /* space */
 706             *outspec = ' ';
 707             count += 2;
 708             (*output_cnt)++;
 709             break;
 710         case '^':
 711             /* Hmm.  Better leave the escape escaped. */
 712             outspec[0] = '^';
 713             outspec[1] = '^';
 714             count += 2;
 715             (*output_cnt) += 2;
 716             break;
 717         case 'U': /* Unicode - FIX-ME this is wrong. */
 718             inspec++;
 719             count++;
 720             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 721             if (scnt == 4) {
 722                 unsigned int c1, c2;
 723                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 724                 outspec[0] == c1 & 0xff;
 725                 outspec[1] == c2 & 0xff;
 726                 if (scnt > 1) {
 727                     (*output_cnt) += 2;
 728                     count += 4;
 729                 }
 730             }
 731             else {
 732                 /* Error - do best we can to continue */
 733                 *outspec = 'U';
 734                 outspec++;
 735                 (*output_cnt++);
 736                 *outspec = *inspec;
 737                 count++;
 738                 (*output_cnt++);
 739             }
 740             break;
 741         default:
 742             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 743             if (scnt == 2) {
 744                 /* Hex encoded */
 745                 unsigned int c1;
 746                 scnt = sscanf(inspec, "%2x", &c1);
 747                 outspec[0] = c1 & 0xff;
 748                 if (scnt > 0) {
 749                     (*output_cnt++);
 750                     count += 2;
 751                 }
 752             }
 753             else {
 754                 *outspec = *inspec;
 755                 count++;
 756                 (*output_cnt++);
 757             }
 758         }
 759     }
 760     else {
 761         *outspec = *inspec;
 762         count++;
 763         (*output_cnt)++;
 764     }
 765     return count;
 766 }
 767
 768 #ifdef sys$filescan
 769 #undef sys$filescan
 770 int sys$filescan
 771    (const struct dsc$descriptor_s * srcstr,
 772     struct filescan_itmlst_2 * valuelist,
 773     unsigned long * fldflags,
 774     struct dsc$descriptor_s *auxout,
 775     unsigned short * retlen);
 776 #endif
 777
 778 /* vms_split_path - Verify that the input file specification is a
 779  * VMS format file specification, and provide pointers to the components of
 780  * it.  With EFS format filenames, this is virtually the only way to
 781  * parse a VMS path specification into components.
 782  *
 783  * If the sum of the components do not add up to the length of the
 784  * string, then the passed file specification is probably a UNIX style
 785  * path.
 786  */
 787 static int vms_split_path
 788    (const char * path,
 789     char * * volume,
 790     int * vol_len,
 791     char * * root,
 792     int * root_len,
 793     char * * dir,
 794     int * dir_len,
 795     char * * name,
 796     int * name_len,
 797     char * * ext,
 798     int * ext_len,
 799     char * * version,
 800     int * ver_len)
 801 {
 802 struct dsc$descriptor path_desc;
 803 int status;
 804 unsigned long flags;
 805 int ret_stat;
 806 struct filescan_itmlst_2 item_list[9];
 807 const int filespec = 0;
 808 const int nodespec = 1;
 809 const int devspec = 2;
 810 const int rootspec = 3;
 811 const int dirspec = 4;
 812 const int namespec = 5;
 813 const int typespec = 6;
 814 const int verspec = 7;
 815
 816     /* Assume the worst for an easy exit */
 817     ret_stat = -1;
 818     *volume = NULL;
 819     *vol_len = 0;
 820     *root = NULL;
 821     *root_len = 0;
 822     *dir = NULL;
 823     *dir_len;
 824     *name = NULL;
 825     *name_len = 0;
 826     *ext = NULL;
 827     *ext_len = 0;
 828     *version = NULL;
 829     *ver_len = 0;
 830
 831     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 832     path_desc.dsc$w_length = strlen(path);
 833     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 834     path_desc.dsc$b_class = DSC$K_CLASS_S;
 835
 836     /* Get the total length, if it is shorter than the string passed
 837      * then this was probably not a VMS formatted file specification
 838      */
 839     item_list[filespec].itmcode = FSCN$_FILESPEC;
 840     item_list[filespec].length = 0;
 841     item_list[filespec].component = NULL;
 842
 843     /* If the node is present, then it gets considered as part of the
 844      * volume name to hopefully make things simple.
 845      */
 846     item_list[nodespec].itmcode = FSCN$_NODE;
 847     item_list[nodespec].length = 0;
 848     item_list[nodespec].component = NULL;
 849
 850     item_list[devspec].itmcode = FSCN$_DEVICE;
 851     item_list[devspec].length = 0;
 852     item_list[devspec].component = NULL;
 853
 854     /* root is a special case,  adding it to either the directory or
 855      * the device components will probalby complicate things for the
 856      * callers of this routine, so leave it separate.
 857      */
 858     item_list[rootspec].itmcode = FSCN$_ROOT;
 859     item_list[rootspec].length = 0;
 860     item_list[rootspec].component = NULL;
 861
 862     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 863     item_list[dirspec].length = 0;
 864     item_list[dirspec].component = NULL;
 865
 866     item_list[namespec].itmcode = FSCN$_NAME;
 867     item_list[namespec].length = 0;
 868     item_list[namespec].component = NULL;
 869
 870     item_list[typespec].itmcode = FSCN$_TYPE;
 871     item_list[typespec].length = 0;
 872     item_list[typespec].component = NULL;
 873
 874     item_list[verspec].itmcode = FSCN$_VERSION;
 875     item_list[verspec].length = 0;
 876     item_list[verspec].component = NULL;
 877
 878     item_list[8].itmcode = 0;
 879     item_list[8].length = 0;
 880     item_list[8].component = NULL;
 881
 882     status = sys$filescan
 883        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 884         &flags, NULL, NULL);
 885     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 886
 887     /* If we parsed it successfully these two lengths should be the same */
 888     if (path_desc.dsc$w_length != item_list[filespec].length)
 889         return ret_stat;
 890
 891     /* If we got here, then it is a VMS file specification */
 892     ret_stat = 0;
 893
 894     /* set the volume name */
 895     if (item_list[nodespec].length > 0) {
 896         *volume = item_list[nodespec].component;
 897         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 898     }
 899     else {
 900         *volume = item_list[devspec].component;
 901         *vol_len = item_list[devspec].length;
 902     }
 903
 904     *root = item_list[rootspec].component;
 905     *root_len = item_list[rootspec].length;
 906
 907     *dir = item_list[dirspec].component;
 908     *dir_len = item_list[dirspec].length;
 909
 910     /* Now fun with versions and EFS file specifications
 911      * The parser can not tell the difference when a "." is a version
 912      * delimiter or a part of the file specification.
 913      */
 914     if ((decc_efs_charset) &&
 915         (item_list[verspec].length > 0) &&
 916         (item_list[verspec].component[0] == '.')) {
 917         *name = item_list[namespec].component;
 918         *name_len = item_list[namespec].length + item_list[typespec].length;
 919         *ext = item_list[verspec].component;
 920         *ext_len = item_list[verspec].length;
 921         *version = NULL;
 922         *ver_len = 0;
 923     }
 924     else {
 925         *name = item_list[namespec].component;
 926         *name_len = item_list[namespec].length;
 927         *ext = item_list[typespec].component;
 928         *ext_len = item_list[typespec].length;
 929         *version = item_list[verspec].component;
 930         *ver_len = item_list[verspec].length;
 931     }
 932     return ret_stat;
 933 }
 934
 935 /* Routine to determine if the file specification ends with .dir */
 936 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
 937
 938     /* e_len must be 4, and version must be <= 2 characters */
 939     if (e_len != 4 || vs_len > 2)
 940         return 0;
 941
 942     /* If a version number is present, it needs to be one */
 943     if ((vs_len == 2) && (vs_spec[1] != '1'))
 944         return 0;
 945
 946     /* Look for the DIR on the extension */
 947     if (vms_process_case_tolerant) {
 948         if ((toupper(e_spec[1]) == 'D') &&
 949             (toupper(e_spec[2]) == 'I') &&
 950             (toupper(e_spec[3]) == 'R')) {
 951             return 1;
 952         }
 953     } else {
 954         /* Directory extensions are supposed to be in upper case only */
 955         /* I would not be surprised if this rule can not be enforced */
 956         /* if and when someone fully debugs the case sensitive mode */
 957         if ((e_spec[1] == 'D') &&
 958             (e_spec[2] == 'I') &&
 959             (e_spec[3] == 'R')) {
 960             return 1;
 961         }
 962     }
 963     return 0;
 964 }
 965
 966
 967 /* my_maxidx
 968  * Routine to retrieve the maximum equivalence index for an input
 969  * logical name.  Some calls to this routine have no knowledge if
 970  * the variable is a logical or not.  So on error we return a max
 971  * index of zero.
 972  */
 973 /*{{{int my_maxidx(const char *lnm) */
 974 static int
 975 my_maxidx(const char *lnm)
 976 {
 977     int status;
 978     int midx;
 979     int attr = LNM$M_CASE_BLIND;
 980     struct dsc$descriptor lnmdsc;
 981     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 982                                 {0, 0, 0, 0}};
 983
 984     lnmdsc.dsc$w_length = strlen(lnm);
 985     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 986     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 987     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 988
 989     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 990     if ((status & 1) == 0)
 991        midx = 0;
 992
 993     return (midx);
 994 }
 995 /*}}}*/
 996
 997 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 998 int
 999 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
1000   struct dsc$descriptor_s **tabvec, unsigned long int flags)
1001 {
1002     const char *cp1;
1003     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
1004     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
1005     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
1006     int midx;
1007     unsigned char acmode;
1008     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1009                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1010     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
1011                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
1012                                  {0, 0, 0, 0}};
1013     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1014 #if defined(PERL_IMPLICIT_CONTEXT)
1015     pTHX = NULL;
1016     if (PL_curinterp) {
1017       aTHX = PERL_GET_INTERP;
1018     } else {
1019       aTHX = NULL;
1020     }
1021 #endif
1022
1023     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
1024       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
1025     }
1026     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1027       *cp2 = _toupper(*cp1);
1028       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1029         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1030         return 0;
1031       }
1032     }
1033     lnmdsc.dsc$w_length = cp1 - lnm;
1034     lnmdsc.dsc$a_pointer = uplnm;
1035     uplnm[lnmdsc.dsc$w_length] = '\0';
1036     secure = flags & PERL__TRNENV_SECURE;
1037     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
1038     if (!tabvec || !*tabvec) tabvec = env_tables;
1039
1040     for (curtab = 0; tabvec[curtab]; curtab++) {
1041       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1042         if (!ivenv && !secure) {
1043           char *eq, *end;
1044           int i;
1045           if (!environ) {
1046             ivenv = 1;
1047 #if defined(PERL_IMPLICIT_CONTEXT)
1048             if (aTHX == NULL) {
1049                 fprintf(stderr,
1050                     "%%PERL-W-VMS_INIT Can't read CRTL environ\n");
1051             } else
1052 #endif
1053                 Perl_warn(aTHX_ "Can't read CRTL environ\n");
1054             continue;
1055           }
1056           retsts = SS$_NOLOGNAM;
1057           for (i = 0; environ[i]; i++) {
1058             if ((eq = strchr(environ[i],'=')) &&
1059                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
1060                 !strncmp(environ[i],uplnm,eq - environ[i])) {
1061               eq++;
1062               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
1063               if (!eqvlen) continue;
1064               retsts = SS$_NORMAL;
1065               break;
1066             }
1067           }
1068           if (retsts != SS$_NOLOGNAM) break;
1069         }
1070       }
1071       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1072                !str$case_blind_compare(&tmpdsc,&clisym)) {
1073         if (!ivsym && !secure) {
1074           unsigned short int deflen = LNM$C_NAMLENGTH;
1075           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1076           /* dynamic dsc to accomodate possible long value */
1077           _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
1078           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
1079           if (retsts & 1) {
1080             if (eqvlen > MAX_DCL_SYMBOL) {
1081               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
1082               eqvlen = MAX_DCL_SYMBOL;
1083               /* Special hack--we might be called before the interpreter's */
1084               /* fully initialized, in which case either thr or PL_curcop */
1085               /* might be bogus. We have to check, since ckWARN needs them */
1086               /* both to be valid if running threaded */
1087 #if defined(PERL_IMPLICIT_CONTEXT)
1088               if (aTHX == NULL) {
1089                   fprintf(stderr,
1090                      "%Perl-VMS-Init, Value of CLI symbol \"%s\" too long",lnm);
1091               } else
1092 #endif
1093                 if (ckWARN(WARN_MISC)) {
1094                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1095                 }
1096             }
1097             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1098           }
1099           _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1100           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1101           if (retsts == LIB$_NOSUCHSYM) continue;
1102           break;
1103         }
1104       }
1105       else if (!ivlnm) {
1106         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1107           midx = my_maxidx(lnm);
1108           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1109             lnmlst[1].bufadr = cp2;
1110             eqvlen = 0;
1111             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1112             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1113             if (retsts == SS$_NOLOGNAM) break;
1114             /* PPFs have a prefix */
1115             if (
1116 #if INTSIZE == 4
1117                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1118 #endif
1119                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1120                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1121                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1122                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1123                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1124               memmove(eqv,eqv+4,eqvlen-4);
1125               eqvlen -= 4;
1126             }
1127             cp2 += eqvlen;
1128             *cp2 = '\0';
1129           }
1130           if ((retsts == SS$_IVLOGNAM) ||
1131               (retsts == SS$_NOLOGNAM)) { continue; }
1132         }
1133         else {
1134           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1135           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1136           if (retsts == SS$_NOLOGNAM) continue;
1137           eqv[eqvlen] = '\0';
1138         }
1139         eqvlen = strlen(eqv);
1140         break;
1141       }
1142     }
1143     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1144     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1145              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1146              retsts == SS$_NOLOGNAM) {
1147       set_errno(EINVAL);  set_vaxc_errno(retsts);
1148     }
1149     else _ckvmssts_noperl(retsts);
1150     return 0;
1151 }  /* end of vmstrnenv */
1152 /*}}}*/
1153
1154 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1155 /* Define as a function so we can access statics. */
1156 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1157 {
1158     int flags = 0;
1159
1160 #if defined(PERL_IMPLICIT_CONTEXT)
1161     if (aTHX != NULL)
1162 #endif
1163 #ifdef SECURE_INTERNAL_GETENV
1164         flags = (PL_curinterp ? PL_tainting : will_taint) ?
1165                  PERL__TRNENV_SECURE : 0;
1166 #endif
1167
1168     return vmstrnenv(lnm, eqv, idx, fildev, flags);
1169 }
1170 /*}}}*/
1171
1172 /* my_getenv
1173  * Note: Uses Perl temp to store result so char * can be returned to
1174  * caller; this pointer will be invalidated at next Perl statement
1175  * transition.
1176  * We define this as a function rather than a macro in terms of my_getenv_len()
1177  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1178  * allocate SVs).
1179  */
1180 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1181 char *
1182 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1183 {
1184     const char *cp1;
1185     static char *__my_getenv_eqv = NULL;
1186     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1187     unsigned long int idx = 0;
1188     int trnsuccess, success, secure, saverr, savvmserr;
1189     int midx, flags;
1190     SV *tmpsv;
1191
1192     midx = my_maxidx(lnm) + 1;
1193
1194     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1195       /* Set up a temporary buffer for the return value; Perl will
1196        * clean it up at the next statement transition */
1197       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1198       if (!tmpsv) return NULL;
1199       eqv = SvPVX(tmpsv);
1200     }
1201     else {
1202       /* Assume no interpreter ==> single thread */
1203       if (__my_getenv_eqv != NULL) {
1204         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1205       }
1206       else {
1207         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1208       }
1209       eqv = __my_getenv_eqv;
1210     }
1211
1212     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1213     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1214       int len;
1215       getcwd(eqv,LNM$C_NAMLENGTH);
1216
1217       len = strlen(eqv);
1218
1219       /* Get rid of "000000/ in rooted filespecs */
1220       if (len > 7) {
1221         char * zeros;
1222         zeros = strstr(eqv, "/000000/");
1223         if (zeros != NULL) {
1224           int mlen;
1225           mlen = len - (zeros - eqv) - 7;
1226           memmove(zeros, &zeros[7], mlen);
1227           len = len - 7;
1228           eqv[len] = '\0';
1229         }
1230       }
1231       return eqv;
1232     }
1233     else {
1234       /* Impose security constraints only if tainting */
1235       if (sys) {
1236         /* Impose security constraints only if tainting */
1237         secure = PL_curinterp ? PL_tainting : will_taint;
1238         saverr = errno;  savvmserr = vaxc$errno;
1239       }
1240       else {
1241         secure = 0;
1242       }
1243
1244       flags =
1245 #ifdef SECURE_INTERNAL_GETENV
1246               secure ? PERL__TRNENV_SECURE : 0
1247 #else
1248               0
1249 #endif
1250       ;
1251
1252       /* For the getenv interface we combine all the equivalence names
1253        * of a search list logical into one value to acquire a maximum
1254        * value length of 255*128 (assuming %ENV is using logicals).
1255        */
1256       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1257
1258       /* If the name contains a semicolon-delimited index, parse it
1259        * off and make sure we only retrieve the equivalence name for
1260        * that index.  */
1261       if ((cp2 = strchr(lnm,';')) != NULL) {
1262         strcpy(uplnm,lnm);
1263         uplnm[cp2-lnm] = '\0';
1264         idx = strtoul(cp2+1,NULL,0);
1265         lnm = uplnm;
1266         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1267       }
1268
1269       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1270
1271       /* Discard NOLOGNAM on internal calls since we're often looking
1272        * for an optional name, and this "error" often shows up as the
1273        * (bogus) exit status for a die() call later on.  */
1274       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1275       return success ? eqv : NULL;
1276     }
1277
1278 }  /* end of my_getenv() */
1279 /*}}}*/
1280
1281
1282 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1283 char *
1284 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1285 {
1286     const char *cp1;
1287     char *buf, *cp2;
1288     unsigned long idx = 0;
1289     int midx, flags;
1290     static char *__my_getenv_len_eqv = NULL;
1291     int secure, saverr, savvmserr;
1292     SV *tmpsv;
1293
1294     midx = my_maxidx(lnm) + 1;
1295
1296     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1297       /* Set up a temporary buffer for the return value; Perl will
1298        * clean it up at the next statement transition */
1299       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1300       if (!tmpsv) return NULL;
1301       buf = SvPVX(tmpsv);
1302     }
1303     else {
1304       /* Assume no interpreter ==> single thread */
1305       if (__my_getenv_len_eqv != NULL) {
1306         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1307       }
1308       else {
1309         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1310       }
1311       buf = __my_getenv_len_eqv;
1312     }
1313
1314     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1315     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1316     char * zeros;
1317
1318       getcwd(buf,LNM$C_NAMLENGTH);
1319       *len = strlen(buf);
1320
1321       /* Get rid of "000000/ in rooted filespecs */
1322       if (*len > 7) {
1323       zeros = strstr(buf, "/000000/");
1324       if (zeros != NULL) {
1325         int mlen;
1326         mlen = *len - (zeros - buf) - 7;
1327         memmove(zeros, &zeros[7], mlen);
1328         *len = *len - 7;
1329         buf[*len] = '\0';
1330         }
1331       }
1332       return buf;
1333     }
1334     else {
1335       if (sys) {
1336         /* Impose security constraints only if tainting */
1337         secure = PL_curinterp ? PL_tainting : will_taint;
1338         saverr = errno;  savvmserr = vaxc$errno;
1339       }
1340       else {
1341         secure = 0;
1342       }
1343
1344       flags =
1345 #ifdef SECURE_INTERNAL_GETENV
1346               secure ? PERL__TRNENV_SECURE : 0
1347 #else
1348               0
1349 #endif
1350       ;
1351
1352       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1353
1354       if ((cp2 = strchr(lnm,';')) != NULL) {
1355         strcpy(buf,lnm);
1356         buf[cp2-lnm] = '\0';
1357         idx = strtoul(cp2+1,NULL,0);
1358         lnm = buf;
1359         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1360       }
1361
1362       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1363
1364       /* Get rid of "000000/ in rooted filespecs */
1365       if (*len > 7) {
1366       char * zeros;
1367         zeros = strstr(buf, "/000000/");
1368         if (zeros != NULL) {
1369           int mlen;
1370           mlen = *len - (zeros - buf) - 7;
1371           memmove(zeros, &zeros[7], mlen);
1372           *len = *len - 7;
1373           buf[*len] = '\0';
1374         }
1375       }
1376
1377       /* Discard NOLOGNAM on internal calls since we're often looking
1378        * for an optional name, and this "error" often shows up as the
1379        * (bogus) exit status for a die() call later on.  */
1380       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1381       return *len ? buf : NULL;
1382     }
1383
1384 }  /* end of my_getenv_len() */
1385 /*}}}*/
1386
1387 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1388
1389 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1390
1391 /*{{{ void prime_env_iter() */
1392 void
1393 prime_env_iter(void)
1394 /* Fill the %ENV associative array with all logical names we can
1395  * find, in preparation for iterating over it.
1396  */
1397 {
1398   static int primed = 0;
1399   HV *seenhv = NULL, *envhv;
1400   SV *sv = NULL;
1401   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1402   unsigned short int chan;
1403 #ifndef CLI$M_TRUSTED
1404 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1405 #endif
1406   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1407   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1408   long int i;
1409   bool have_sym = FALSE, have_lnm = FALSE;
1410   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1411   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1412   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1413   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1414   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1415 #if defined(PERL_IMPLICIT_CONTEXT)
1416   pTHX;
1417 #endif
1418 #if defined(USE_ITHREADS)
1419   static perl_mutex primenv_mutex;
1420   MUTEX_INIT(&primenv_mutex);
1421 #endif
1422
1423 #if defined(PERL_IMPLICIT_CONTEXT)
1424     /* We jump through these hoops because we can be called at */
1425     /* platform-specific initialization time, which is before anything is */
1426     /* set up--we can't even do a plain dTHX since that relies on the */
1427     /* interpreter structure to be initialized */
1428     if (PL_curinterp) {
1429       aTHX = PERL_GET_INTERP;
1430     } else {
1431       /* we never get here because the NULL pointer will cause the */
1432       /* several of the routines called by this routine to access violate */
1433
1434       /* This routine is only called by hv.c/hv_iterinit which has a */
1435       /* context, so the real fix may be to pass it through instead of */
1436       /* the hoops above */
1437       aTHX = NULL;
1438     }
1439 #endif
1440
1441   if (primed || !PL_envgv) return;
1442   MUTEX_LOCK(&primenv_mutex);
1443   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1444   envhv = GvHVn(PL_envgv);
1445   /* Perform a dummy fetch as an lval to insure that the hash table is
1446    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1447   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1448
1449   for (i = 0; env_tables[i]; i++) {
1450      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1451          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1452      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1453   }
1454   if (have_sym || have_lnm) {
1455     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1456     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1457     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1458     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1459   }
1460
1461   for (i--; i >= 0; i--) {
1462     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1463       char *start;
1464       int j;
1465       for (j = 0; environ[j]; j++) {
1466         if (!(start = strchr(environ[j],'='))) {
1467           if (ckWARN(WARN_INTERNAL))
1468             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1469         }
1470         else {
1471           start++;
1472           sv = newSVpv(start,0);
1473           SvTAINTED_on(sv);
1474           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1475         }
1476       }
1477       continue;
1478     }
1479     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1480              !str$case_blind_compare(&tmpdsc,&clisym)) {
1481       strcpy(cmd,"Show Symbol/Global *");
1482       cmddsc.dsc$w_length = 20;
1483       if (env_tables[i]->dsc$w_length == 12 &&
1484           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1485           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1486       flags = defflags | CLI$M_NOLOGNAM;
1487     }
1488     else {
1489       strcpy(cmd,"Show Logical *");
1490       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1491         strcat(cmd," /Table=");
1492         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1493         cmddsc.dsc$w_length = strlen(cmd);
1494       }
1495       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1496       flags = defflags | CLI$M_NOCLISYM;
1497     }
1498
1499     /* Create a new subprocess to execute each command, to exclude the
1500      * remote possibility that someone could subvert a mbx or file used
1501      * to write multiple commands to a single subprocess.
1502      */
1503     do {
1504       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1505                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1506       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1507       defflags &= ~CLI$M_TRUSTED;
1508     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1509     _ckvmssts(retsts);
1510     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1511     if (seenhv) SvREFCNT_dec(seenhv);
1512     seenhv = newHV();
1513     while (1) {
1514       char *cp1, *cp2, *key;
1515       unsigned long int sts, iosb[2], retlen, keylen;
1516       register U32 hash;
1517
1518       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1519       if (sts & 1) sts = iosb[0] & 0xffff;
1520       if (sts == SS$_ENDOFFILE) {
1521         int wakect = 0;
1522         while (substs == 0) { sys$hiber(); wakect++;}
1523         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1524         _ckvmssts(substs);
1525         break;
1526       }
1527       _ckvmssts(sts);
1528       retlen = iosb[0] >> 16;
1529       if (!retlen) continue;  /* blank line */
1530       buf[retlen] = '\0';
1531       if (iosb[1] != subpid) {
1532         if (iosb[1]) {
1533           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1534         }
1535         continue;
1536       }
1537       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1538         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1539
1540       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1541       if (*cp1 == '(' || /* Logical name table name */
1542           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1543       if (*cp1 == '"') cp1++;
1544       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1545       key = cp1;  keylen = cp2 - cp1;
1546       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1547       while (*cp2 && *cp2 != '=') cp2++;
1548       while (*cp2 && *cp2 == '=') cp2++;
1549       while (*cp2 && *cp2 == ' ') cp2++;
1550       if (*cp2 == '"') {  /* String translation; may embed "" */
1551         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1552         cp2++;  cp1--; /* Skip "" surrounding translation */
1553       }
1554       else {  /* Numeric translation */
1555         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1556         cp1--;  /* stop on last non-space char */
1557       }
1558       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1559         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1560         continue;
1561       }
1562       PERL_HASH(hash,key,keylen);
1563
1564       if (cp1 == cp2 && *cp2 == '.') {
1565         /* A single dot usually means an unprintable character, such as a null
1566          * to indicate a zero-length value.  Get the actual value to make sure.
1567          */
1568         char lnm[LNM$C_NAMLENGTH+1];
1569         char eqv[MAX_DCL_SYMBOL+1];
1570         int trnlen;
1571         strncpy(lnm, key, keylen);
1572         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1573         sv = newSVpvn(eqv, strlen(eqv));
1574       }
1575       else {
1576         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1577       }
1578
1579       SvTAINTED_on(sv);
1580       hv_store(envhv,key,keylen,sv,hash);
1581       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1582     }
1583     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1584       /* get the PPFs for this process, not the subprocess */
1585       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1586       char eqv[LNM$C_NAMLENGTH+1];
1587       int trnlen, i;
1588       for (i = 0; ppfs[i]; i++) {
1589         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1590         sv = newSVpv(eqv,trnlen);
1591         SvTAINTED_on(sv);
1592         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1593       }
1594     }
1595   }
1596   primed = 1;
1597   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1598   if (buf) Safefree(buf);
1599   if (seenhv) SvREFCNT_dec(seenhv);
1600   MUTEX_UNLOCK(&primenv_mutex);
1601   return;
1602
1603 }  /* end of prime_env_iter */
1604 /*}}}*/
1605
1606
1607 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1608 /* Define or delete an element in the same "environment" as
1609  * vmstrnenv().  If an element is to be deleted, it's removed from
1610  * the first place it's found.  If it's to be set, it's set in the
1611  * place designated by the first element of the table vector.
1612  * Like setenv() returns 0 for success, non-zero on error.
1613  */
1614 int
1615 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1616 {
1617     const char *cp1;
1618     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1619     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1620     int nseg = 0, j;
1621     unsigned long int retsts, usermode = PSL$C_USER;
1622     struct itmlst_3 *ile, *ilist;
1623     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1624                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1625                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1626     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1627     $DESCRIPTOR(local,"_LOCAL");
1628
1629     if (!lnm) {
1630         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1631         return SS$_IVLOGNAM;
1632     }
1633
1634     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1635       *cp2 = _toupper(*cp1);
1636       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1637         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1638         return SS$_IVLOGNAM;
1639       }
1640     }
1641     lnmdsc.dsc$w_length = cp1 - lnm;
1642     if (!tabvec || !*tabvec) tabvec = env_tables;
1643
1644     if (!eqv) {  /* we're deleting n element */
1645       for (curtab = 0; tabvec[curtab]; curtab++) {
1646         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1647         int i;
1648           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1649             if ((cp1 = strchr(environ[i],'=')) &&
1650                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1651                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1652 #ifdef HAS_SETENV
1653               return setenv(lnm,"",1) ? vaxc$errno : 0;
1654             }
1655           }
1656           ivenv = 1; retsts = SS$_NOLOGNAM;
1657 #else
1658               if (ckWARN(WARN_INTERNAL))
1659                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1660               ivenv = 1; retsts = SS$_NOSUCHPGM;
1661               break;
1662             }
1663           }
1664 #endif
1665         }
1666         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1667                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1668           unsigned int symtype;
1669           if (tabvec[curtab]->dsc$w_length == 12 &&
1670               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1671               !str$case_blind_compare(&tmpdsc,&local))
1672             symtype = LIB$K_CLI_LOCAL_SYM;
1673           else symtype = LIB$K_CLI_GLOBAL_SYM;
1674           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1675           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1676           if (retsts == LIB$_NOSUCHSYM) continue;
1677           break;
1678         }
1679         else if (!ivlnm) {
1680           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1681           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1682           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1683           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1684           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1685         }
1686       }
1687     }
1688     else {  /* we're defining a value */
1689       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1690 #ifdef HAS_SETENV
1691         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1692 #else
1693         if (ckWARN(WARN_INTERNAL))
1694           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1695         retsts = SS$_NOSUCHPGM;
1696 #endif
1697       }
1698       else {
1699         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1700         eqvdsc.dsc$w_length  = strlen(eqv);
1701         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1702             !str$case_blind_compare(&tmpdsc,&clisym)) {
1703           unsigned int symtype;
1704           if (tabvec[0]->dsc$w_length == 12 &&
1705               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1706                !str$case_blind_compare(&tmpdsc,&local))
1707             symtype = LIB$K_CLI_LOCAL_SYM;
1708           else symtype = LIB$K_CLI_GLOBAL_SYM;
1709           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1710         }
1711         else {
1712           if (!*eqv) eqvdsc.dsc$w_length = 1;
1713           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1714
1715             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1716             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1717               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1718                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1719               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1720               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1721             }
1722
1723             Newx(ilist,nseg+1,struct itmlst_3);
1724             ile = ilist;
1725             if (!ile) {
1726               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1727               return SS$_INSFMEM;
1728             }
1729             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1730
1731             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1732               ile->itmcode = LNM$_STRING;
1733               ile->bufadr = c;
1734               if ((j+1) == nseg) {
1735                 ile->buflen = strlen(c);
1736                 /* in case we are truncating one that's too long */
1737                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1738               }
1739               else {
1740                 ile->buflen = LNM$C_NAMLENGTH;
1741               }
1742             }
1743
1744             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1745             Safefree (ilist);
1746           }
1747           else {
1748             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1749           }
1750         }
1751       }
1752     }
1753     if (!(retsts & 1)) {
1754       switch (retsts) {
1755         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1756         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1757           set_errno(EVMSERR); break;
1758         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1759         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1760           set_errno(EINVAL); break;
1761         case SS$_NOPRIV:
1762           set_errno(EACCES); break;
1763         default:
1764           _ckvmssts(retsts);
1765           set_errno(EVMSERR);
1766        }
1767        set_vaxc_errno(retsts);
1768        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1769     }
1770     else {
1771       /* We reset error values on success because Perl does an hv_fetch()
1772        * before each hv_store(), and if the thing we're setting didn't
1773        * previously exist, we've got a leftover error message.  (Of course,
1774        * this fails in the face of
1775        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1776        * in that the error reported in $! isn't spurious,
1777        * but it's right more often than not.)
1778        */
1779       set_errno(0); set_vaxc_errno(retsts);
1780       return 0;
1781     }
1782
1783 }  /* end of vmssetenv() */
1784 /*}}}*/
1785
1786 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1787 /* This has to be a function since there's a prototype for it in proto.h */
1788 void
1789 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1790 {
1791     if (lnm && *lnm) {
1792       int len = strlen(lnm);
1793       if  (len == 7) {
1794         char uplnm[8];
1795         int i;
1796         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1797         if (!strcmp(uplnm,"DEFAULT")) {
1798           if (eqv && *eqv) my_chdir(eqv);
1799           return;
1800         }
1801     }
1802 #ifndef RTL_USES_UTC
1803     if (len == 6 || len == 2) {
1804       char uplnm[7];
1805       int i;
1806       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1807       uplnm[len] = '\0';
1808       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1809       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1810     }
1811 #endif
1812   }
1813   (void) vmssetenv(lnm,eqv,NULL);
1814 }
1815 /*}}}*/
1816
1817 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1818 /*  vmssetuserlnm
1819  *  sets a user-mode logical in the process logical name table
1820  *  used for redirection of sys$error
1821  *
1822  *  Fix-me: The pTHX is not needed for this routine, however doio.c
1823  *          is calling it with one instead of using a macro.
1824  *          A macro needs to be added to vmsish.h and doio.c updated to use it.
1825  *
1826  */
1827 void
1828 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1829 {
1830     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1831     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1832     unsigned long int iss, attr = LNM$M_CONFINE;
1833     unsigned char acmode = PSL$C_USER;
1834     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1835                                  {0, 0, 0, 0}};
1836     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1837     d_name.dsc$w_length = strlen(name);
1838
1839     lnmlst[0].buflen = strlen(eqv);
1840     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1841
1842     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1843     if (!(iss&1)) lib$signal(iss);
1844 }
1845 /*}}}*/
1846
1847
1848 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1849 /* my_crypt - VMS password hashing
1850  * my_crypt() provides an interface compatible with the Unix crypt()
1851  * C library function, and uses sys$hash_password() to perform VMS
1852  * password hashing.  The quadword hashed password value is returned
1853  * as a NUL-terminated 8 character string.  my_crypt() does not change
1854  * the case of its string arguments; in order to match the behavior
1855  * of LOGINOUT et al., alphabetic characters in both arguments must
1856  *  be upcased by the caller.
1857  *
1858  * - fix me to call ACM services when available
1859  */
1860 char *
1861 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1862 {
1863 #   ifndef UAI$C_PREFERRED_ALGORITHM
1864 #     define UAI$C_PREFERRED_ALGORITHM 127
1865 #   endif
1866     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1867     unsigned short int salt = 0;
1868     unsigned long int sts;
1869     struct const_dsc {
1870         unsigned short int dsc$w_length;
1871         unsigned char      dsc$b_type;
1872         unsigned char      dsc$b_class;
1873         const char *       dsc$a_pointer;
1874     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1875        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1876     struct itmlst_3 uailst[3] = {
1877         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1878         { sizeof salt, UAI$_SALT,    &salt, 0},
1879         { 0,           0,            NULL,  NULL}};
1880     static char hash[9];
1881
1882     usrdsc.dsc$w_length = strlen(usrname);
1883     usrdsc.dsc$a_pointer = usrname;
1884     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1885       switch (sts) {
1886         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1887           set_errno(EACCES);
1888           break;
1889         case RMS$_RNF:
1890           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1891           break;
1892         default:
1893           set_errno(EVMSERR);
1894       }
1895       set_vaxc_errno(sts);
1896       if (sts != RMS$_RNF) return NULL;
1897     }
1898
1899     txtdsc.dsc$w_length = strlen(textpasswd);
1900     txtdsc.dsc$a_pointer = textpasswd;
1901     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1902       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1903     }
1904
1905     return (char *) hash;
1906
1907 }  /* end of my_crypt() */
1908 /*}}}*/
1909
1910
1911 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1912 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1913 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1914
1915 /* fixup barenames that are directories for internal use.
1916  * There have been problems with the consistent handling of UNIX
1917  * style directory names when routines are presented with a name that
1918  * has no directory delimitors at all.  So this routine will eventually
1919  * fix the issue.
1920  */
1921 static char * fixup_bare_dirnames(const char * name)
1922 {
1923   if (decc_disable_to_vms_logname_translation) {
1924 /* fix me */
1925   }
1926   return NULL;
1927 }
1928
1929 /* 8.3, remove() is now broken on symbolic links */
1930 static int rms_erase(const char * vmsname);
1931
1932
1933 /* mp_do_kill_file
1934  * A little hack to get around a bug in some implemenation of remove()
1935  * that do not know how to delete a directory
1936  *
1937  * Delete any file to which user has control access, regardless of whether
1938  * delete access is explicitly allowed.
1939  * Limitations: User must have write access to parent directory.
1940  *              Does not block signals or ASTs; if interrupted in midstream
1941  *              may leave file with an altered ACL.
1942  * HANDLE WITH CARE!
1943  */
1944 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1945 static int
1946 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1947 {
1948     char *vmsname;
1949     char *rslt;
1950     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1951     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1952     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1953     struct myacedef {
1954       unsigned char myace$b_length;
1955       unsigned char myace$b_type;
1956       unsigned short int myace$w_flags;
1957       unsigned long int myace$l_access;
1958       unsigned long int myace$l_ident;
1959     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1960                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1961       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1962      struct itmlst_3
1963        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1964                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1965        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1966        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1967        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1968        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1969
1970     /* Expand the input spec using RMS, since the CRTL remove() and
1971      * system services won't do this by themselves, so we may miss
1972      * a file "hiding" behind a logical name or search list. */
1973     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1974     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1975
1976     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1977     if (rslt == NULL) {
1978         PerlMem_free(vmsname);
1979         return -1;
1980       }
1981
1982     /* Erase the file */
1983     rmsts = rms_erase(vmsname);
1984
1985     /* Did it succeed */
1986     if ($VMS_STATUS_SUCCESS(rmsts)) {
1987         PerlMem_free(vmsname);
1988         return 0;
1989       }
1990
1991     /* If not, can changing protections help? */
1992     if (rmsts != RMS$_PRV) {
1993       set_vaxc_errno(rmsts);
1994       PerlMem_free(vmsname);
1995       return -1;
1996     }
1997
1998     /* No, so we get our own UIC to use as a rights identifier,
1999      * and the insert an ACE at the head of the ACL which allows us
2000      * to delete the file.
2001      */
2002     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
2003     fildsc.dsc$w_length = strlen(vmsname);
2004     fildsc.dsc$a_pointer = vmsname;
2005     cxt = 0;
2006     newace.myace$l_ident = oldace.myace$l_ident;
2007     rmsts = -1;
2008     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
2009       switch (aclsts) {
2010         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
2011           set_errno(ENOENT); break;
2012         case RMS$_DIR:
2013           set_errno(ENOTDIR); break;
2014         case RMS$_DEV:
2015           set_errno(ENODEV); break;
2016         case RMS$_SYN: case SS$_INVFILFOROP:
2017           set_errno(EINVAL); break;
2018         case RMS$_PRV:
2019           set_errno(EACCES); break;
2020         default:
2021           _ckvmssts_noperl(aclsts);
2022       }
2023       set_vaxc_errno(aclsts);
2024       PerlMem_free(vmsname);
2025       return -1;
2026     }
2027     /* Grab any existing ACEs with this identifier in case we fail */
2028     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2029     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2030                     || fndsts == SS$_NOMOREACE ) {
2031       /* Add the new ACE . . . */
2032       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2033         goto yourroom;
2034
2035       rmsts = rms_erase(vmsname);
2036       if ($VMS_STATUS_SUCCESS(rmsts)) {
2037         rmsts = 0;
2038         }
2039         else {
2040         rmsts = -1;
2041         /* We blew it - dir with files in it, no write priv for
2042          * parent directory, etc.  Put things back the way they were. */
2043         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2044           goto yourroom;
2045         if (fndsts & 1) {
2046           addlst[0].bufadr = &oldace;
2047           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2048             goto yourroom;
2049         }
2050       }
2051     }
2052
2053     yourroom:
2054     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2055     /* We just deleted it, so of course it's not there.  Some versions of
2056      * VMS seem to return success on the unlock operation anyhow (after all
2057      * the unlock is successful), but others don't.
2058      */
2059     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2060     if (aclsts & 1) aclsts = fndsts;
2061     if (!(aclsts & 1)) {
2062       set_errno(EVMSERR);
2063       set_vaxc_errno(aclsts);
2064     }
2065
2066     PerlMem_free(vmsname);
2067     return rmsts;
2068
2069 }  /* end of kill_file() */
2070 /*}}}*/
2071
2072
2073 /*{{{int do_rmdir(char *name)*/
2074 int
2075 Perl_do_rmdir(pTHX_ const char *name)
2076 {
2077     char * dirfile;
2078     int retval;
2079     Stat_t st;
2080
2081     /* lstat returns a VMS fileified specification of the name */
2082     /* that is looked up, and also lets verifies that this is a directory */
2083
2084     retval = flex_lstat(name, &st);
2085     if (retval != 0) {
2086         char * ret_spec;
2087
2088         /* Due to a historical feature, flex_stat/lstat can not see some */
2089         /* Unix format file names that the rest of the CRTL can see */
2090         /* Fixing that feature will cause some perl tests to fail */
2091         /* So try this one more time. */
2092
2093         retval = lstat(name, &st.crtl_stat);
2094         if (retval != 0)
2095             return -1;
2096
2097         /* force it to a file spec for the kill file to work. */
2098         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
2099         if (ret_spec == NULL) {
2100             errno = EIO;
2101             return -1;
2102         }
2103     }
2104
2105     if (!S_ISDIR(st.st_mode)) {
2106         errno = ENOTDIR;
2107         retval = -1;
2108     }
2109     else {
2110         dirfile = st.st_devnam;
2111
2112         /* It may be possible for flex_stat to find a file and vmsify() to */
2113         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
2114         /* with that case, so fail it */
2115         if (dirfile[0] == 0) {
2116             errno = EIO;
2117             return -1;
2118         }
2119
2120         retval = mp_do_kill_file(aTHX_ dirfile, 1);
2121     }
2122
2123     return retval;
2124
2125 }  /* end of do_rmdir */
2126 /*}}}*/
2127
2128 /* kill_file
2129  * Delete any file to which user has control access, regardless of whether
2130  * delete access is explicitly allowed.
2131  * Limitations: User must have write access to parent directory.
2132  *              Does not block signals or ASTs; if interrupted in midstream
2133  *              may leave file with an altered ACL.
2134  * HANDLE WITH CARE!
2135  */
2136 /*{{{int kill_file(char *name)*/
2137 int
2138 Perl_kill_file(pTHX_ const char *name)
2139 {
2140     char * vmsfile;
2141     Stat_t st;
2142     int rmsts;
2143
2144     /* Convert the filename to VMS format and see if it is a directory */
2145     /* flex_lstat returns a vmsified file specification */
2146     rmsts = flex_lstat(name, &st);
2147     if (rmsts != 0) {
2148
2149         /* Due to a historical feature, flex_stat/lstat can not see some */
2150         /* Unix format file names that the rest of the CRTL can see when */
2151         /* ODS-2 file specifications are in use. */
2152         /* Fixing that feature will cause some perl tests to fail */
2153         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2154         st.st_mode = 0;
2155         vmsfile = (char *) name; /* cast ok */
2156
2157     } else {
2158         vmsfile = st.st_devnam;
2159         if (vmsfile[0] == 0) {
2160             /* It may be possible for flex_stat to find a file and vmsify() */
2161             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
2162             /* deal with that case, so fail it */
2163             errno = EIO;
2164             return -1;
2165         }
2166     }
2167
2168     /* Remove() is allowed to delete directories, according to the X/Open
2169      * specifications.
2170      * This may need special handling to work with the ACL hacks.
2171      */
2172     if (S_ISDIR(st.st_mode)) {
2173         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2174         return rmsts;
2175     }
2176
2177     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2178
2179     /* Need to delete all versions ? */
2180     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2181         int i = 0;
2182
2183         /* Just use lstat() here as do not need st_dev */
2184         /* and we know that the file is in VMS format or that */
2185         /* because of a historical bug, flex_stat can not see the file */
2186         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2187             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2188             if (rmsts != 0)
2189                 break;
2190             i++;
2191
2192             /* Make sure that we do not loop forever */
2193             if (i > 32767) {
2194                 errno = EIO;
2195                 rmsts = -1;
2196                 break;
2197             }
2198         }
2199     }
2200
2201     return rmsts;
2202
2203 }  /* end of kill_file() */
2204 /*}}}*/
2205
2206
2207 /*{{{int my_mkdir(char *,Mode_t)*/
2208 int
2209 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2210 {
2211   STRLEN dirlen = strlen(dir);
2212
2213   /* zero length string sometimes gives ACCVIO */
2214   if (dirlen == 0) return -1;
2215
2216   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2217    * null file name/type.  However, it's commonplace under Unix,
2218    * so we'll allow it for a gain in portability.
2219    */
2220   if (dir[dirlen-1] == '/') {
2221     char *newdir = savepvn(dir,dirlen-1);
2222     int ret = mkdir(newdir,mode);
2223     Safefree(newdir);
2224     return ret;
2225   }
2226   else return mkdir(dir,mode);
2227 }  /* end of my_mkdir */
2228 /*}}}*/
2229
2230 /*{{{int my_chdir(char *)*/
2231 int
2232 Perl_my_chdir(pTHX_ const char *dir)
2233 {
2234   STRLEN dirlen = strlen(dir);
2235
2236   /* zero length string sometimes gives ACCVIO */
2237   if (dirlen == 0) return -1;
2238   const char *dir1;
2239
2240   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2241    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2242    * so that existing scripts do not need to be changed.
2243    */
2244   dir1 = dir;
2245   while ((dirlen > 0) && (*dir1 == ' ')) {
2246     dir1++;
2247     dirlen--;
2248   }
2249
2250   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2251    * that implies
2252    * null file name/type.  However, it's commonplace under Unix,
2253    * so we'll allow it for a gain in portability.
2254    *
2255    *  '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2256    */
2257   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2258       char *newdir;
2259       int ret;
2260       newdir = PerlMem_malloc(dirlen);
2261       if (newdir ==NULL)
2262           _ckvmssts_noperl(SS$_INSFMEM);
2263       strncpy(newdir, dir1, dirlen-1);
2264       newdir[dirlen-1] = '\0';
2265       ret = chdir(newdir);
2266       PerlMem_free(newdir);
2267       return ret;
2268   }
2269   else return chdir(dir1);
2270 }  /* end of my_chdir */
2271 /*}}}*/
2272
2273
2274 /*{{{int my_chmod(char *, mode_t)*/
2275 int
2276 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2277 {
2278   Stat_t st;
2279   int ret = -1;
2280   char * changefile;
2281   STRLEN speclen = strlen(file_spec);
2282
2283   /* zero length string sometimes gives ACCVIO */
2284   if (speclen == 0) return -1;
2285
2286   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2287    * that implies null file name/type.  However, it's commonplace under Unix,
2288    * so we'll allow it for a gain in portability.
2289    *
2290    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2291    * in VMS file.dir notation.
2292    */
2293   changefile = (char *) file_spec; /* cast ok */
2294   ret = flex_lstat(file_spec, &st);
2295   if (ret != 0) {
2296
2297         /* Due to a historical feature, flex_stat/lstat can not see some */
2298         /* Unix format file names that the rest of the CRTL can see when */
2299         /* ODS-2 file specifications are in use. */
2300         /* Fixing that feature will cause some perl tests to fail */
2301         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2302         st.st_mode = 0;
2303
2304   } else {
2305       /* It may be possible to get here with nothing in st_devname */
2306       /* chmod still may work though */
2307       if (st.st_devnam[0] != 0) {
2308           changefile = st.st_devnam;
2309       }
2310   }
2311   ret = chmod(changefile, mode);
2312   return ret;
2313 }  /* end of my_chmod */
2314 /*}}}*/
2315
2316
2317 /*{{{FILE *my_tmpfile()*/
2318 FILE *
2319 my_tmpfile(void)
2320 {
2321   FILE *fp;
2322   char *cp;
2323
2324   if ((fp = tmpfile())) return fp;
2325
2326   cp = PerlMem_malloc(L_tmpnam+24);
2327   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2328
2329   if (decc_filename_unix_only == 0)
2330     strcpy(cp,"Sys$Scratch:");
2331   else
2332     strcpy(cp,"/tmp/");
2333   tmpnam(cp+strlen(cp));
2334   strcat(cp,".Perltmp");
2335   fp = fopen(cp,"w+","fop=dlt");
2336   PerlMem_free(cp);
2337   return fp;
2338 }
2339 /*}}}*/
2340
2341
2342 #ifndef HOMEGROWN_POSIX_SIGNALS
2343 /*
2344  * The C RTL's sigaction fails to check for invalid signal numbers so we
2345  * help it out a bit.  The docs are correct, but the actual routine doesn't
2346  * do what the docs say it will.
2347  */
2348 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2349 int
2350 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2351                    struct sigaction* oact)
2352 {
2353   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2354         SETERRNO(EINVAL, SS$_INVARG);
2355         return -1;
2356   }
2357   return sigaction(sig, act, oact);
2358 }
2359 /*}}}*/
2360 #endif
2361
2362 #ifdef KILL_BY_SIGPRC
2363 #include <errnodef.h>
2364
2365 /* We implement our own kill() using the undocumented system service
2366    sys$sigprc for one of two reasons:
2367
2368    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2369    target process to do a sys$exit, which usually can't be handled
2370    gracefully...certainly not by Perl and the %SIG{} mechanism.
2371
2372    2.) If the kill() in the CRTL can't be called from a signal
2373    handler without disappearing into the ether, i.e., the signal
2374    it purportedly sends is never trapped. Still true as of VMS 7.3.
2375
2376    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2377    in the target process rather than calling sys$exit.
2378
2379    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2380    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2381    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2382    with condition codes C$_SIG0+nsig*8, catching the exception on the
2383    target process and resignaling with appropriate arguments.
2384
2385    But we don't have that VMS 7.0+ exception handler, so if you
2386    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2387
2388    Also note that SIGTERM is listed in the docs as being "unimplemented",
2389    yet always seems to be signaled with a VMS condition code of 4 (and
2390    correctly handled for that code).  So we hardwire it in.
2391
2392    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2393    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2394    than signalling with an unrecognized (and unhandled by CRTL) code.
2395 */
2396
2397 #define _MY_SIG_MAX 28
2398
2399 static unsigned int
2400 Perl_sig_to_vmscondition_int(int sig)
2401 {
2402     static unsigned int sig_code[_MY_SIG_MAX+1] =
2403     {
2404         0,                  /*  0 ZERO     */
2405         SS$_HANGUP,         /*  1 SIGHUP   */
2406         SS$_CONTROLC,       /*  2 SIGINT   */
2407         SS$_CONTROLY,       /*  3 SIGQUIT  */
2408         SS$_RADRMOD,        /*  4 SIGILL   */
2409         SS$_BREAK,          /*  5 SIGTRAP  */
2410         SS$_OPCCUS,         /*  6 SIGABRT  */
2411         SS$_COMPAT,         /*  7 SIGEMT   */
2412 #ifdef __VAX
2413         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2414 #else
2415         SS$_HPARITH,        /*  8 SIGFPE AXP */
2416 #endif
2417         SS$_ABORT,          /*  9 SIGKILL  */
2418         SS$_ACCVIO,         /* 10 SIGBUS   */
2419         SS$_ACCVIO,         /* 11 SIGSEGV  */
2420         SS$_BADPARAM,       /* 12 SIGSYS   */
2421         SS$_NOMBX,          /* 13 SIGPIPE  */
2422         SS$_ASTFLT,         /* 14 SIGALRM  */
2423         4,                  /* 15 SIGTERM  */
2424         0,                  /* 16 SIGUSR1  */
2425         0,                  /* 17 SIGUSR2  */
2426         0,                  /* 18 */
2427         0,                  /* 19 */
2428         0,                  /* 20 SIGCHLD  */
2429         0,                  /* 21 SIGCONT  */
2430         0,                  /* 22 SIGSTOP  */
2431         0,                  /* 23 SIGTSTP  */
2432         0,                  /* 24 SIGTTIN  */
2433         0,                  /* 25 SIGTTOU  */
2434         0,                  /* 26 */
2435         0,                  /* 27 */
2436         0                   /* 28 SIGWINCH  */
2437     };
2438
2439 #if __VMS_VER >= 60200000
2440     static int initted = 0;
2441     if (!initted) {
2442         initted = 1;
2443         sig_code[16] = C$_SIGUSR1;
2444         sig_code[17] = C$_SIGUSR2;
2445 #if __CRTL_VER >= 70000000
2446         sig_code[20] = C$_SIGCHLD;
2447 #endif
2448 #if __CRTL_VER >= 70300000
2449         sig_code[28] = C$_SIGWINCH;
2450 #endif
2451     }
2452 #endif
2453
2454     if (sig < _SIG_MIN) return 0;
2455     if (sig > _MY_SIG_MAX) return 0;
2456     return sig_code[sig];
2457 }
2458
2459 unsigned int
2460 Perl_sig_to_vmscondition(int sig)
2461 {
2462 #ifdef SS$_DEBUG
2463     if (vms_debug_on_exception != 0)
2464         lib$signal(SS$_DEBUG);
2465 #endif
2466     return Perl_sig_to_vmscondition_int(sig);
2467 }
2468
2469
2470 int
2471 Perl_my_kill(int pid, int sig)
2472 {
2473     dTHX;
2474     int iss;
2475     unsigned int code;
2476     int sys$sigprc(unsigned int *pidadr,
2477                      struct dsc$descriptor_s *prcname,
2478                      unsigned int code);
2479
2480      /* sig 0 means validate the PID */
2481     /*------------------------------*/
2482     if (sig == 0) {
2483         const unsigned long int jpicode = JPI$_PID;
2484         pid_t ret_pid;
2485         int status;
2486         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2487         if ($VMS_STATUS_SUCCESS(status))
2488            return 0;
2489         switch (status) {
2490         case SS$_NOSUCHNODE:
2491         case SS$_UNREACHABLE:
2492         case SS$_NONEXPR:
2493            errno = ESRCH;
2494            break;
2495         case SS$_NOPRIV:
2496            errno = EPERM;
2497            break;
2498         default:
2499            errno = EVMSERR;
2500         }
2501         vaxc$errno=status;
2502         return -1;
2503     }
2504
2505     code = Perl_sig_to_vmscondition_int(sig);
2506
2507     if (!code) {
2508         SETERRNO(EINVAL, SS$_BADPARAM);
2509         return -1;
2510     }
2511
2512     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2513      * signals are to be sent to multiple processes.
2514      *  pid = 0 - all processes in group except ones that the system exempts
2515      *  pid = -1 - all processes except ones that the system exempts
2516      *  pid = -n - all processes in group (abs(n)) except ...
2517      * For now, just report as not supported.
2518      */
2519
2520     if (pid <= 0) {
2521         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2522         return -1;
2523     }
2524
2525     iss = sys$sigprc((unsigned int *)&pid,0,code);
2526     if (iss&1) return 0;
2527
2528     switch (iss) {
2529       case SS$_NOPRIV:
2530         set_errno(EPERM);  break;
2531       case SS$_NONEXPR:
2532       case SS$_NOSUCHNODE:
2533       case SS$_UNREACHABLE:
2534         set_errno(ESRCH);  break;
2535       case SS$_INSFMEM:
2536         set_errno(ENOMEM); break;
2537       default:
2538         _ckvmssts_noperl(iss);
2539         set_errno(EVMSERR);
2540     }
2541     set_vaxc_errno(iss);
2542
2543     return -1;
2544 }
2545 #endif
2546
2547 /* Routine to convert a VMS status code to a UNIX status code.
2548 ** More tricky than it appears because of conflicting conventions with
2549 ** existing code.
2550 **
2551 ** VMS status codes are a bit mask, with the least significant bit set for
2552 ** success.
2553 **
2554 ** Special UNIX status of EVMSERR indicates that no translation is currently
2555 ** available, and programs should check the VMS status code.
2556 **
2557 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2558 ** decoding.
2559 */
2560
2561 #ifndef C_FACILITY_NO
2562 #define C_FACILITY_NO 0x350000
2563 #endif
2564 #ifndef DCL_IVVERB
2565 #define DCL_IVVERB 0x38090
2566 #endif
2567
2568 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2569 {
2570 int facility;
2571 int fac_sp;
2572 int msg_no;
2573 int msg_status;
2574 int unix_status;
2575
2576   /* Assume the best or the worst */
2577   if (vms_status & STS$M_SUCCESS)
2578     unix_status = 0;
2579   else
2580     unix_status = EVMSERR;
2581
2582   msg_status = vms_status & ~STS$M_CONTROL;
2583
2584   facility = vms_status & STS$M_FAC_NO;
2585   fac_sp = vms_status & STS$M_FAC_SP;
2586   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2587
2588   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2589     switch(msg_no) {
2590     case SS$_NORMAL:
2591         unix_status = 0;
2592         break;
2593     case SS$_ACCVIO:
2594         unix_status = EFAULT;
2595         break;
2596     case SS$_DEVOFFLINE:
2597         unix_status = EBUSY;
2598         break;
2599     case SS$_CLEARED:
2600         unix_status = ENOTCONN;
2601         break;
2602     case SS$_IVCHAN:
2603     case SS$_IVLOGNAM:
2604     case SS$_BADPARAM:
2605     case SS$_IVLOGTAB:
2606     case SS$_NOLOGNAM:
2607     case SS$_NOLOGTAB:
2608     case SS$_INVFILFOROP:
2609     case SS$_INVARG:
2610     case SS$_NOSUCHID:
2611     case SS$_IVIDENT:
2612         unix_status = EINVAL;
2613         break;
2614     case SS$_UNSUPPORTED:
2615         unix_status = ENOTSUP;
2616         break;
2617     case SS$_FILACCERR:
2618     case SS$_NOGRPPRV:
2619     case SS$_NOSYSPRV:
2620         unix_status = EACCES;
2621         break;
2622     case SS$_DEVICEFULL:
2623         unix_status = ENOSPC;
2624         break;
2625     case SS$_NOSUCHDEV:
2626         unix_status = ENODEV;
2627         break;
2628     case SS$_NOSUCHFILE:
2629     case SS$_NOSUCHOBJECT:
2630         unix_status = ENOENT;
2631         break;
2632     case SS$_ABORT:                                 /* Fatal case */
2633     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2634     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2635         unix_status = EINTR;
2636         break;
2637     case SS$_BUFFEROVF:
2638         unix_status = E2BIG;
2639         break;
2640     case SS$_INSFMEM:
2641         unix_status = ENOMEM;
2642         break;
2643     case SS$_NOPRIV:
2644         unix_status = EPERM;
2645         break;
2646     case SS$_NOSUCHNODE:
2647     case SS$_UNREACHABLE:
2648         unix_status = ESRCH;
2649         break;
2650     case SS$_NONEXPR:
2651         unix_status = ECHILD;
2652         break;
2653     default:
2654         if ((facility == 0) && (msg_no < 8)) {
2655           /* These are not real VMS status codes so assume that they are
2656           ** already UNIX status codes
2657           */
2658           unix_status = msg_no;
2659           break;
2660         }
2661     }
2662   }
2663   else {
2664     /* Translate a POSIX exit code to a UNIX exit code */
2665     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2666         unix_status = (msg_no & 0x07F8) >> 3;
2667     }
2668     else {
2669
2670          /* Documented traditional behavior for handling VMS child exits */
2671         /*--------------------------------------------------------------*/
2672         if (child_flag != 0) {
2673
2674              /* Success / Informational return 0 */
2675             /*----------------------------------*/
2676             if (msg_no & STS$K_SUCCESS)
2677                 return 0;
2678
2679              /* Warning returns 1 */
2680             /*-------------------*/
2681             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2682                 return 1;
2683
2684              /* Everything else pass through the severity bits */
2685             /*------------------------------------------------*/
2686             return (msg_no & STS$M_SEVERITY);
2687         }
2688
2689          /* Normal VMS status to ERRNO mapping attempt */
2690         /*--------------------------------------------*/
2691         switch(msg_status) {
2692         /* case RMS$_EOF: */ /* End of File */
2693         case RMS$_FNF:  /* File Not Found */
2694         case RMS$_DNF:  /* Dir Not Found */
2695                 unix_status = ENOENT;
2696                 break;
2697         case RMS$_RNF:  /* Record Not Found */
2698                 unix_status = ESRCH;
2699                 break;
2700         case RMS$_DIR:
2701                 unix_status = ENOTDIR;
2702                 break;
2703         case RMS$_DEV:
2704                 unix_status = ENODEV;
2705                 break;
2706         case RMS$_IFI:
2707         case RMS$_FAC:
2708         case RMS$_ISI:
2709                 unix_status = EBADF;
2710                 break;
2711         case RMS$_FEX:
2712                 unix_status = EEXIST;
2713                 break;
2714         case RMS$_SYN:
2715         case RMS$_FNM:
2716         case LIB$_INVSTRDES:
2717         case LIB$_INVARG:
2718         case LIB$_NOSUCHSYM:
2719         case LIB$_INVSYMNAM:
2720         case DCL_IVVERB:
2721                 unix_status = EINVAL;
2722                 break;
2723         case CLI$_BUFOVF:
2724         case RMS$_RTB:
2725         case CLI$_TKNOVF:
2726         case CLI$_RSLOVF:
2727                 unix_status = E2BIG;
2728                 break;
2729         case RMS$_PRV:  /* No privilege */
2730         case RMS$_ACC:  /* ACP file access failed */
2731         case RMS$_WLK:  /* Device write locked */
2732                 unix_status = EACCES;
2733                 break;
2734         case RMS$_MKD:  /* Failed to mark for delete */
2735                 unix_status = EPERM;
2736                 break;
2737         /* case RMS$_NMF: */  /* No more files */
2738         }
2739     }
2740   }
2741
2742   return unix_status;
2743 }
2744
2745 /* Try to guess at what VMS error status should go with a UNIX errno
2746  * value.  This is hard to do as there could be many possible VMS
2747  * error statuses that caused the errno value to be set.
2748  */
2749
2750 int Perl_unix_status_to_vms(int unix_status)
2751 {
2752 int test_unix_status;
2753
2754      /* Trivial cases first */
2755     /*---------------------*/
2756     if (unix_status == EVMSERR)
2757         return vaxc$errno;
2758
2759      /* Is vaxc$errno sane? */
2760     /*---------------------*/
2761     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2762     if (test_unix_status == unix_status)
2763         return vaxc$errno;
2764
2765      /* If way out of range, must be VMS code already */
2766     /*-----------------------------------------------*/
2767     if (unix_status > EVMSERR)
2768         return unix_status;
2769
2770      /* If out of range, punt */
2771     /*-----------------------*/
2772     if (unix_status > __ERRNO_MAX)
2773         return SS$_ABORT;
2774
2775
2776      /* Ok, now we have to do it the hard way. */
2777     /*----------------------------------------*/
2778     switch(unix_status) {
2779     case 0:     return SS$_NORMAL;
2780     case EPERM: return SS$_NOPRIV;
2781     case ENOENT: return SS$_NOSUCHOBJECT;
2782     case ESRCH: return SS$_UNREACHABLE;
2783     case EINTR: return SS$_ABORT;
2784     /* case EIO: */
2785     /* case ENXIO:  */
2786     case E2BIG: return SS$_BUFFEROVF;
2787     /* case ENOEXEC */
2788     case EBADF: return RMS$_IFI;
2789     case ECHILD: return SS$_NONEXPR;
2790     /* case EAGAIN */
2791     case ENOMEM: return SS$_INSFMEM;
2792     case EACCES: return SS$_FILACCERR;
2793     case EFAULT: return SS$_ACCVIO;
2794     /* case ENOTBLK */
2795     case EBUSY: return SS$_DEVOFFLINE;
2796     case EEXIST: return RMS$_FEX;
2797     /* case EXDEV */
2798     case ENODEV: return SS$_NOSUCHDEV;
2799     case ENOTDIR: return RMS$_DIR;
2800     /* case EISDIR */
2801     case EINVAL: return SS$_INVARG;
2802     /* case ENFILE */
2803     /* case EMFILE */
2804     /* case ENOTTY */
2805     /* case ETXTBSY */
2806     /* case EFBIG */
2807     case ENOSPC: return SS$_DEVICEFULL;
2808     case ESPIPE: return LIB$_INVARG;
2809     /* case EROFS: */
2810     /* case EMLINK: */
2811     /* case EPIPE: */
2812     /* case EDOM */
2813     case ERANGE: return LIB$_INVARG;
2814     /* case EWOULDBLOCK */
2815     /* case EINPROGRESS */
2816     /* case EALREADY */
2817     /* case ENOTSOCK */
2818     /* case EDESTADDRREQ */
2819     /* case EMSGSIZE */
2820     /* case EPROTOTYPE */
2821     /* case ENOPROTOOPT */
2822     /* case EPROTONOSUPPORT */
2823     /* case ESOCKTNOSUPPORT */
2824     /* case EOPNOTSUPP */
2825     /* case EPFNOSUPPORT */
2826     /* case EAFNOSUPPORT */
2827     /* case EADDRINUSE */
2828     /* case EADDRNOTAVAIL */
2829     /* case ENETDOWN */
2830     /* case ENETUNREACH */
2831     /* case ENETRESET */
2832     /* case ECONNABORTED */
2833     /* case ECONNRESET */
2834     /* case ENOBUFS */
2835     /* case EISCONN */
2836     case ENOTCONN: return SS$_CLEARED;
2837     /* case ESHUTDOWN */
2838     /* case ETOOMANYREFS */
2839     /* case ETIMEDOUT */
2840     /* case ECONNREFUSED */
2841     /* case ELOOP */
2842     /* case ENAMETOOLONG */
2843     /* case EHOSTDOWN */
2844     /* case EHOSTUNREACH */
2845     /* case ENOTEMPTY */
2846     /* case EPROCLIM */
2847     /* case EUSERS  */
2848     /* case EDQUOT  */
2849     /* case ENOMSG  */
2850     /* case EIDRM */
2851     /* case EALIGN */
2852     /* case ESTALE */
2853     /* case EREMOTE */
2854     /* case ENOLCK */
2855     /* case ENOSYS */
2856     /* case EFTYPE */
2857     /* case ECANCELED */
2858     /* case EFAIL */
2859     /* case EINPROG */
2860     case ENOTSUP:
2861         return SS$_UNSUPPORTED;
2862     /* case EDEADLK */
2863     /* case ENWAIT */
2864     /* case EILSEQ */
2865     /* case EBADCAT */
2866     /* case EBADMSG */
2867     /* case EABANDONED */
2868     default:
2869         return SS$_ABORT; /* punt */
2870     }
2871
2872   return SS$_ABORT; /* Should not get here */
2873 }
2874
2875
2876 /* default piping mailbox size */
2877 #define PERL_BUFSIZ        512
2878
2879
2880 static void
2881 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2882 {
2883   unsigned long int mbxbufsiz;
2884   static unsigned long int syssize = 0;
2885   unsigned long int dviitm = DVI$_DEVNAM;
2886   char csize[LNM$C_NAMLENGTH+1];
2887   int sts;
2888
2889   if (!syssize) {
2890     unsigned long syiitm = SYI$_MAXBUF;
2891     /*
2892      * Get the SYSGEN parameter MAXBUF
2893      *
2894      * If the logical 'PERL_MBX_SIZE' is defined
2895      * use the value of the logical instead of PERL_BUFSIZ, but
2896      * keep the size between 128 and MAXBUF.
2897      *
2898      */
2899     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2900   }
2901
2902   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2903       mbxbufsiz = atoi(csize);
2904   } else {
2905       mbxbufsiz = PERL_BUFSIZ;
2906   }
2907   if (mbxbufsiz < 128) mbxbufsiz = 128;
2908   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2909
2910   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2911
2912   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2913   _ckvmssts_noperl(sts);
2914   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2915
2916 }  /* end of create_mbx() */
2917
2918
2919 /*{{{  my_popen and my_pclose*/
2920
2921 typedef struct _iosb           IOSB;
2922 typedef struct _iosb*         pIOSB;
2923 typedef struct _pipe           Pipe;
2924 typedef struct _pipe*         pPipe;
2925 typedef struct pipe_details    Info;
2926 typedef struct pipe_details*  pInfo;
2927 typedef struct _srqp            RQE;
2928 typedef struct _srqp*          pRQE;
2929 typedef struct _tochildbuf      CBuf;
2930 typedef struct _tochildbuf*    pCBuf;
2931
2932 struct _iosb {
2933     unsigned short status;
2934     unsigned short count;
2935     unsigned long  dvispec;
2936 };
2937
2938 #pragma member_alignment save
2939 #pragma nomember_alignment quadword
2940 struct _srqp {          /* VMS self-relative queue entry */
2941     unsigned long qptr[2];
2942 };
2943 #pragma member_alignment restore
2944 static RQE  RQE_ZERO = {0,0};
2945
2946 struct _tochildbuf {
2947     RQE             q;
2948     int             eof;
2949     unsigned short  size;
2950     char            *buf;
2951 };
2952
2953 struct _pipe {
2954     RQE            free;
2955     RQE            wait;
2956     int            fd_out;
2957     unsigned short chan_in;
2958     unsigned short chan_out;
2959     char          *buf;
2960     unsigned int   bufsize;
2961     IOSB           iosb;
2962     IOSB           iosb2;
2963     int           *pipe_done;
2964     int            retry;
2965     int            type;
2966     int            shut_on_empty;
2967     int            need_wake;
2968     pPipe         *home;
2969     pInfo          info;
2970     pCBuf          curr;
2971     pCBuf          curr2;
2972 #if defined(PERL_IMPLICIT_CONTEXT)
2973     void            *thx;           /* Either a thread or an interpreter */
2974                                     /* pointer, depending on how we're built */
2975 #endif
2976 };
2977
2978
2979 struct pipe_details
2980 {
2981     pInfo           next;
2982     PerlIO *fp;  /* file pointer to pipe mailbox */
2983     int useFILE; /* using stdio, not perlio */
2984     int pid;   /* PID of subprocess */
2985     int mode;  /* == 'r' if pipe open for reading */
2986     int done;  /* subprocess has completed */
2987     int waiting; /* waiting for completion/closure */
2988     int             closing;        /* my_pclose is closing this pipe */
2989     unsigned long   completion;     /* termination status of subprocess */
2990     pPipe           in;             /* pipe in to sub */
2991     pPipe           out;            /* pipe out of sub */
2992     pPipe           err;            /* pipe of sub's sys$error */
2993     int             in_done;        /* true when in pipe finished */
2994     int             out_done;
2995     int             err_done;
2996     unsigned short  xchan;          /* channel to debug xterm */
2997     unsigned short  xchan_valid;    /* channel is assigned */
2998 };
2999
3000 struct exit_control_block
3001 {
3002     struct exit_control_block *flink;
3003     unsigned long int   (*exit_routine)();
3004     unsigned long int arg_count;
3005     unsigned long int *status_address;
3006     unsigned long int exit_status;
3007 };
3008
3009 typedef struct _closed_pipes    Xpipe;
3010 typedef struct _closed_pipes*  pXpipe;
3011
3012 struct _closed_pipes {
3013     int             pid;            /* PID of subprocess */
3014     unsigned long   completion;     /* termination status of subprocess */
3015 };
3016 #define NKEEPCLOSED 50
3017 static Xpipe closed_list[NKEEPCLOSED];
3018 static int   closed_index = 0;
3019 static int   closed_num = 0;
3020
3021 #define RETRY_DELAY     "0 ::0.20"
3022 #define MAX_RETRY              50
3023
3024 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
3025 static unsigned long mypid;
3026 static unsigned long delaytime[2];
3027
3028 static pInfo open_pipes = NULL;
3029 static $DESCRIPTOR(nl_desc, "NL:");
3030
3031 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
3032
3033
3034
3035 static unsigned long int
3036 pipe_exit_routine()
3037 {
3038     pInfo info;
3039     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
3040     int sts, did_stuff, need_eof, j;
3041
3042    /*
3043     * Flush any pending i/o, but since we are in process run-down, be
3044     * careful about referencing PerlIO structures that may already have
3045     * been deallocated.  We may not even have an interpreter anymore.
3046     */
3047     info = open_pipes;
3048     while (info) {
3049         if (info->fp) {
3050 #if defined(PERL_IMPLICIT_CONTEXT)
3051            /* We need to use the Perl context of the thread that created */
3052            /* the pipe. */
3053            pTHX;
3054            if (info->err)
3055                aTHX = info->err->thx;
3056            else if (info->out)
3057                aTHX = info->out->thx;
3058            else if (info->in)
3059                aTHX = info->in->thx;
3060 #endif
3061            if (!info->useFILE
3062 #if defined(USE_ITHREADS)
3063              && my_perl
3064 #endif
3065              && PL_perlio_fd_refcnt)
3066                PerlIO_flush(info->fp);
3067            else
3068                fflush((FILE *)info->fp);
3069         }
3070         info = info->next;
3071     }
3072
3073     /*
3074      next we try sending an EOF...ignore if doesn't work, make sure we
3075      don't hang
3076     */
3077     did_stuff = 0;
3078     info = open_pipes;
3079
3080     while (info) {
3081       int need_eof;
3082       _ckvmssts_noperl(sys$setast(0));
3083       if (info->in && !info->in->shut_on_empty) {
3084         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3085                                  0, 0, 0, 0, 0, 0));
3086         info->waiting = 1;
3087         did_stuff = 1;
3088       }
3089       _ckvmssts_noperl(sys$setast(1));
3090       info = info->next;
3091     }
3092
3093     /* wait for EOF to have effect, up to ~ 30 sec [default] */
3094
3095     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3096         int nwait = 0;
3097
3098         info = open_pipes;
3099         while (info) {
3100           _ckvmssts_noperl(sys$setast(0));
3101           if (info->waiting && info->done)
3102                 info->waiting = 0;
3103           nwait += info->waiting;
3104           _ckvmssts_noperl(sys$setast(1));
3105           info = info->next;
3106         }
3107         if (!nwait) break;
3108         sleep(1);
3109     }
3110
3111     did_stuff = 0;
3112     info = open_pipes;
3113     while (info) {
3114       _ckvmssts_noperl(sys$setast(0));
3115       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3116         sts = sys$forcex(&info->pid,0,&abort);
3117         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3118         did_stuff = 1;
3119       }
3120       _ckvmssts_noperl(sys$setast(1));
3121       info = info->next;
3122     }
3123
3124     /* again, wait for effect */
3125
3126     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3127         int nwait = 0;
3128
3129         info = open_pipes;
3130         while (info) {
3131           _ckvmssts_noperl(sys$setast(0));
3132           if (info->waiting && info->done)
3133                 info->waiting = 0;
3134           nwait += info->waiting;
3135           _ckvmssts_noperl(sys$setast(1));
3136           info = info->next;
3137         }
3138         if (!nwait) break;
3139         sleep(1);
3140     }
3141
3142     info = open_pipes;
3143     while (info) {
3144       _ckvmssts_noperl(sys$setast(0));
3145       if (!info->done) {  /* We tried to be nice . . . */
3146         sts = sys$delprc(&info->pid,0);
3147         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3148         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3149       }
3150       _ckvmssts_noperl(sys$setast(1));
3151       info = info->next;
3152     }
3153
3154     while(open_pipes) {
3155
3156 #if defined(PERL_IMPLICIT_CONTEXT)
3157       /* We need to use the Perl context of the thread that created */
3158       /* the pipe. */
3159       pTHX;
3160       if (open_pipes->err)
3161           aTHX = open_pipes->err->thx;
3162       else if (open_pipes->out)
3163           aTHX = open_pipes->out->thx;
3164       else if (open_pipes->in)
3165           aTHX = open_pipes->in->thx;
3166 #endif
3167       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3168       else if (!(sts & 1)) retsts = sts;
3169     }
3170     return retsts;
3171 }
3172
3173 static struct exit_control_block pipe_exitblock =
3174        {(struct exit_control_block *) 0,
3175         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3176
3177 static void pipe_mbxtofd_ast(pPipe p);
3178 static void pipe_tochild1_ast(pPipe p);
3179 static void pipe_tochild2_ast(pPipe p);
3180
3181 static void
3182 popen_completion_ast(pInfo info)
3183 {
3184   pInfo i = open_pipes;
3185   int iss;
3186   int sts;
3187   pXpipe x;
3188
3189   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3190   closed_list[closed_index].pid = info->pid;
3191   closed_list[closed_index].completion = info->completion;
3192   closed_index++;
3193   if (closed_index == NKEEPCLOSED)
3194     closed_index = 0;
3195   closed_num++;
3196
3197   while (i) {
3198     if (i == info) break;
3199     i = i->next;
3200   }
3201   if (!i) return;       /* unlinked, probably freed too */
3202
3203   info->done = TRUE;
3204
3205 /*
3206     Writing to subprocess ...
3207             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3208
3209             chan_out may be waiting for "done" flag, or hung waiting
3210             for i/o completion to child...cancel the i/o.  This will
3211             put it into "snarf mode" (done but no EOF yet) that discards
3212             input.
3213
3214     Output from subprocess (stdout, stderr) needs to be flushed and
3215     shut down.   We try sending an EOF, but if the mbx is full the pipe
3216     routine should still catch the "shut_on_empty" flag, telling it to
3217     use immediate-style reads so that "mbx empty" -> EOF.
3218
3219
3220 */
3221   if (info->in && !info->in_done) {               /* only for mode=w */
3222         if (info->in->shut_on_empty && info->in->need_wake) {
3223             info->in->need_wake = FALSE;
3224             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3225         } else {
3226             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3227         }
3228   }
3229
3230   if (info->out && !info->out_done) {             /* were we also piping output? */
3231       info->out->shut_on_empty = TRUE;
3232       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3233       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3234       _ckvmssts_noperl(iss);
3235   }
3236
3237   if (info->err && !info->err_done) {        /* we were piping stderr */
3238         info->err->shut_on_empty = TRUE;
3239         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3240         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3241         _ckvmssts_noperl(iss);
3242   }
3243   _ckvmssts_noperl(sys$setef(pipe_ef));
3244
3245 }
3246
3247 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3248 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3249
3250 /*
3251     we actually differ from vmstrnenv since we use this to
3252     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3253     are pointing to the same thing
3254 */
3255
3256 static unsigned short
3257 popen_translate(pTHX_ char *logical, char *result)
3258 {
3259     int iss;
3260     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3261     $DESCRIPTOR(d_log,"");
3262     struct _il3 {
3263         unsigned short length;
3264         unsigned short code;
3265         char *         buffer_addr;
3266         unsigned short *retlenaddr;
3267     } itmlst[2];
3268     unsigned short l, ifi;
3269
3270     d_log.dsc$a_pointer = logical;
3271     d_log.dsc$w_length  = strlen(logical);
3272
3273     itmlst[0].code = LNM$_STRING;
3274     itmlst[0].length = 255;
3275     itmlst[0].buffer_addr = result;
3276     itmlst[0].retlenaddr = &l;
3277
3278     itmlst[1].code = 0;
3279     itmlst[1].length = 0;
3280     itmlst[1].buffer_addr = 0;
3281     itmlst[1].retlenaddr = 0;
3282
3283     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3284     if (iss == SS$_NOLOGNAM) {
3285         iss = SS$_NORMAL;
3286         l = 0;
3287     }
3288     if (!(iss&1)) lib$signal(iss);
3289     result[l] = '\0';
3290 /*
3291     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3292     strip it off and return the ifi, if any
3293 */
3294     ifi  = 0;
3295     if (result[0] == 0x1b && result[1] == 0x00) {
3296         memmove(&ifi,result+2,2);
3297         strcpy(result,result+4);
3298     }
3299     return ifi;     /* this is the RMS internal file id */
3300 }
3301
3302 static void pipe_infromchild_ast(pPipe p);
3303
3304 /*
3305     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3306     inside an AST routine without worrying about reentrancy and which Perl
3307     memory allocator is being used.
3308
3309     We read data and queue up the buffers, then spit them out one at a
3310     time to the output mailbox when the output mailbox is ready for one.
3311
3312 */
3313 #define INITIAL_TOCHILDQUEUE  2
3314
3315 static pPipe
3316 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3317 {
3318     pPipe p;
3319     pCBuf b;
3320     char mbx1[64], mbx2[64];
3321     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3322                                       DSC$K_CLASS_S, mbx1},
3323                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3324                                       DSC$K_CLASS_S, mbx2};
3325     unsigned int dviitm = DVI$_DEVBUFSIZ;
3326     int j, n;
3327
3328     n = sizeof(Pipe);
3329     _ckvmssts_noperl(lib$get_vm(&n, &p));
3330
3331     create_mbx(&p->chan_in , &d_mbx1);
3332     create_mbx(&p->chan_out, &d_mbx2);
3333     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3334
3335     p->buf           = 0;
3336     p->shut_on_empty = FALSE;
3337     p->need_wake     = FALSE;
3338     p->type          = 0;
3339     p->retry         = 0;
3340     p->iosb.status   = SS$_NORMAL;
3341     p->iosb2.status  = SS$_NORMAL;
3342     p->free          = RQE_ZERO;
3343     p->wait          = RQE_ZERO;
3344     p->curr          = 0;
3345     p->curr2         = 0;
3346     p->info          = 0;
3347 #ifdef PERL_IMPLICIT_CONTEXT
3348     p->thx           = aTHX;
3349 #endif
3350
3351     n = sizeof(CBuf) + p->bufsize;
3352
3353     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3354         _ckvmssts_noperl(lib$get_vm(&n, &b));
3355         b->buf = (char *) b + sizeof(CBuf);
3356         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3357     }
3358
3359     pipe_tochild2_ast(p);
3360     pipe_tochild1_ast(p);
3361     strcpy(wmbx, mbx1);
3362     strcpy(rmbx, mbx2);
3363     return p;
3364 }
3365
3366 /*  reads the MBX Perl is writing, and queues */
3367
3368 static void
3369 pipe_tochild1_ast(pPipe p)
3370 {
3371     pCBuf b = p->curr;
3372     int iss = p->iosb.status;
3373     int eof = (iss == SS$_ENDOFFILE);
3374     int sts;
3375 #ifdef PERL_IMPLICIT_CONTEXT
3376     pTHX = p->thx;
3377 #endif
3378
3379     if (p->retry) {
3380         if (eof) {
3381             p->shut_on_empty = TRUE;
3382             b->eof     = TRUE;
3383             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3384         } else  {
3385             _ckvmssts_noperl(iss);
3386         }
3387
3388         b->eof  = eof;
3389         b->size = p->iosb.count;
3390         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3391         if (p->need_wake) {
3392             p->need_wake = FALSE;
3393             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3394         }
3395     } else {
3396         p->retry = 1;   /* initial call */
3397     }
3398
3399     if (eof) {                  /* flush the free queue, return when done */
3400         int n = sizeof(CBuf) + p->bufsize;
3401         while (1) {
3402             iss = lib$remqti(&p->free, &b);
3403             if (iss == LIB$_QUEWASEMP) return;
3404             _ckvmssts_noperl(iss);
3405             _ckvmssts_noperl(lib$free_vm(&n, &b));
3406         }
3407     }
3408
3409     iss = lib$remqti(&p->free, &b);
3410     if (iss == LIB$_QUEWASEMP) {
3411         int n = sizeof(CBuf) + p->bufsize;
3412         _ckvmssts_noperl(lib$get_vm(&n, &b));
3413         b->buf = (char *) b + sizeof(CBuf);
3414     } else {
3415        _ckvmssts_noperl(iss);
3416     }
3417
3418     p->curr = b;
3419     iss = sys$qio(0,p->chan_in,
3420              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3421              &p->iosb,
3422              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3423     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3424     _ckvmssts_noperl(iss);
3425 }
3426
3427
3428 /* writes queued buffers to output, waits for each to complete before
3429    doing the next */
3430
3431 static void
3432 pipe_tochild2_ast(pPipe p)
3433 {
3434     pCBuf b = p->curr2;
3435     int iss = p->iosb2.status;
3436     int n = sizeof(CBuf) + p->bufsize;
3437     int done = (p->info && p->info->done) ||
3438               iss == SS$_CANCEL || iss == SS$_ABORT;
3439 #if defined(PERL_IMPLICIT_CONTEXT)
3440     pTHX = p->thx;
3441 #endif
3442
3443     do {
3444         if (p->type) {         /* type=1 has old buffer, dispose */
3445             if (p->shut_on_empty) {
3446                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3447             } else {
3448                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3449             }
3450             p->type = 0;
3451         }
3452
3453         iss = lib$remqti(&p->wait, &b);
3454         if (iss == LIB$_QUEWASEMP) {
3455             if (p->shut_on_empty) {
3456                 if (done) {
3457                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3458                     *p->pipe_done = TRUE;
3459                     _ckvmssts_noperl(sys$setef(pipe_ef));
3460                 } else {
3461                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3462                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3463                 }
3464                 return;
3465             }
3466             p->need_wake = TRUE;
3467             return;
3468         }
3469         _ckvmssts_noperl(iss);
3470         p->type = 1;
3471     } while (done);
3472
3473
3474     p->curr2 = b;
3475     if (b->eof) {
3476         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3477             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3478     } else {
3479         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3480             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3481     }
3482
3483     return;
3484
3485 }
3486
3487
3488 static pPipe
3489 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3490 {
3491     pPipe p;
3492     char mbx1[64], mbx2[64];
3493     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3494                                       DSC$K_CLASS_S, mbx1},
3495                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3496                                       DSC$K_CLASS_S, mbx2};
3497     unsigned int dviitm = DVI$_DEVBUFSIZ;
3498
3499     int n = sizeof(Pipe);
3500     _ckvmssts_noperl(lib$get_vm(&n, &p));
3501     create_mbx(&p->chan_in , &d_mbx1);
3502     create_mbx(&p->chan_out, &d_mbx2);
3503
3504     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3505     n = p->bufsize * sizeof(char);
3506     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3507     p->shut_on_empty = FALSE;
3508     p->info   = 0;
3509     p->type   = 0;
3510     p->iosb.status = SS$_NORMAL;
3511 #if defined(PERL_IMPLICIT_CONTEXT)
3512     p->thx = aTHX;
3513 #endif
3514     pipe_infromchild_ast(p);
3515
3516     strcpy(wmbx, mbx1);
3517     strcpy(rmbx, mbx2);
3518     return p;
3519 }
3520
3521 static void
3522 pipe_infromchild_ast(pPipe p)
3523 {
3524     int iss = p->iosb.status;
3525     int eof = (iss == SS$_ENDOFFILE);
3526     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3527     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3528 #if defined(PERL_IMPLICIT_CONTEXT)
3529     pTHX = p->thx;
3530 #endif
3531
3532     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3533         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3534         p->chan_out = 0;
3535     }
3536
3537     /* read completed:
3538             input shutdown if EOF from self (done or shut_on_empty)
3539             output shutdown if closing flag set (my_pclose)
3540             send data/eof from child or eof from self
3541             otherwise, re-read (snarf of data from child)
3542     */
3543
3544     if (p->type == 1) {
3545         p->type = 0;
3546         if (myeof && p->chan_in) {                  /* input shutdown */
3547             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3548             p->chan_in = 0;
3549         }
3550
3551         if (p->chan_out) {
3552             if (myeof || kideof) {      /* pass EOF to parent */
3553                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3554                                          pipe_infromchild_ast, p,
3555                                          0, 0, 0, 0, 0, 0));
3556                 return;
3557             } else if (eof) {       /* eat EOF --- fall through to read*/
3558
3559             } else {                /* transmit data */
3560                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3561                                          pipe_infromchild_ast,p,
3562                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3563                 return;
3564             }
3565         }
3566     }
3567
3568     /*  everything shut? flag as done */
3569
3570     if (!p->chan_in && !p->chan_out) {
3571         *p->pipe_done = TRUE;
3572         _ckvmssts_noperl(sys$setef(pipe_ef));
3573         return;
3574     }
3575
3576     /* write completed (or read, if snarfing from child)
3577             if still have input active,
3578                queue read...immediate mode if shut_on_empty so we get EOF if empty
3579             otherwise,
3580                check if Perl reading, generate EOFs as needed
3581     */
3582
3583     if (p->type == 0) {
3584         p->type = 1;
3585         if (p->chan_in) {
3586             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3587                           pipe_infromchild_ast,p,
3588                           p->buf, p->bufsize, 0, 0, 0, 0);
3589             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3590             _ckvmssts_noperl(iss);
3591         } else {           /* send EOFs for extra reads */
3592             p->iosb.status = SS$_ENDOFFILE;
3593             p->iosb.dvispec = 0;
3594             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3595                                      0, 0, 0,
3596                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3597         }
3598     }
3599 }
3600
3601 static pPipe
3602 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3603 {
3604     pPipe p;
3605     char mbx[64];
3606     unsigned long dviitm = DVI$_DEVBUFSIZ;
3607     struct stat s;
3608     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3609                                       DSC$K_CLASS_S, mbx};
3610     int n = sizeof(Pipe);
3611
3612     /* things like terminals and mbx's don't need this filter */
3613     if (fd && fstat(fd,&s) == 0) {
3614         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3615         char device[65];
3616         unsigned short dev_len;
3617         struct dsc$descriptor_s d_dev;
3618         char * cptr;
3619         struct item_list_3 items[3];
3620         int status;
3621         unsigned short dvi_iosb[4];
3622
3623         cptr = getname(fd, out, 1);
3624         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3625         d_dev.dsc$a_pointer = out;
3626         d_dev.dsc$w_length = strlen(out);
3627         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3628         d_dev.dsc$b_class = DSC$K_CLASS_S;
3629
3630         items[0].len = 4;
3631         items[0].code = DVI$_DEVCHAR;
3632         items[0].bufadr = &devchar;
3633         items[0].retadr = NULL;
3634         items[1].len = 64;
3635         items[1].code = DVI$_FULLDEVNAM;
3636         items[1].bufadr = device;
3637         items[1].retadr = &dev_len;
3638         items[2].len = 0;
3639         items[2].code = 0;
3640
3641         status = sys$getdviw
3642                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3643         _ckvmssts_noperl(status);
3644         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3645             device[dev_len] = 0;
3646
3647             if (!(devchar & DEV$M_DIR)) {
3648                 strcpy(out, device);
3649                 return 0;
3650             }
3651         }
3652     }
3653
3654     _ckvmssts_noperl(lib$get_vm(&n, &p));
3655     p->fd_out = dup(fd);
3656     create_mbx(&p->chan_in, &d_mbx);
3657     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3658     n = (p->bufsize+1) * sizeof(char);
3659     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3660     p->shut_on_empty = FALSE;
3661     p->retry = 0;
3662     p->info  = 0;
3663     strcpy(out, mbx);
3664
3665     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3666                              pipe_mbxtofd_ast, p,
3667                              p->buf, p->bufsize, 0, 0, 0, 0));
3668
3669     return p;
3670 }
3671
3672 static void
3673 pipe_mbxtofd_ast(pPipe p)
3674 {
3675     int iss = p->iosb.status;
3676     int done = p->info->done;
3677     int iss2;
3678     int eof = (iss == SS$_ENDOFFILE);
3679     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3680     int err = !(iss&1) && !eof;
3681 #if defined(PERL_IMPLICIT_CONTEXT)
3682     pTHX = p->thx;
3683 #endif
3684
3685     if (done && myeof) {               /* end piping */
3686         close(p->fd_out);
3687         sys$dassgn(p->chan_in);
3688         *p->pipe_done = TRUE;
3689         _ckvmssts_noperl(sys$setef(pipe_ef));
3690         return;
3691     }
3692
3693     if (!err && !eof) {             /* good data to send to file */
3694         p->buf[p->iosb.count] = '\n';
3695         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3696         if (iss2 < 0) {
3697             p->retry++;
3698             if (p->retry < MAX_RETRY) {
3699                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3700                 return;
3701             }
3702         }
3703         p->retry = 0;
3704     } else if (err) {
3705         _ckvmssts_noperl(iss);
3706     }
3707
3708
3709     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3710           pipe_mbxtofd_ast, p,
3711           p->buf, p->bufsize, 0, 0, 0, 0);
3712     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3713     _ckvmssts_noperl(iss);
3714 }
3715
3716
3717 typedef struct _pipeloc     PLOC;
3718 typedef struct _pipeloc*   pPLOC;
3719
3720 struct _pipeloc {
3721     pPLOC   next;
3722     char    dir[NAM$C_MAXRSS+1];
3723 };
3724 static pPLOC  head_PLOC = 0;
3725
3726 void
3727 free_pipelocs(pTHX_ void *head)
3728 {
3729     pPLOC p, pnext;
3730     pPLOC *pHead = (pPLOC *)head;
3731
3732     p = *pHead;
3733     while (p) {
3734         pnext = p->next;
3735         PerlMem_free(p);
3736         p = pnext;
3737     }
3738     *pHead = 0;
3739 }
3740
3741 static void
3742 store_pipelocs(pTHX)
3743 {
3744     int    i;
3745     pPLOC  p;
3746     AV    *av = 0;
3747     SV    *dirsv;
3748     GV    *gv;
3749     char  *dir, *x;
3750     char  *unixdir;
3751     char  temp[NAM$C_MAXRSS+1];
3752     STRLEN n_a;
3753
3754     if (head_PLOC)
3755         free_pipelocs(aTHX_ &head_PLOC);
3756
3757 /*  the . directory from @INC comes last */
3758
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     strcpy(p->dir,"./");
3764
3765 /*  get the directory from $^X */
3766
3767     unixdir = PerlMem_malloc(VMS_MAXRSS);
3768     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3769
3770 #ifdef PERL_IMPLICIT_CONTEXT
3771     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3772 #else
3773     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3774 #endif
3775         strcpy(temp, PL_origargv[0]);
3776         x = strrchr(temp,']');
3777         if (x == NULL) {
3778         x = strrchr(temp,'>');
3779           if (x == NULL) {
3780             /* It could be a UNIX path */
3781             x = strrchr(temp,'/');
3782           }
3783         }
3784         if (x)
3785           x[1] = '\0';
3786         else {
3787           /* Got a bare name, so use default directory */
3788           temp[0] = '.';
3789           temp[1] = '\0';
3790         }
3791
3792         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3793             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3794             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3795             p->next = head_PLOC;
3796             head_PLOC = p;
3797             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3798             p->dir[NAM$C_MAXRSS] = '\0';
3799         }
3800     }
3801
3802 /*  reverse order of @INC entries, skip "." since entered above */
3803
3804 #ifdef PERL_IMPLICIT_CONTEXT
3805     if (aTHX)
3806 #endif
3807     if (PL_incgv) av = GvAVn(PL_incgv);
3808
3809     for (i = 0; av && i <= AvFILL(av); i++) {
3810         dirsv = *av_fetch(av,i,TRUE);
3811
3812         if (SvROK(dirsv)) continue;
3813         dir = SvPVx(dirsv,n_a);
3814         if (strcmp(dir,".") == 0) continue;
3815         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3816             continue;
3817
3818         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3819         p->next = head_PLOC;
3820         head_PLOC = p;
3821         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3822         p->dir[NAM$C_MAXRSS] = '\0';
3823     }
3824
3825 /* most likely spot (ARCHLIB) put first in the list */
3826
3827 #ifdef ARCHLIB_EXP
3828     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3829         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3830         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3831         p->next = head_PLOC;
3832         head_PLOC = p;
3833         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3834         p->dir[NAM$C_MAXRSS] = '\0';
3835     }
3836 #endif
3837     PerlMem_free(unixdir);
3838 }
3839
3840 static I32
3841 Perl_cando_by_name_int
3842    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3843 #if !defined(PERL_IMPLICIT_CONTEXT)
3844 #define cando_by_name_int               Perl_cando_by_name_int
3845 #else
3846 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3847 #endif
3848
3849 static char *
3850 find_vmspipe(pTHX)
3851 {
3852     static int   vmspipe_file_status = 0;
3853     static char  vmspipe_file[NAM$C_MAXRSS+1];
3854
3855     /* already found? Check and use ... need read+execute permission */
3856
3857     if (vmspipe_file_status == 1) {
3858         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3859          && cando_by_name_int
3860            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3861             return vmspipe_file;
3862         }
3863         vmspipe_file_status = 0;
3864     }
3865
3866     /* scan through stored @INC, $^X */
3867
3868     if (vmspipe_file_status == 0) {
3869         char file[NAM$C_MAXRSS+1];
3870         pPLOC  p = head_PLOC;
3871
3872         while (p) {
3873             char * exp_res;
3874             int dirlen;
3875             strcpy(file, p->dir);
3876             dirlen = strlen(file);
3877             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3878             file[NAM$C_MAXRSS] = '\0';
3879             p = p->next;
3880
3881             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3882             if (!exp_res) continue;
3883
3884             if (cando_by_name_int
3885                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3886              && cando_by_name_int
3887                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3888                 vmspipe_file_status = 1;
3889                 return vmspipe_file;
3890             }
3891         }
3892         vmspipe_file_status = -1;   /* failed, use tempfiles */
3893     }
3894
3895     return 0;
3896 }
3897
3898 static FILE *
3899 vmspipe_tempfile(pTHX)
3900 {
3901     char file[NAM$C_MAXRSS+1];
3902     FILE *fp;
3903     static int index = 0;
3904     Stat_t s0, s1;
3905     int cmp_result;
3906
3907     /* create a tempfile */
3908
3909     /* we can't go from   W, shr=get to  R, shr=get without
3910        an intermediate vulnerable state, so don't bother trying...
3911
3912        and lib$spawn doesn't shr=put, so have to close the write
3913
3914        So... match up the creation date/time and the FID to
3915        make sure we're dealing with the same file
3916
3917     */
3918
3919     index++;
3920     if (!decc_filename_unix_only) {
3921       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3922       fp = fopen(file,"w");
3923       if (!fp) {
3924         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3925         fp = fopen(file,"w");
3926         if (!fp) {
3927             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3928             fp = fopen(file,"w");
3929         }
3930       }
3931      }
3932      else {
3933       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3934       fp = fopen(file,"w");
3935       if (!fp) {
3936         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3937         fp = fopen(file,"w");
3938         if (!fp) {
3939           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3940           fp = fopen(file,"w");
3941         }
3942       }
3943     }
3944     if (!fp) return 0;  /* we're hosed */
3945
3946     fprintf(fp,"$! 'f$verify(0)'\n");
3947     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3948     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3949     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3950     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3951     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3952     fprintf(fp,"$ perl_del    = \"delete\"\n");
3953     fprintf(fp,"$ pif         = \"if\"\n");
3954     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3955     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3956     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3957     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3958     fprintf(fp,"$!  --- build command line to get max possible length\n");
3959     fprintf(fp,"$c=perl_popen_cmd0\n");
3960     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3961     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3962     fprintf(fp,"$x=perl_popen_cmd3\n");
3963     fprintf(fp,"$c=c+x\n");
3964     fprintf(fp,"$ perl_on\n");
3965     fprintf(fp,"$ 'c'\n");
3966     fprintf(fp,"$ perl_status = $STATUS\n");
3967     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3968     fprintf(fp,"$ perl_exit 'perl_status'\n");
3969     fsync(fileno(fp));
3970
3971     fgetname(fp, file, 1);
3972     fstat(fileno(fp), &s0.crtl_stat);
3973     fclose(fp);
3974
3975     if (decc_filename_unix_only)
3976         int_tounixspec(file, file, NULL);
3977     fp = fopen(file,"r","shr=get");
3978     if (!fp) return 0;
3979     fstat(fileno(fp), &s1.crtl_stat);
3980
3981     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3982     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3983         fclose(fp);
3984         return 0;
3985     }
3986
3987     return fp;
3988 }
3989
3990
3991 static int vms_is_syscommand_xterm(void)
3992 {
3993     const static struct dsc$descriptor_s syscommand_dsc =
3994       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3995
3996     const static struct dsc$descriptor_s decwdisplay_dsc =
3997       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3998
3999     struct item_list_3 items[2];
4000     unsigned short dvi_iosb[4];
4001     unsigned long devchar;
4002     unsigned long devclass;
4003     int status;
4004
4005     /* Very simple check to guess if sys$command is a decterm? */
4006     /* First see if the DECW$DISPLAY: device exists */
4007     items[0].len = 4;
4008     items[0].code = DVI$_DEVCHAR;
4009     items[0].bufadr = &devchar;
4010     items[0].retadr = NULL;
4011     items[1].len = 0;
4012     items[1].code = 0;
4013
4014     status = sys$getdviw
4015         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
4016
4017     if ($VMS_STATUS_SUCCESS(status)) {
4018         status = dvi_iosb[0];
4019     }
4020
4021     if (!$VMS_STATUS_SUCCESS(status)) {
4022         SETERRNO(EVMSERR, status);
4023         return -1;
4024     }
4025
4026     /* If it does, then for now assume that we are on a workstation */
4027     /* Now verify that SYS$COMMAND is a terminal */
4028     /* for creating the debugger DECTerm */
4029
4030     items[0].len = 4;
4031     items[0].code = DVI$_DEVCLASS;
4032     items[0].bufadr = &devclass;
4033     items[0].retadr = NULL;
4034     items[1].len = 0;
4035     items[1].code = 0;
4036
4037     status = sys$getdviw
4038         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
4039
4040     if ($VMS_STATUS_SUCCESS(status)) {
4041         status = dvi_iosb[0];
4042     }
4043
4044     if (!$VMS_STATUS_SUCCESS(status)) {
4045         SETERRNO(EVMSERR, status);
4046         return -1;
4047     }
4048     else {
4049         if (devclass == DC$_TERM) {
4050             return 0;
4051         }
4052     }
4053     return -1;
4054 }
4055
4056 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
4057 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
4058 {
4059     int status;
4060     int ret_stat;
4061     char * ret_char;
4062     char device_name[65];
4063     unsigned short device_name_len;
4064     struct dsc$descriptor_s customization_dsc;
4065     struct dsc$descriptor_s device_name_dsc;
4066     const char * cptr;
4067     char * tptr;
4068     char customization[200];
4069     char title[40];
4070     pInfo info = NULL;
4071     char mbx1[64];
4072     unsigned short p_chan;
4073     int n;
4074     unsigned short iosb[4];
4075     struct item_list_3 items[2];
4076     const char * cust_str =
4077         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
4078     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
4079                                           DSC$K_CLASS_S, mbx1};
4080
4081      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4082     /*---------------------------------------*/
4083     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
4084
4085
4086     /* Make sure that this is from the Perl debugger */
4087     ret_char = strstr(cmd," xterm ");
4088     if (ret_char == NULL)
4089         return NULL;
4090     cptr = ret_char + 7;
4091     ret_char = strstr(cmd,"tty");
4092     if (ret_char == NULL)
4093         return NULL;
4094     ret_char = strstr(cmd,"sleep");
4095     if (ret_char == NULL)
4096         return NULL;
4097
4098     if (decw_term_port == 0) {
4099         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4100         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4101         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4102
4103        status = lib$find_image_symbol
4104                                (&filename1_dsc,
4105                                 &decw_term_port_dsc,
4106                                 (void *)&decw_term_port,
4107                                 NULL,
4108                                 0);
4109
4110         /* Try again with the other image name */
4111         if (!$VMS_STATUS_SUCCESS(status)) {
4112
4113            status = lib$find_image_symbol
4114                                (&filename2_dsc,
4115                                 &decw_term_port_dsc,
4116                                 (void *)&decw_term_port,
4117                                 NULL,
4118                                 0);
4119
4120         }
4121
4122     }
4123
4124
4125     /* No decw$term_port, give it up */
4126     if (!$VMS_STATUS_SUCCESS(status))
4127         return NULL;
4128
4129     /* Are we on a workstation? */
4130     /* to do: capture the rows / columns and pass their properties */
4131     ret_stat = vms_is_syscommand_xterm();
4132     if (ret_stat < 0)
4133         return NULL;
4134
4135     /* Make the title: */
4136     ret_char = strstr(cptr,"-title");
4137     if (ret_char != NULL) {
4138         while ((*cptr != 0) && (*cptr != '\"')) {
4139             cptr++;
4140         }
4141         if (*cptr == '\"')
4142             cptr++;
4143         n = 0;
4144         while ((*cptr != 0) && (*cptr != '\"')) {
4145             title[n] = *cptr;
4146             n++;
4147             if (n == 39) {
4148                 title[39] == 0;
4149                 break;
4150             }
4151             cptr++;
4152         }
4153         title[n] = 0;
4154     }
4155     else {
4156             /* Default title */
4157             strcpy(title,"Perl Debug DECTerm");
4158     }
4159     sprintf(customization, cust_str, title);
4160
4161     customization_dsc.dsc$a_pointer = customization;
4162     customization_dsc.dsc$w_length = strlen(customization);
4163     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4164     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4165
4166     device_name_dsc.dsc$a_pointer = device_name;
4167     device_name_dsc.dsc$w_length = sizeof device_name -1;
4168     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4169     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4170
4171     device_name_len = 0;
4172
4173     /* Try to create the window */
4174      status = (*decw_term_port)
4175        (NULL,
4176         NULL,
4177         &customization_dsc,
4178         &device_name_dsc,
4179         &device_name_len,
4180         NULL,
4181         NULL,
4182         NULL);
4183     if (!$VMS_STATUS_SUCCESS(status)) {
4184         SETERRNO(EVMSERR, status);
4185         return NULL;
4186     }
4187
4188     device_name[device_name_len] = '\0';
4189
4190     /* Need to set this up to look like a pipe for cleanup */
4191     n = sizeof(Info);
4192     status = lib$get_vm(&n, &info);
4193     if (!$VMS_STATUS_SUCCESS(status)) {
4194         SETERRNO(ENOMEM, status);
4195         return NULL;
4196     }
4197
4198     info->mode = *mode;
4199     info->done = FALSE;
4200     info->completion = 0;
4201     info->closing    = FALSE;
4202     info->in         = 0;
4203     info->out        = 0;
4204     info->err        = 0;
4205     info->fp         = NULL;
4206     info->useFILE    = 0;
4207     info->waiting    = 0;
4208     info->in_done    = TRUE;
4209     info->out_done   = TRUE;
4210     info->err_done   = TRUE;
4211
4212     /* Assign a channel on this so that it will persist, and not login */
4213     /* We stash this channel in the info structure for reference. */
4214     /* The created xterm self destructs when the last channel is removed */
4215     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4216     /* So leave this assigned. */
4217     device_name_dsc.dsc$w_length = device_name_len;
4218     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4219     if (!$VMS_STATUS_SUCCESS(status)) {
4220         SETERRNO(EVMSERR, status);
4221         return NULL;
4222     }
4223     info->xchan_valid = 1;
4224
4225     /* Now create a mailbox to be read by the application */
4226
4227     create_mbx(&p_chan, &d_mbx1);
4228
4229     /* write the name of the created terminal to the mailbox */
4230     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4231             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4232
4233     if (!$VMS_STATUS_SUCCESS(status)) {
4234         SETERRNO(EVMSERR, status);
4235         return NULL;
4236     }
4237
4238     info->fp  = PerlIO_open(mbx1, mode);
4239
4240     /* Done with this channel */
4241     sys$dassgn(p_chan);
4242
4243     /* If any errors, then clean up */
4244     if (!info->fp) {
4245         n = sizeof(Info);
4246         _ckvmssts_noperl(lib$free_vm(&n, &info));
4247         return NULL;
4248         }
4249
4250     /* All done */
4251     return info->fp;
4252 }
4253
4254 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4255
4256 static PerlIO *
4257 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4258 {
4259     static int handler_set_up = FALSE;
4260     PerlIO * ret_fp;
4261     unsigned long int sts, flags = CLI$M_NOWAIT;
4262     /* The use of a GLOBAL table (as was done previously) rendered
4263      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4264      * environment.  Hence we've switched to LOCAL symbol table.
4265      */
4266     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4267     int j, wait = 0, n;
4268     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4269     char *in, *out, *err, mbx[512];
4270     FILE *tpipe = 0;
4271     char tfilebuf[NAM$C_MAXRSS+1];
4272     pInfo info = NULL;
4273     char cmd_sym_name[20];
4274     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4275                                       DSC$K_CLASS_S, symbol};
4276     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4277                                       DSC$K_CLASS_S, 0};
4278     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4279                                       DSC$K_CLASS_S, cmd_sym_name};
4280     struct dsc$descriptor_s *vmscmd;
4281     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4282     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4283     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4284
4285     /* Check here for Xterm create request.  This means looking for
4286      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4287      *  is possible to create an xterm.
4288      */
4289     if (*in_mode == 'r') {
4290         PerlIO * xterm_fd;
4291
4292 #if defined(PERL_IMPLICIT_CONTEXT)
4293         /* Can not fork an xterm with a NULL context */
4294         /* This probably could never happen */
4295         xterm_fd = NULL;
4296         if (aTHX != NULL)
4297 #endif
4298         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4299         if (xterm_fd != NULL)
4300             return xterm_fd;
4301     }
4302
4303     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4304
4305     /* once-per-program initialization...
4306        note that the SETAST calls and the dual test of pipe_ef
4307        makes sure that only the FIRST thread through here does
4308        the initialization...all other threads wait until it's
4309        done.
4310
4311        Yeah, uglier than a pthread call, it's got all the stuff inline
4312        rather than in a separate routine.
4313     */
4314
4315     if (!pipe_ef) {
4316         _ckvmssts_noperl(sys$setast(0));
4317         if (!pipe_ef) {
4318             unsigned long int pidcode = JPI$_PID;
4319             $DESCRIPTOR(d_delay, RETRY_DELAY);
4320             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4321             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4322             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4323         }
4324         if (!handler_set_up) {
4325           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4326           handler_set_up = TRUE;
4327         }
4328         _ckvmssts_noperl(sys$setast(1));
4329     }
4330
4331     /* see if we can find a VMSPIPE.COM */
4332
4333     tfilebuf[0] = '@';
4334     vmspipe = find_vmspipe(aTHX);
4335     if (vmspipe) {
4336         strcpy(tfilebuf+1,vmspipe);
4337     } else {        /* uh, oh...we're in tempfile hell */
4338         tpipe = vmspipe_tempfile(aTHX);
4339         if (!tpipe) {       /* a fish popular in Boston */
4340             if (ckWARN(WARN_PIPE)) {
4341                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4342             }
4343         return NULL;
4344         }
4345         fgetname(tpipe,tfilebuf+1,1);
4346     }
4347     vmspipedsc.dsc$a_pointer = tfilebuf;
4348     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4349
4350     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4351     if (!(sts & 1)) {
4352       switch (sts) {
4353         case RMS$_FNF:  case RMS$_DNF:
4354           set_errno(ENOENT); break;
4355         case RMS$_DIR:
4356           set_errno(ENOTDIR); break;
4357         case RMS$_DEV:
4358           set_errno(ENODEV); break;
4359         case RMS$_PRV:
4360           set_errno(EACCES); break;
4361         case RMS$_SYN:
4362           set_errno(EINVAL); break;
4363         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4364           set_errno(E2BIG); break;
4365         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4366           _ckvmssts_noperl(sts); /* fall through */
4367         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4368           set_errno(EVMSERR);
4369       }
4370       set_vaxc_errno(sts);
4371       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4372         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4373       }
4374       *psts = sts;
4375       return NULL;
4376     }
4377     n = sizeof(Info);
4378     _ckvmssts_noperl(lib$get_vm(&n, &info));
4379
4380     strcpy(mode,in_mode);
4381     info->mode = *mode;
4382     info->done = FALSE;
4383     info->completion = 0;
4384     info->closing    = FALSE;
4385     info->in         = 0;
4386     info->out        = 0;
4387     info->err        = 0;
4388     info->fp         = NULL;
4389     info->useFILE    = 0;
4390     info->waiting    = 0;
4391     info->in_done    = TRUE;
4392     info->out_done   = TRUE;
4393     info->err_done   = TRUE;
4394     info->xchan      = 0;
4395     info->xchan_valid = 0;
4396
4397     in = PerlMem_malloc(VMS_MAXRSS);
4398     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4399     out = PerlMem_malloc(VMS_MAXRSS);
4400     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4401     err = PerlMem_malloc(VMS_MAXRSS);
4402     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4403
4404     in[0] = out[0] = err[0] = '\0';
4405
4406     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4407         info->useFILE = 1;
4408         strcpy(p,p+1);
4409     }
4410     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4411         wait = 1;
4412         strcpy(p,p+1);
4413     }
4414
4415     if (*mode == 'r') {             /* piping from subroutine */
4416
4417         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4418         if (info->out) {
4419             info->out->pipe_done = &info->out_done;
4420             info->out_done = FALSE;
4421             info->out->info = info;
4422         }
4423         if (!info->useFILE) {
4424             info->fp  = PerlIO_open(mbx, mode);
4425         } else {
4426             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4427             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4428         }
4429
4430         if (!info->fp && info->out) {
4431             sys$cancel(info->out->chan_out);
4432
4433             while (!info->out_done) {
4434                 int done;
4435                 _ckvmssts_noperl(sys$setast(0));
4436                 done = info->out_done;
4437                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4438                 _ckvmssts_noperl(sys$setast(1));
4439                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4440             }
4441
4442             if (info->out->buf) {
4443                 n = info->out->bufsize * sizeof(char);
4444                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4445             }
4446             n = sizeof(Pipe);
4447             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4448             n = sizeof(Info);
4449             _ckvmssts_noperl(lib$free_vm(&n, &info));
4450             *psts = RMS$_FNF;
4451             return NULL;
4452         }
4453
4454         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4455         if (info->err) {
4456             info->err->pipe_done = &info->err_done;
4457             info->err_done = FALSE;
4458             info->err->info = info;
4459         }
4460
4461     } else if (*mode == 'w') {      /* piping to subroutine */
4462
4463         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4464         if (info->out) {
4465             info->out->pipe_done = &info->out_done;
4466             info->out_done = FALSE;
4467             info->out->info = info;
4468         }
4469
4470         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4471         if (info->err) {
4472             info->err->pipe_done = &info->err_done;
4473             info->err_done = FALSE;
4474             info->err->info = info;
4475         }
4476
4477         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4478         if (!info->useFILE) {
4479             info->fp  = PerlIO_open(mbx, mode);
4480         } else {
4481             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4482             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4483         }
4484
4485         if (info->in) {
4486             info->in->pipe_done = &info->in_done;
4487             info->in_done = FALSE;
4488             info->in->info = info;
4489         }
4490
4491         /* error cleanup */
4492         if (!info->fp && info->in) {
4493             info->done = TRUE;
4494             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4495                                       0, 0, 0, 0, 0, 0, 0, 0));
4496
4497             while (!info->in_done) {
4498                 int done;
4499                 _ckvmssts_noperl(sys$setast(0));
4500                 done = info->in_done;
4501                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4502                 _ckvmssts_noperl(sys$setast(1));
4503                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4504             }
4505
4506             if (info->in->buf) {
4507                 n = info->in->bufsize * sizeof(char);
4508                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4509             }
4510             n = sizeof(Pipe);
4511             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4512             n = sizeof(Info);
4513             _ckvmssts_noperl(lib$free_vm(&n, &info));
4514             *psts = RMS$_FNF;
4515             return NULL;
4516         }
4517
4518
4519     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4520         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4521         if (info->out) {
4522             info->out->pipe_done = &info->out_done;
4523             info->out_done = FALSE;
4524             info->out->info = info;
4525         }
4526
4527         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4528         if (info->err) {
4529             info->err->pipe_done = &info->err_done;
4530             info->err_done = FALSE;
4531             info->err->info = info;
4532         }
4533     }
4534
4535     symbol[MAX_DCL_SYMBOL] = '\0';
4536
4537     strncpy(symbol, in, MAX_DCL_SYMBOL);
4538     d_symbol.dsc$w_length = strlen(symbol);
4539     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4540
4541     strncpy(symbol, err, MAX_DCL_SYMBOL);
4542     d_symbol.dsc$w_length = strlen(symbol);
4543     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4544
4545     strncpy(symbol, out, MAX_DCL_SYMBOL);
4546     d_symbol.dsc$w_length = strlen(symbol);
4547     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4548
4549     /* Done with the names for the pipes */
4550     PerlMem_free(err);
4551     PerlMem_free(out);
4552     PerlMem_free(in);
4553
4554     p = vmscmd->dsc$a_pointer;
4555     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4556     if (*p == '$') p++;                         /* remove leading $ */
4557     while (*p == ' ' || *p == '\t') p++;
4558
4559     for (j = 0; j < 4; j++) {
4560         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4561         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4562
4563     strncpy(symbol, p, MAX_DCL_SYMBOL);
4564     d_symbol.dsc$w_length = strlen(symbol);
4565     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4566
4567         if (strlen(p) > MAX_DCL_SYMBOL) {
4568             p += MAX_DCL_SYMBOL;
4569         } else {
4570             p += strlen(p);
4571         }
4572     }
4573     _ckvmssts_noperl(sys$setast(0));
4574     info->next=open_pipes;  /* prepend to list */
4575     open_pipes=info;
4576     _ckvmssts_noperl(sys$setast(1));
4577     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4578      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4579      * have SYS$COMMAND if we need it.
4580      */
4581     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4582                       0, &info->pid, &info->completion,
4583                       0, popen_completion_ast,info,0,0,0));
4584
4585     /* if we were using a tempfile, close it now */
4586
4587     if (tpipe) fclose(tpipe);
4588
4589     /* once the subprocess is spawned, it has copied the symbols and
4590        we can get rid of ours */
4591
4592     for (j = 0; j < 4; j++) {
4593         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4594         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4595     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4596     }
4597     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4598     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4599     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4600     vms_execfree(vmscmd);
4601
4602 #ifdef PERL_IMPLICIT_CONTEXT
4603     if (aTHX)
4604 #endif
4605     PL_forkprocess = info->pid;
4606
4607     ret_fp = info->fp;
4608     if (wait) {
4609          dSAVEDERRNO;
4610          int done = 0;
4611          while (!done) {
4612              _ckvmssts_noperl(sys$setast(0));
4613              done = info->done;
4614              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4615              _ckvmssts_noperl(sys$setast(1));
4616              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4617          }
4618         *psts = info->completion;
4619 /* Caller thinks it is open and tries to close it. */
4620 /* This causes some problems, as it changes the error status */
4621 /*        my_pclose(info->fp); */
4622
4623          /* If we did not have a file pointer open, then we have to */
4624          /* clean up here or eventually we will run out of something */
4625          SAVE_ERRNO;
4626          if (info->fp == NULL) {
4627              my_pclose_pinfo(aTHX_ info);
4628          }
4629          RESTORE_ERRNO;
4630
4631     } else {
4632         *psts = info->pid;
4633     }
4634     return ret_fp;
4635 }  /* end of safe_popen */
4636
4637
4638 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4639 PerlIO *
4640 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4641 {
4642     int sts;
4643     TAINT_ENV();
4644     TAINT_PROPER("popen");
4645     PERL_FLUSHALL_FOR_CHILD;
4646     return safe_popen(aTHX_ cmd,mode,&sts);
4647 }
4648
4649 /*}}}*/
4650
4651
4652 /* Routine to close and cleanup a pipe info structure */
4653
4654 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4655
4656     unsigned long int retsts;
4657     int done, iss, n;
4658     int status;
4659     pInfo next, last;
4660
4661     /* If we were writing to a subprocess, insure that someone reading from
4662      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4663      * produce an EOF record in the mailbox.
4664      *
4665      *  well, at least sometimes it *does*, so we have to watch out for
4666      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4667      */
4668      if (info->fp) {
4669         if (!info->useFILE
4670 #if defined(USE_ITHREADS)
4671           && my_perl
4672 #endif
4673           && PL_perlio_fd_refcnt)
4674             PerlIO_flush(info->fp);
4675         else
4676             fflush((FILE *)info->fp);
4677     }
4678
4679     _ckvmssts(sys$setast(0));
4680      info->closing = TRUE;
4681      done = info->done && info->in_done && info->out_done && info->err_done;
4682      /* hanging on write to Perl's input? cancel it */
4683      if (info->mode == 'r' && info->out && !info->out_done) {
4684         if (info->out->chan_out) {
4685             _ckvmssts(sys$cancel(info->out->chan_out));
4686             if (!info->out->chan_in) {   /* EOF generation, need AST */
4687                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4688             }
4689         }
4690      }
4691      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4692          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4693                            0, 0, 0, 0, 0, 0));
4694     _ckvmssts(sys$setast(1));
4695     if (info->fp) {
4696      if (!info->useFILE
4697 #if defined(USE_ITHREADS)
4698          && my_perl
4699 #endif
4700          && PL_perlio_fd_refcnt)
4701         PerlIO_close(info->fp);
4702      else
4703         fclose((FILE *)info->fp);
4704     }
4705      /*
4706         we have to wait until subprocess completes, but ALSO wait until all
4707         the i/o completes...otherwise we'll be freeing the "info" structure
4708         that the i/o ASTs could still be using...
4709      */
4710
4711      while (!done) {
4712          _ckvmssts(sys$setast(0));
4713          done = info->done && info->in_done && info->out_done && info->err_done;
4714          if (!done) _ckvmssts(sys$clref(pipe_ef));
4715          _ckvmssts(sys$setast(1));
4716          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4717      }
4718      retsts = info->completion;
4719
4720     /* remove from list of open pipes */
4721     _ckvmssts(sys$setast(0));
4722     last = NULL;
4723     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4724         if (next == info)
4725             break;
4726     }
4727
4728     if (last)
4729         last->next = info->next;
4730     else
4731         open_pipes = info->next;
4732     _ckvmssts(sys$setast(1));
4733
4734     /* free buffers and structures */
4735
4736     if (info->in) {
4737         if (info->in->buf) {
4738             n = info->in->bufsize * sizeof(char);
4739             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4740         }
4741         n = sizeof(Pipe);
4742         _ckvmssts(lib$free_vm(&n, &info->in));
4743     }
4744     if (info->out) {
4745         if (info->out->buf) {
4746             n = info->out->bufsize * sizeof(char);
4747             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4748         }
4749         n = sizeof(Pipe);
4750         _ckvmssts(lib$free_vm(&n, &info->out));
4751     }
4752     if (info->err) {
4753         if (info->err->buf) {
4754             n = info->err->bufsize * sizeof(char);
4755             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4756         }
4757         n = sizeof(Pipe);
4758         _ckvmssts(lib$free_vm(&n, &info->err));
4759     }
4760     n = sizeof(Info);
4761     _ckvmssts(lib$free_vm(&n, &info));
4762
4763     return retsts;
4764 }
4765
4766
4767 /*{{{  I32 my_pclose(PerlIO *fp)*/
4768 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4769 {
4770     pInfo info, last = NULL;
4771     I32 ret_status;
4772
4773     /* Fixme - need ast and mutex protection here */
4774     for (info = open_pipes; info != NULL; last = info, info = info->next)
4775         if (info->fp == fp) break;
4776
4777     if (info == NULL) {  /* no such pipe open */
4778       set_errno(ECHILD); /* quoth POSIX */
4779       set_vaxc_errno(SS$_NONEXPR);
4780       return -1;
4781     }
4782
4783     ret_status = my_pclose_pinfo(aTHX_ info);
4784
4785     return ret_status;
4786
4787 }  /* end of my_pclose() */
4788
4789 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4790   /* Roll our own prototype because we want this regardless of whether
4791    * _VMS_WAIT is defined.
4792    */
4793   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4794 #endif
4795 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4796    created with popen(); otherwise partially emulate waitpid() unless
4797    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4798    Also check processes not considered by the CRTL waitpid().
4799  */
4800 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4801 Pid_t
4802 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4803 {
4804     pInfo info;
4805     int done;
4806     int sts;
4807     int j;
4808
4809     if (statusp) *statusp = 0;
4810
4811     for (info = open_pipes; info != NULL; info = info->next)
4812         if (info->pid == pid) break;
4813
4814     if (info != NULL) {  /* we know about this child */
4815       while (!info->done) {
4816           _ckvmssts(sys$setast(0));
4817           done = info->done;
4818           if (!done) _ckvmssts(sys$clref(pipe_ef));
4819           _ckvmssts(sys$setast(1));
4820           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4821       }
4822
4823       if (statusp) *statusp = info->completion;
4824       return pid;
4825     }
4826
4827     /* child that already terminated? */
4828
4829     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4830         if (closed_list[j].pid == pid) {
4831             if (statusp) *statusp = closed_list[j].completion;
4832             return pid;
4833         }
4834     }
4835
4836     /* fall through if this child is not one of our own pipe children */
4837
4838 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4839
4840       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4841        * in 7.2 did we get a version that fills in the VMS completion
4842        * status as Perl has always tried to do.
4843        */
4844
4845       sts = __vms_waitpid( pid, statusp, flags );
4846
4847       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4848          return sts;
4849
4850       /* If the real waitpid tells us the child does not exist, we
4851        * fall through here to implement waiting for a child that
4852        * was created by some means other than exec() (say, spawned
4853        * from DCL) or to wait for a process that is not a subprocess
4854        * of the current process.
4855        */
4856
4857 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4858
4859     {
4860       $DESCRIPTOR(intdsc,"0 00:00:01");
4861       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4862       unsigned long int pidcode = JPI$_PID, mypid;
4863       unsigned long int interval[2];
4864       unsigned int jpi_iosb[2];
4865       struct itmlst_3 jpilist[2] = {
4866           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4867           {                      0,         0,                 0, 0}
4868       };
4869
4870       if (pid <= 0) {
4871         /* Sorry folks, we don't presently implement rooting around for
4872            the first child we can find, and we definitely don't want to
4873            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4874          */
4875         set_errno(ENOTSUP);
4876         return -1;
4877       }
4878
4879       /* Get the owner of the child so I can warn if it's not mine. If the
4880        * process doesn't exist or I don't have the privs to look at it,
4881        * I can go home early.
4882        */
4883       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4884       if (sts & 1) sts = jpi_iosb[0];
4885       if (!(sts & 1)) {
4886         switch (sts) {
4887             case SS$_NONEXPR:
4888                 set_errno(ECHILD);
4889                 break;
4890             case SS$_NOPRIV:
4891                 set_errno(EACCES);
4892                 break;
4893             default:
4894                 _ckvmssts(sts);
4895         }
4896         set_vaxc_errno(sts);
4897         return -1;
4898       }
4899
4900       if (ckWARN(WARN_EXEC)) {
4901         /* remind folks they are asking for non-standard waitpid behavior */
4902         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4903         if (ownerpid != mypid)
4904           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4905                       "waitpid: process %x is not a child of process %x",
4906                       pid,mypid);
4907       }
4908
4909       /* simply check on it once a second until it's not there anymore. */
4910
4911       _ckvmssts(sys$bintim(&intdsc,interval));
4912       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4913             _ckvmssts(sys$schdwk(0,0,interval,0));
4914             _ckvmssts(sys$hiber());
4915       }
4916       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4917
4918       _ckvmssts(sts);
4919       return pid;
4920     }
4921 }  /* end of waitpid() */
4922 /*}}}*/
4923 /*}}}*/
4924 /*}}}*/
4925
4926 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4927 char *
4928 my_gconvert(double val, int ndig, int trail, char *buf)
4929 {
4930   static char __gcvtbuf[DBL_DIG+1];
4931   char *loc;
4932
4933   loc = buf ? buf : __gcvtbuf;
4934
4935 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4936   if (val < 1) {
4937     sprintf(loc,"%.*g",ndig,val);
4938     return loc;
4939   }
4940 #endif
4941
4942   if (val) {
4943     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4944     return gcvt(val,ndig,loc);
4945   }
4946   else {
4947     loc[0] = '0'; loc[1] = '\0';
4948     return loc;
4949   }
4950
4951 }
4952 /*}}}*/
4953
4954 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4955 static int rms_free_search_context(struct FAB * fab)
4956 {
4957 struct NAM * nam;
4958
4959     nam = fab->fab$l_nam;
4960     nam->nam$b_nop |= NAM$M_SYNCHK;
4961     nam->nam$l_rlf = NULL;
4962     fab->fab$b_dns = 0;
4963     return sys$parse(fab, NULL, NULL);
4964 }
4965
4966 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4967 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4968 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4969 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4970 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4971 #define rms_nam_esll(nam) nam.nam$b_esl
4972 #define rms_nam_esl(nam) nam.nam$b_esl
4973 #define rms_nam_name(nam) nam.nam$l_name
4974 #define rms_nam_namel(nam) nam.nam$l_name
4975 #define rms_nam_type(nam) nam.nam$l_type
4976 #define rms_nam_typel(nam) nam.nam$l_type
4977 #define rms_nam_ver(nam) nam.nam$l_ver
4978 #define rms_nam_verl(nam) nam.nam$l_ver
4979 #define rms_nam_rsll(nam) nam.nam$b_rsl
4980 #define rms_nam_rsl(nam) nam.nam$b_rsl
4981 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4982 #define rms_set_fna(fab, nam, name, size) \
4983         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4984 #define rms_get_fna(fab, nam) fab.fab$l_fna
4985 #define rms_set_dna(fab, nam, name, size) \
4986         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4987 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4988 #define rms_set_esa(nam, name, size) \
4989         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4990 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4991         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4992 #define rms_set_rsa(nam, name, size) \
4993         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4994 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4995         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4996 #define rms_nam_name_type_l_size(nam) \
4997         (nam.nam$b_name + nam.nam$b_type)
4998 #else
4999 static int rms_free_search_context(struct FAB * fab)
5000 {
5001 struct NAML * nam;
5002
5003     nam = fab->fab$l_naml;
5004     nam->naml$b_nop |= NAM$M_SYNCHK;
5005     nam->naml$l_rlf = NULL;
5006     nam->naml$l_long_defname_size = 0;
5007
5008     fab->fab$b_dns = 0;
5009     return sys$parse(fab, NULL, NULL);
5010 }
5011
5012 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
5013 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
5014 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
5015 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
5016 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
5017 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
5018 #define rms_nam_esl(nam) nam.naml$b_esl
5019 #define rms_nam_name(nam) nam.naml$l_name
5020 #define rms_nam_namel(nam) nam.naml$l_long_name
5021 #define rms_nam_type(nam) nam.naml$l_type
5022 #define rms_nam_typel(nam) nam.naml$l_long_type
5023 #define rms_nam_ver(nam) nam.naml$l_ver
5024 #define rms_nam_verl(nam) nam.naml$l_long_ver
5025 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
5026 #define rms_nam_rsl(nam) nam.naml$b_rsl
5027 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
5028 #define rms_set_fna(fab, nam, name, size) \
5029         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
5030         nam.naml$l_long_filename_size = size; \
5031         nam.naml$l_long_filename = name;}
5032 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
5033 #define rms_set_dna(fab, nam, name, size) \
5034         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
5035         nam.naml$l_long_defname_size = size; \
5036         nam.naml$l_long_defname = name; }
5037 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
5038 #define rms_set_esa(nam, name, size) \
5039         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
5040         nam.naml$l_long_expand_alloc = size; \
5041         nam.naml$l_long_expand = name; }
5042 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
5043         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
5044         nam.naml$l_long_expand = l_name; \
5045         nam.naml$l_long_expand_alloc = l_size; }
5046 #define rms_set_rsa(nam, name, size) \
5047         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
5048         nam.naml$l_long_result = name; \
5049         nam.naml$l_long_result_alloc = size; }
5050 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
5051         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
5052         nam.naml$l_long_result = l_name; \
5053         nam.naml$l_long_result_alloc = l_size; }
5054 #define rms_nam_name_type_l_size(nam) \
5055         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
5056 #endif
5057
5058
5059 /* rms_erase
5060  * The CRTL for 8.3 and later can create symbolic links in any mode,
5061  * however in 8.3 the unlink/remove/delete routines will only properly handle
5062  * them if one of the PCP modes is active.
5063  */
5064 static int rms_erase(const char * vmsname)
5065 {
5066   int status;
5067   struct FAB myfab = cc$rms_fab;
5068   rms_setup_nam(mynam);
5069
5070   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
5071   rms_bind_fab_nam(myfab, mynam);
5072
5073 #ifdef NAML$M_OPEN_SPECIAL
5074   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5075 #endif
5076
5077   status = sys$erase(&myfab, 0, 0);
5078
5079   return status;
5080 }
5081
5082
5083 static int
5084 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5085                     const struct dsc$descriptor_s * vms_dst_dsc,
5086                     unsigned long flags)
5087 {
5088     /*  VMS and UNIX handle file permissions differently and the
5089      * the same ACL trick may be needed for renaming files,
5090      * especially if they are directories.
5091      */
5092
5093    /* todo: get kill_file and rename to share common code */
5094    /* I can not find online documentation for $change_acl
5095     * it appears to be replaced by $set_security some time ago */
5096
5097 const unsigned int access_mode = 0;
5098 $DESCRIPTOR(obj_file_dsc,"FILE");
5099 char *vmsname;
5100 char *rslt;
5101 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
5102 int aclsts, fndsts, rnsts = -1;
5103 unsigned int ctx = 0;
5104 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5105 struct dsc$descriptor_s * clean_dsc;
5106
5107 struct myacedef {
5108     unsigned char myace$b_length;
5109     unsigned char myace$b_type;
5110     unsigned short int myace$w_flags;
5111     unsigned long int myace$l_access;
5112     unsigned long int myace$l_ident;
5113 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5114              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5115              0},
5116              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5117
5118 struct item_list_3
5119         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5120                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5121                       {0,0,0,0}},
5122         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5123         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5124                      {0,0,0,0}};
5125
5126
5127     /* Expand the input spec using RMS, since we do not want to put
5128      * ACLs on the target of a symbolic link */
5129     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
5130     if (vmsname == NULL)
5131         return SS$_INSFMEM;
5132
5133     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5134                         vmsname,
5135                         PERL_RMSEXPAND_M_SYMLINK);
5136     if (rslt == NULL) {
5137         PerlMem_free(vmsname);
5138         return SS$_INSFMEM;
5139     }
5140
5141     /* So we get our own UIC to use as a rights identifier,
5142      * and the insert an ACE at the head of the ACL which allows us
5143      * to delete the file.
5144      */
5145     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5146
5147     fildsc.dsc$w_length = strlen(vmsname);
5148     fildsc.dsc$a_pointer = vmsname;
5149     ctx = 0;
5150     newace.myace$l_ident = oldace.myace$l_ident;
5151     rnsts = SS$_ABORT;
5152
5153     /* Grab any existing ACEs with this identifier in case we fail */
5154     clean_dsc = &fildsc;
5155     aclsts = fndsts = sys$get_security(&obj_file_dsc,
5156                                &fildsc,
5157                                NULL,
5158                                OSS$M_WLOCK,
5159                                findlst,
5160                                &ctx,
5161                                &access_mode);
5162
5163     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
5164         /* Add the new ACE . . . */
5165
5166         /* if the sys$get_security succeeded, then ctx is valid, and the
5167          * object/file descriptors will be ignored.  But otherwise they
5168          * are needed
5169          */
5170         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5171                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
5172         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5173             set_errno(EVMSERR);
5174             set_vaxc_errno(aclsts);
5175             PerlMem_free(vmsname);
5176             return aclsts;
5177         }
5178
5179         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5180                                 NULL, NULL,
5181                                 &flags,
5182                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5183
5184         if ($VMS_STATUS_SUCCESS(rnsts)) {
5185             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5186         }
5187
5188         /* Put things back the way they were. */
5189         ctx = 0;
5190         aclsts = sys$get_security(&obj_file_dsc,
5191                                   clean_dsc,
5192                                   NULL,
5193                                   OSS$M_WLOCK,
5194                                   findlst,
5195                                   &ctx,
5196                                   &access_mode);
5197
5198         if ($VMS_STATUS_SUCCESS(aclsts)) {
5199         int sec_flags;
5200
5201             sec_flags = 0;
5202             if (!$VMS_STATUS_SUCCESS(fndsts))
5203                 sec_flags = OSS$M_RELCTX;
5204
5205             /* Get rid of the new ACE */
5206             aclsts = sys$set_security(NULL, NULL, NULL,
5207                                   sec_flags, dellst, &ctx, &access_mode);
5208
5209             /* If there was an old ACE, put it back */
5210             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5211                 addlst[0].bufadr = &oldace;
5212                 aclsts = sys$set_security(NULL, NULL, NULL,
5213                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5214                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5215                     set_errno(EVMSERR);
5216                     set_vaxc_errno(aclsts);
5217                     rnsts = aclsts;
5218                 }
5219             } else {
5220             int aclsts2;
5221
5222                 /* Try to clear the lock on the ACL list */
5223                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5224                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5225
5226                 /* Rename errors are most important */
5227                 if (!$VMS_STATUS_SUCCESS(rnsts))
5228                     aclsts = rnsts;
5229                 set_errno(EVMSERR);
5230                 set_vaxc_errno(aclsts);
5231                 rnsts = aclsts;
5232             }
5233         }
5234         else {
5235             if (aclsts != SS$_ACLEMPTY)
5236                 rnsts = aclsts;
5237         }
5238     }
5239     else
5240         rnsts = fndsts;
5241
5242     PerlMem_free(vmsname);
5243     return rnsts;
5244 }
5245
5246
5247 /*{{{int rename(const char *, const char * */
5248 /* Not exactly what X/Open says to do, but doing it absolutely right
5249  * and efficiently would require a lot more work.  This should be close
5250  * enough to pass all but the most strict X/Open compliance test.
5251  */
5252 int
5253 Perl_rename(pTHX_ const char *src, const char * dst)
5254 {
5255 int retval;
5256 int pre_delete = 0;
5257 int src_sts;
5258 int dst_sts;
5259 Stat_t src_st;
5260 Stat_t dst_st;
5261
5262     /* Validate the source file */
5263     src_sts = flex_lstat(src, &src_st);
5264     if (src_sts != 0) {
5265
5266         /* No source file or other problem */
5267         return src_sts;
5268     }
5269     if (src_st.st_devnam[0] == 0)  {
5270         /* This may be possible so fail if it is seen. */
5271         errno = EIO;
5272         return -1;
5273     }
5274
5275     dst_sts = flex_lstat(dst, &dst_st);
5276     if (dst_sts == 0) {
5277
5278         if (dst_st.st_dev != src_st.st_dev) {
5279             /* Must be on the same device */
5280             errno = EXDEV;
5281             return -1;
5282         }
5283
5284         /* VMS_INO_T_COMPARE is true if the inodes are different
5285          * to match the output of memcmp
5286          */
5287
5288         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5289             /* That was easy, the files are the same! */
5290             return 0;
5291         }
5292
5293         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5294             /* If source is a directory, so must be dest */
5295                 errno = EISDIR;
5296                 return -1;
5297         }
5298
5299     }
5300
5301
5302     if ((dst_sts == 0) &&
5303         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5304
5305         /* We have issues here if vms_unlink_all_versions is set
5306          * If the destination exists, and is not a directory, then
5307          * we must delete in advance.
5308          *
5309          * If the src is a directory, then we must always pre-delete
5310          * the destination.
5311          *
5312          * If we successfully delete the dst in advance, and the rename fails
5313          * X/Open requires that errno be EIO.
5314          *
5315          */
5316
5317         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5318             int d_sts;
5319             d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5320                                      S_ISDIR(dst_st.st_mode));
5321
5322            /* Need to delete all versions ? */
5323            if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5324                 int i = 0;
5325
5326                 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5327                     d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5328                     if (d_sts != 0)
5329                         break;
5330                     i++;
5331
5332                     /* Make sure that we do not loop forever */
5333                     if (i > 32767) {
5334                         errno = EIO;
5335                         d_sts = -1;
5336                         break;
5337                     }
5338                 }
5339            }
5340
5341             if (d_sts != 0)
5342                 return d_sts;
5343
5344             /* We killed the destination, so only errno now is EIO */
5345             pre_delete = 1;
5346         }
5347     }
5348
5349     /* Originally the idea was to call the CRTL rename() and only
5350      * try the lib$rename_file if it failed.
5351      * It turns out that there are too many variants in what the
5352      * the CRTL rename might do, so only use lib$rename_file
5353      */
5354     retval = -1;
5355
5356     {
5357         /* Is the source and dest both in VMS format */
5358         /* if the source is a directory, then need to fileify */
5359         /*  and dest must be a directory or non-existant. */
5360
5361         char * vms_dst;
5362         int sts;
5363         char * ret_str;
5364         unsigned long flags;
5365         struct dsc$descriptor_s old_file_dsc;
5366         struct dsc$descriptor_s new_file_dsc;
5367
5368         /* We need to modify the src and dst depending
5369          * on if one or more of them are directories.
5370          */
5371
5372         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5373         if (vms_dst == NULL)
5374             _ckvmssts_noperl(SS$_INSFMEM);
5375
5376         if (S_ISDIR(src_st.st_mode)) {
5377         char * ret_str;
5378         char * vms_dir_file;
5379
5380             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5381             if (vms_dir_file == NULL)
5382                 _ckvmssts_noperl(SS$_INSFMEM);
5383
5384             /* If the dest is a directory, we must remove it
5385             if (dst_sts == 0) {
5386                 int d_sts;
5387                 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5388                 if (d_sts != 0) {
5389                     PerlMem_free(vms_dst);
5390                     errno = EIO;
5391                     return sts;
5392                 }
5393
5394                 pre_delete = 1;
5395             }
5396
5397            /* The dest must be a VMS file specification */
5398            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5399            if (ret_str == NULL) {
5400                 PerlMem_free(vms_dst);
5401                 errno = EIO;
5402                 return -1;
5403            }
5404
5405             /* The source must be a file specification */
5406             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5407             if (vms_dir_file == NULL)
5408                 _ckvmssts_noperl(SS$_INSFMEM);
5409
5410             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5411             if (ret_str == NULL) {
5412                 PerlMem_free(vms_dst);
5413                 PerlMem_free(vms_dir_file);
5414                 errno = EIO;
5415                 return -1;
5416             }
5417             PerlMem_free(vms_dst);
5418             vms_dst = vms_dir_file;
5419
5420         } else {
5421             /* File to file or file to new dir */
5422
5423             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5424                 /* VMS pathify a dir target */
5425                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5426                 if (ret_str == NULL) {
5427                     PerlMem_free(vms_dst);
5428                     errno = EIO;
5429                     return -1;
5430                 }
5431             } else {
5432                 char * v_spec, * r_spec, * d_spec, * n_spec;
5433                 char * e_spec, * vs_spec;
5434                 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5435
5436                 /* fileify a target VMS file specification */
5437                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5438                 if (ret_str == NULL) {
5439                     PerlMem_free(vms_dst);
5440                     errno = EIO;
5441                     return -1;
5442                 }
5443
5444                 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5445                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5446                              &e_len, &vs_spec, &vs_len);
5447                 if (sts == 0) {
5448                      if (e_len == 0) {
5449                          /* Get rid of the version */
5450                          if (vs_len != 0) {
5451                              *vs_spec = '\0';
5452                          }
5453                          /* Need to specify a '.' so that the extension */
5454                          /* is not inherited */
5455                          strcat(vms_dst,".");
5456                      }
5457                 }
5458             }
5459         }
5460
5461         old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5462         old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5463         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5464         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5465
5466         new_file_dsc.dsc$a_pointer = vms_dst;
5467         new_file_dsc.dsc$w_length = strlen(vms_dst);
5468         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5469         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5470
5471         flags = 0;
5472 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5473         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5474 #endif
5475
5476         sts = lib$rename_file(&old_file_dsc,
5477                               &new_file_dsc,
5478                               NULL, NULL,
5479                               &flags,
5480                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5481         if (!$VMS_STATUS_SUCCESS(sts)) {
5482
5483            /* We could have failed because VMS style permissions do not
5484             * permit renames that UNIX will allow.  Just like the hack
5485             * in for kill_file.
5486             */
5487            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5488         }
5489
5490         PerlMem_free(vms_dst);
5491         if (!$VMS_STATUS_SUCCESS(sts)) {
5492             errno = EIO;
5493             return -1;
5494         }
5495         retval = 0;
5496     }
5497
5498     if (vms_unlink_all_versions) {
5499         /* Now get rid of any previous versions of the source file that
5500          * might still exist
5501          */
5502         int i = 0;
5503         dSAVEDERRNO;
5504         SAVE_ERRNO;
5505         src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5506                                    S_ISDIR(src_st.st_mode));
5507         while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5508              src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5509                                        S_ISDIR(src_st.st_mode));
5510              if (src_sts != 0)
5511                  break;
5512              i++;
5513
5514              /* Make sure that we do not loop forever */
5515              if (i > 32767) {
5516                  src_sts = -1;
5517                  break;
5518              }
5519         }
5520         RESTORE_ERRNO;
5521     }
5522
5523     /* We deleted the destination, so must force the error to be EIO */
5524     if ((retval != 0) && (pre_delete != 0))
5525         errno = EIO;
5526
5527     return retval;
5528 }
5529 /*}}}*/
5530
5531
5532 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5533 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5534  * to expand file specification.  Allows for a single default file
5535  * specification and a simple mask of options.  If outbuf is non-NULL,
5536  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5537  * the resultant file specification is placed.  If outbuf is NULL, the
5538  * resultant file specification is placed into a static buffer.
5539  * The third argument, if non-NULL, is taken to be a default file
5540  * specification string.  The fourth argument is unused at present.
5541  * rmesexpand() returns the address of the resultant string if
5542  * successful, and NULL on error.
5543  *
5544  * New functionality for previously unused opts value:
5545  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5546  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5547  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5548  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5549  */
5550 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5551
5552 static char *
5553 int_rmsexpand
5554    (const char *filespec,
5555     char *outbuf,
5556     const char *defspec,
5557     unsigned opts,
5558     int * fs_utf8,
5559     int * dfs_utf8)
5560 {
5561   char * ret_spec;
5562   const char * in_spec;
5563   char * spec_buf;
5564   const char * def_spec;
5565   char * vmsfspec, *vmsdefspec;
5566   char * esa;
5567   char * esal = NULL;
5568   char * outbufl;
5569   struct FAB myfab = cc$rms_fab;
5570   rms_setup_nam(mynam);
5571   STRLEN speclen;
5572   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5573   int sts;
5574
5575   /* temp hack until UTF8 is actually implemented */
5576   if (fs_utf8 != NULL)
5577     *fs_utf8 = 0;
5578
5579   if (!filespec || !*filespec) {
5580     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5581     return NULL;
5582   }
5583
5584   vmsfspec = NULL;
5585   vmsdefspec = NULL;
5586   outbufl = NULL;
5587
5588   in_spec = filespec;
5589   isunix = 0;
5590   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5591       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5592       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5593
5594       /* If this is a UNIX file spec, convert it to VMS */
5595       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5596                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5597                            &e_len, &vs_spec, &vs_len);
5598       if (sts != 0) {
5599           isunix = 1;
5600           char * ret_spec;
5601
5602           vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5603           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5604           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5605           if (ret_spec == NULL) {
5606               PerlMem_free(vmsfspec);
5607               return NULL;
5608           }
5609           in_spec = (const char *)vmsfspec;
5610
5611           /* Unless we are forcing to VMS format, a UNIX input means
5612            * UNIX output, and that requires long names to be used
5613            */
5614           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5615 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5616               opts |= PERL_RMSEXPAND_M_LONG;
5617 #endif
5618           else
5619               isunix = 0;
5620       }
5621
5622   }
5623
5624   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5625   rms_bind_fab_nam(myfab, mynam);
5626
5627   /* Process the default file specification if present */
5628   def_spec = defspec;
5629   if (defspec && *defspec) {
5630     int t_isunix;
5631     t_isunix = is_unix_filespec(defspec);
5632     if (t_isunix) {
5633       vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
5634       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5635       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5636
5637       if (ret_spec == NULL) {
5638           /* Clean up and bail */
5639           PerlMem_free(vmsdefspec);
5640           if (vmsfspec != NULL)
5641               PerlMem_free(vmsfspec);
5642               return NULL;
5643           }
5644           def_spec = (const char *)vmsdefspec;
5645       }
5646       rms_set_dna(myfab, mynam,
5647                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5648   }
5649
5650   /* Now we need the expansion buffers */
5651   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5652   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5653 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5654   esal = PerlMem_malloc(VMS_MAXRSS);
5655   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5656 #endif
5657   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5658
5659   /* If a NAML block is used RMS always writes to the long and short
5660    * addresses unless you suppress the short name.
5661    */
5662 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5663   outbufl = PerlMem_malloc(VMS_MAXRSS);
5664   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5665 #endif
5666    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5667
5668 #ifdef NAM$M_NO_SHORT_UPCASE
5669   if (decc_efs_case_preserve)
5670     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5671 #endif
5672
5673    /* We may not want to follow symbolic links */
5674 #ifdef NAML$M_OPEN_SPECIAL
5675   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5676     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5677 #endif
5678
5679   /* First attempt to parse as an existing file */
5680   retsts = sys$parse(&myfab,0,0);
5681   if (!(retsts & STS$K_SUCCESS)) {
5682
5683     /* Could not find the file, try as syntax only if error is not fatal */
5684     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5685     if (retsts == RMS$_DNF ||
5686         retsts == RMS$_DIR ||
5687         retsts == RMS$_DEV ||
5688         retsts == RMS$_PRV) {
5689       retsts = sys$parse(&myfab,0,0);
5690       if (retsts & STS$K_SUCCESS) goto int_expanded;
5691     }
5692
5693      /* Still could not parse the file specification */
5694     /*----------------------------------------------*/
5695     sts = rms_free_search_context(&myfab); /* Free search context */
5696     if (vmsdefspec != NULL)
5697         PerlMem_free(vmsdefspec);
5698     if (vmsfspec != NULL)
5699         PerlMem_free(vmsfspec);
5700     if (outbufl != NULL)
5701         PerlMem_free(outbufl);
5702     PerlMem_free(esa);
5703     if (esal != NULL)
5704         PerlMem_free(esal);
5705     set_vaxc_errno(retsts);
5706     if      (retsts == RMS$_PRV) set_errno(EACCES);
5707     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5708     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5709     else                         set_errno(EVMSERR);
5710     return NULL;
5711   }
5712   retsts = sys$search(&myfab,0,0);
5713   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5714     sts = rms_free_search_context(&myfab); /* Free search context */
5715     if (vmsdefspec != NULL)
5716         PerlMem_free(vmsdefspec);
5717     if (vmsfspec != NULL)
5718         PerlMem_free(vmsfspec);
5719     if (outbufl != NULL)
5720         PerlMem_free(outbufl);
5721     PerlMem_free(esa);
5722     if (esal != NULL)
5723         PerlMem_free(esal);
5724     set_vaxc_errno(retsts);
5725     if      (retsts == RMS$_PRV) set_errno(EACCES);
5726     else                         set_errno(EVMSERR);
5727     return NULL;
5728   }
5729
5730   /* If the input filespec contained any lowercase characters,
5731    * downcase the result for compatibility with Unix-minded code. */
5732 int_expanded:
5733   if (!decc_efs_case_preserve) {
5734     char * tbuf;
5735     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5736       if (islower(*tbuf)) { haslower = 1; break; }
5737   }
5738
5739    /* Is a long or a short name expected */
5740   /*------------------------------------*/
5741   spec_buf = NULL;
5742   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5743     if (rms_nam_rsll(mynam)) {
5744         spec_buf = outbufl;
5745         speclen = rms_nam_rsll(mynam);
5746     }
5747     else {
5748         spec_buf = esal; /* Not esa */
5749         speclen = rms_nam_esll(mynam);
5750     }
5751   }
5752   else {
5753     if (rms_nam_rsl(mynam)) {
5754         spec_buf = outbuf;
5755         speclen = rms_nam_rsl(mynam);
5756     }
5757     else {
5758         spec_buf = esa; /* Not esal */
5759         speclen = rms_nam_esl(mynam);
5760     }
5761   }
5762   spec_buf[speclen] = '\0';
5763
5764   /* Trim off null fields added by $PARSE
5765    * If type > 1 char, must have been specified in original or default spec
5766    * (not true for version; $SEARCH may have added version of existing file).
5767    */
5768   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5769   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5770     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5771              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5772   }
5773   else {
5774     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5775              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5776   }
5777   if (trimver || trimtype) {
5778     if (defspec && *defspec) {
5779       char *defesal = NULL;
5780       char *defesa = NULL;
5781       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5782       if (defesa != NULL) {
5783         struct FAB deffab = cc$rms_fab;
5784 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5785         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5786         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5787 #endif
5788         rms_setup_nam(defnam);
5789
5790         rms_bind_fab_nam(deffab, defnam);
5791
5792         /* Cast ok */
5793         rms_set_fna
5794             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5795
5796         /* RMS needs the esa/esal as a work area if wildcards are involved */
5797         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5798
5799         rms_clear_nam_nop(defnam);
5800         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5801 #ifdef NAM$M_NO_SHORT_UPCASE
5802         if (decc_efs_case_preserve)
5803           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5804 #endif
5805 #ifdef NAML$M_OPEN_SPECIAL
5806         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5807           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5808 #endif
5809         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5810           if (trimver) {
5811              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5812           }
5813           if (trimtype) {
5814             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5815           }
5816         }
5817         if (defesal != NULL)
5818             PerlMem_free(defesal);
5819         PerlMem_free(defesa);
5820       } else {
5821           _ckvmssts_noperl(SS$_INSFMEM);
5822       }
5823     }
5824     if (trimver) {
5825       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5826         if (*(rms_nam_verl(mynam)) != '\"')
5827           speclen = rms_nam_verl(mynam) - spec_buf;
5828       }
5829       else {
5830         if (*(rms_nam_ver(mynam)) != '\"')
5831           speclen = rms_nam_ver(mynam) - spec_buf;
5832       }
5833     }
5834     if (trimtype) {
5835       /* If we didn't already trim version, copy down */
5836       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5837         if (speclen > rms_nam_verl(mynam) - spec_buf)
5838           memmove
5839            (rms_nam_typel(mynam),
5840             rms_nam_verl(mynam),
5841             speclen - (rms_nam_verl(mynam) - spec_buf));
5842           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5843       }
5844       else {
5845         if (speclen > rms_nam_ver(mynam) - spec_buf)
5846           memmove
5847            (rms_nam_type(mynam),
5848             rms_nam_ver(mynam),
5849             speclen - (rms_nam_ver(mynam) - spec_buf));
5850           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5851       }
5852     }
5853   }
5854
5855    /* Done with these copies of the input files */
5856   /*-------------------------------------------*/
5857   if (vmsfspec != NULL)
5858         PerlMem_free(vmsfspec);
5859   if (vmsdefspec != NULL)
5860         PerlMem_free(vmsdefspec);
5861
5862   /* If we just had a directory spec on input, $PARSE "helpfully"
5863    * adds an empty name and type for us */
5864 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5865   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5866     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5867         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5868         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5869       speclen = rms_nam_namel(mynam) - spec_buf;
5870   }
5871   else
5872 #endif
5873   {
5874     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5875         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5876         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5877       speclen = rms_nam_name(mynam) - spec_buf;
5878   }
5879
5880   /* Posix format specifications must have matching quotes */
5881   if (speclen < (VMS_MAXRSS - 1)) {
5882     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5883       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5884         spec_buf[speclen] = '\"';
5885         speclen++;
5886       }
5887     }
5888   }
5889   spec_buf[speclen] = '\0';
5890   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5891
5892   /* Have we been working with an expanded, but not resultant, spec? */
5893   /* Also, convert back to Unix syntax if necessary. */
5894   {
5895   int rsl;
5896
5897 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5898     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5899       rsl = rms_nam_rsll(mynam);
5900     } else
5901 #endif
5902     {
5903       rsl = rms_nam_rsl(mynam);
5904     }
5905     if (!rsl) {
5906       /* rsl is not present, it means that spec_buf is either */
5907       /* esa or esal, and needs to be copied to outbuf */
5908       /* convert to Unix if desired */
5909       if (isunix) {
5910         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5911       } else {
5912         /* VMS file specs are not in UTF-8 */
5913         if (fs_utf8 != NULL)
5914             *fs_utf8 = 0;
5915         strcpy(outbuf, spec_buf);
5916         ret_spec = outbuf;
5917       }
5918     }
5919     else {
5920       /* Now spec_buf is either outbuf or outbufl */
5921       /* We need the result into outbuf */
5922       if (isunix) {
5923            /* If we need this in UNIX, then we need another buffer */
5924            /* to keep things in order */
5925            char * src;
5926            char * new_src = NULL;
5927            if (spec_buf == outbuf) {
5928                new_src = PerlMem_malloc(VMS_MAXRSS);
5929                strcpy(new_src, spec_buf);
5930            } else {
5931                src = spec_buf;
5932            }
5933            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5934            if (new_src) {
5935                PerlMem_free(new_src);
5936            }
5937       } else {
5938            /* VMS file specs are not in UTF-8 */
5939            if (fs_utf8 != NULL)
5940                *fs_utf8 = 0;
5941
5942            /* Copy the buffer if needed */
5943            if (outbuf != spec_buf)
5944                strcpy(outbuf, spec_buf);
5945            ret_spec = outbuf;
5946       }
5947     }
5948   }
5949
5950   /* Need to clean up the search context */
5951   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5952   sts = rms_free_search_context(&myfab); /* Free search context */
5953
5954   /* Clean up the extra buffers */
5955   if (esal != NULL)
5956       PerlMem_free(esal);
5957   PerlMem_free(esa);
5958   if (outbufl != NULL)
5959      PerlMem_free(outbufl);
5960
5961   /* Return the result */
5962   return ret_spec;
5963 }
5964
5965 /* Common simple case - Expand an already VMS spec */
5966 static char *
5967 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5968     opts |= PERL_RMSEXPAND_M_VMS_IN;
5969     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5970 }
5971
5972 /* Common simple case - Expand to a VMS spec */
5973 static char *
5974 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5975     opts |= PERL_RMSEXPAND_M_VMS;
5976     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5977 }
5978
5979
5980 /* Entry point used by perl routines */
5981 static char *
5982 mp_do_rmsexpand
5983    (pTHX_ const char *filespec,
5984     char *outbuf,
5985     int ts,
5986     const char *defspec,
5987     unsigned opts,
5988     int * fs_utf8,
5989     int * dfs_utf8)
5990 {
5991     static char __rmsexpand_retbuf[VMS_MAXRSS];
5992     char * expanded, *ret_spec, *ret_buf;
5993
5994     expanded = NULL;
5995     ret_buf = outbuf;
5996     if (ret_buf == NULL) {
5997         if (ts) {
5998             Newx(expanded, VMS_MAXRSS, char);
5999             if (expanded == NULL)
6000                 _ckvmssts(SS$_INSFMEM);
6001             ret_buf = expanded;
6002         } else {
6003             ret_buf = __rmsexpand_retbuf;
6004         }
6005     }
6006
6007
6008     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
6009                              opts, fs_utf8,  dfs_utf8);
6010
6011     if (ret_spec == NULL) {
6012        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6013        if (expanded)
6014            Safefree(expanded);
6015     }
6016
6017     return ret_spec;
6018 }
6019 /*}}}*/
6020 /* External entry points */
6021 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
6022 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
6023 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
6024 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
6025 char *Perl_rmsexpand_utf8
6026   (pTHX_ const char *spec, char *buf, const char *def,
6027    unsigned opt, int * fs_utf8, int * dfs_utf8)
6028 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
6029 char *Perl_rmsexpand_utf8_ts
6030   (pTHX_ const char *spec, char *buf, const char *def,
6031    unsigned opt, int * fs_utf8, int * dfs_utf8)
6032 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
6033
6034
6035 /*
6036 ** The following routines are provided to make life easier when
6037 ** converting among VMS-style and Unix-style directory specifications.
6038 ** All will take input specifications in either VMS or Unix syntax. On
6039 ** failure, all return NULL.  If successful, the routines listed below
6040 ** return a pointer to a buffer containing the appropriately
6041 ** reformatted spec (and, therefore, subsequent calls to that routine
6042 ** will clobber the result), while the routines of the same names with
6043 ** a _ts suffix appended will return a pointer to a mallocd string
6044 ** containing the appropriately reformatted spec.
6045 ** In all cases, only explicit syntax is altered; no check is made that
6046 ** the resulting string is valid or that the directory in question
6047 ** actually exists.
6048 **
6049 **   fileify_dirspec() - convert a directory spec into the name of the
6050 **     directory file (i.e. what you can stat() to see if it's a dir).
6051 **     The style (VMS or Unix) of the result is the same as the style
6052 **     of the parameter passed in.
6053 **   pathify_dirspec() - convert a directory spec into a path (i.e.
6054 **     what you prepend to a filename to indicate what directory it's in).
6055 **     The style (VMS or Unix) of the result is the same as the style
6056 **     of the parameter passed in.
6057 **   tounixpath() - convert a directory spec into a Unix-style path.
6058 **   tovmspath() - convert a directory spec into a VMS-style path.
6059 **   tounixspec() - convert any file spec into a Unix-style file spec.
6060 **   tovmsspec() - convert any file spec into a VMS-style spec.
6061 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
6062 **
6063 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
6064 ** Permission is given to distribute this code as part of the Perl
6065 ** standard distribution under the terms of the GNU General Public
6066 ** License or the Perl Artistic License.  Copies of each may be
6067 ** found in the Perl standard distribution.
6068  */
6069
6070 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6071 static char *
6072 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
6073 {
6074     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
6075     char *cp1, *cp2, *lastdir;
6076     char *trndir, *vmsdir;
6077     unsigned short int trnlnm_iter_count;
6078     int is_vms = 0;
6079     int is_unix = 0;
6080     int sts;
6081     if (utf8_fl != NULL)
6082         *utf8_fl = 0;
6083
6084     if (!dir || !*dir) {
6085       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6086     }
6087     dirlen = strlen(dir);
6088     while (dirlen && dir[dirlen-1] == '/') --dirlen;
6089     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
6090       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
6091         dir = "/sys$disk";
6092         dirlen = 9;
6093       }
6094       else
6095         dirlen = 1;
6096     }
6097     if (dirlen > (VMS_MAXRSS - 1)) {
6098       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6099       return NULL;
6100     }
6101     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
6102     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6103     if (!strpbrk(dir+1,"/]>:")  &&
6104         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
6105       strcpy(trndir,*dir == '/' ? dir + 1: dir);
6106       trnlnm_iter_count = 0;
6107       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6108         trnlnm_iter_count++;
6109         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6110       }
6111       dirlen = strlen(trndir);
6112     }
6113     else {
6114       strncpy(trndir,dir,dirlen);
6115       trndir[dirlen] = '\0';
6116     }
6117
6118     /* At this point we are done with *dir and use *trndir which is a
6119      * copy that can be modified.  *dir must not be modified.
6120      */
6121
6122     /* If we were handed a rooted logical name or spec, treat it like a
6123      * simple directory, so that
6124      *    $ Define myroot dev:[dir.]
6125      *    ... do_fileify_dirspec("myroot",buf,1) ...
6126      * does something useful.
6127      */
6128     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6129       trndir[--dirlen] = '\0';
6130       trndir[dirlen-1] = ']';
6131     }
6132     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6133       trndir[--dirlen] = '\0';
6134       trndir[dirlen-1] = '>';
6135     }
6136
6137     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6138       /* If we've got an explicit filename, we can just shuffle the string. */
6139       if (*(cp1+1)) hasfilename = 1;
6140       /* Similarly, we can just back up a level if we've got multiple levels
6141          of explicit directories in a VMS spec which ends with directories. */
6142       else {
6143         for (cp2 = cp1; cp2 > trndir; cp2--) {
6144           if (*cp2 == '.') {
6145             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6146 /* fix-me, can not scan EFS file specs backward like this */
6147               *cp2 = *cp1; *cp1 = '\0';
6148               hasfilename = 1;
6149               break;
6150             }
6151           }
6152           if (*cp2 == '[' || *cp2 == '<') break;
6153         }
6154       }
6155     }
6156
6157     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
6158     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6159     cp1 = strpbrk(trndir,"]:>");
6160     if (hasfilename || !cp1) { /* filename present or not VMS */
6161
6162       if (decc_efs_charset && !cp1) {
6163
6164           /* EFS handling for UNIX mode */
6165
6166           /* Just remove the trailing '/' and we should be done */
6167           STRLEN trndir_len;
6168           trndir_len = strlen(trndir);
6169
6170           if (trndir_len > 1) {
6171               trndir_len--;
6172               if (trndir[trndir_len] == '/') {
6173                   trndir[trndir_len] = '\0';
6174               }
6175           }
6176           strcpy(buf, trndir);
6177           PerlMem_free(trndir);
6178           PerlMem_free(vmsdir);
6179           return buf;
6180       }
6181
6182       /* For non-EFS mode, this is left for backwards compatibility */
6183       /* For EFS mode, this is only done for VMS format filespecs as */
6184       /* Perl programs generally have problems when a UNIX format spec */
6185       /* returns a VMS format spec */
6186       if (trndir[0] == '.') {
6187         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6188           PerlMem_free(trndir);
6189           PerlMem_free(vmsdir);
6190           return int_fileify_dirspec("[]", buf, NULL);
6191         }
6192         else if (trndir[1] == '.' &&
6193                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6194           PerlMem_free(trndir);
6195           PerlMem_free(vmsdir);
6196           return int_fileify_dirspec("[-]", buf, NULL);
6197         }
6198       }
6199       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6200         dirlen -= 1;                 /* to last element */
6201         lastdir = strrchr(trndir,'/');
6202       }
6203       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6204         /* If we have "/." or "/..", VMSify it and let the VMS code
6205          * below expand it, rather than repeating the code to handle
6206          * relative components of a filespec here */
6207         do {
6208           if (*(cp1+2) == '.') cp1++;
6209           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6210             char * ret_chr;
6211             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6212                 PerlMem_free(trndir);
6213                 PerlMem_free(vmsdir);
6214                 return NULL;
6215             }
6216             if (strchr(vmsdir,'/') != NULL) {
6217               /* If int_tovmsspec() returned it, it must have VMS syntax
6218                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6219                * the time to check this here only so we avoid a recursion
6220                * loop; otherwise, gigo.
6221                */
6222               PerlMem_free(trndir);
6223               PerlMem_free(vmsdir);
6224               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6225               return NULL;
6226             }
6227             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6228                 PerlMem_free(trndir);
6229                 PerlMem_free(vmsdir);
6230                 return NULL;
6231             }
6232             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6233             PerlMem_free(trndir);
6234             PerlMem_free(vmsdir);
6235             return ret_chr;
6236           }
6237           cp1++;
6238         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6239         lastdir = strrchr(trndir,'/');
6240       }
6241       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6242         char * ret_chr;
6243         /* Ditto for specs that end in an MFD -- let the VMS code
6244          * figure out whether it's a real device or a rooted logical. */
6245
6246         /* This should not happen any more.  Allowing the fake /000000
6247          * in a UNIX pathname causes all sorts of problems when trying
6248          * to run in UNIX emulation.  So the VMS to UNIX conversions
6249          * now remove the fake /000000 directories.
6250          */
6251
6252         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6253         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6254             PerlMem_free(trndir);
6255             PerlMem_free(vmsdir);
6256             return NULL;
6257         }
6258         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6259             PerlMem_free(trndir);
6260             PerlMem_free(vmsdir);
6261             return NULL;
6262         }
6263         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6264         PerlMem_free(trndir);
6265         PerlMem_free(vmsdir);
6266         return ret_chr;
6267       }
6268       else {
6269
6270         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6271              !(lastdir = cp1 = strrchr(trndir,']')) &&
6272              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6273
6274         cp2 = strrchr(cp1,'.');
6275         if (cp2) {
6276             int e_len, vs_len = 0;
6277             int is_dir = 0;
6278             char * cp3;
6279             cp3 = strchr(cp2,';');
6280             e_len = strlen(cp2);
6281             if (cp3) {
6282                 vs_len = strlen(cp3);
6283                 e_len = e_len - vs_len;
6284             }
6285             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6286             if (!is_dir) {
6287                 if (!decc_efs_charset) {
6288                     /* If this is not EFS, then not a directory */
6289                     PerlMem_free(trndir);
6290                     PerlMem_free(vmsdir);
6291                     set_errno(ENOTDIR);
6292                     set_vaxc_errno(RMS$_DIR);
6293                     return NULL;
6294                 }
6295             } else {
6296                 /* Ok, here we have an issue, technically if a .dir shows */
6297                 /* from inside a directory, then we should treat it as */
6298                 /* xxx^.dir.dir.  But we do not have that context at this */
6299                 /* point unless this is totally restructured, so we remove */
6300                 /* The .dir for now, and fix this better later */
6301                 dirlen = cp2 - trndir;
6302             }
6303         }
6304
6305       }
6306
6307       retlen = dirlen + 6;
6308       memcpy(buf, trndir, dirlen);
6309       buf[dirlen] = '\0';
6310
6311       /* We've picked up everything up to the directory file name.
6312          Now just add the type and version, and we're set. */
6313
6314       /* We should only add type for VMS syntax, but historically Perl
6315          has added it for UNIX style also */
6316
6317       /* Fix me - we should not be using the same routine for VMS and
6318          UNIX format files.  Things are too tangled so we need to lookup
6319          what syntax the output is */
6320
6321       is_unix = 0;
6322       is_vms = 0;
6323       lastdir = strrchr(trndir,'/');
6324       if (lastdir) {
6325           is_unix = 1;
6326       } else {
6327           lastdir = strpbrk(trndir,"]:>");
6328           if (lastdir) {
6329               is_vms = 1;
6330           }
6331       }
6332
6333       if ((is_vms == 0) && (is_unix == 0)) {
6334           /* We still do not  know? */
6335           is_unix = decc_filename_unix_report;
6336           if (is_unix == 0)
6337               is_vms = 1;
6338       }
6339
6340       if ((is_unix && !decc_efs_charset) || is_vms) {
6341
6342            /* It is a bug to add a .dir to a UNIX format directory spec */
6343            /* However Perl on VMS may have programs that expect this so */
6344            /* If not using EFS character specifications allow it. */
6345
6346            if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
6347                /* Traditionally Perl expects filenames in lower case */
6348                strcat(buf, ".dir");
6349            } else {
6350                /* VMS expects the .DIR to be in upper case */
6351                strcat(buf, ".DIR");
6352            }
6353
6354            /* It is also a bug to put a VMS format version on a UNIX file */
6355            /* specification.  Perl self tests are looking for this */
6356            if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
6357                strcat(buf, ";1");
6358       }
6359       PerlMem_free(trndir);
6360       PerlMem_free(vmsdir);
6361       return buf;
6362     }
6363     else {  /* VMS-style directory spec */
6364
6365       char *esa, *esal, term, *cp;
6366       char *my_esa;
6367       int my_esa_len;
6368       unsigned long int sts, cmplen, haslower = 0;
6369       unsigned int nam_fnb;
6370       char * nam_type;
6371       struct FAB dirfab = cc$rms_fab;
6372       rms_setup_nam(savnam);
6373       rms_setup_nam(dirnam);
6374
6375       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6376       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6377       esal = NULL;
6378 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6379       esal = PerlMem_malloc(VMS_MAXRSS);
6380       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6381 #endif
6382       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6383       rms_bind_fab_nam(dirfab, dirnam);
6384       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6385       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6386 #ifdef NAM$M_NO_SHORT_UPCASE
6387       if (decc_efs_case_preserve)
6388         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6389 #endif
6390
6391       for (cp = trndir; *cp; cp++)
6392         if (islower(*cp)) { haslower = 1; break; }
6393       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6394         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6395             (dirfab.fab$l_sts == RMS$_DNF) ||
6396             (dirfab.fab$l_sts == RMS$_PRV)) {
6397             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6398             sts = sys$parse(&dirfab);
6399         }
6400         if (!sts) {
6401           PerlMem_free(esa);
6402           if (esal != NULL)
6403               PerlMem_free(esal);
6404           PerlMem_free(trndir);
6405           PerlMem_free(vmsdir);
6406           set_errno(EVMSERR);
6407           set_vaxc_errno(dirfab.fab$l_sts);
6408           return NULL;
6409         }
6410       }
6411       else {
6412         savnam = dirnam;
6413         /* Does the file really exist? */
6414         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6415           /* Yes; fake the fnb bits so we'll check type below */
6416           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6417         }
6418         else { /* No; just work with potential name */
6419           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6420           else {
6421             int fab_sts;
6422             fab_sts = dirfab.fab$l_sts;
6423             sts = rms_free_search_context(&dirfab);
6424             PerlMem_free(esa);
6425             if (esal != NULL)
6426                 PerlMem_free(esal);
6427             PerlMem_free(trndir);
6428             PerlMem_free(vmsdir);
6429             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6430             return NULL;
6431           }
6432         }
6433       }
6434
6435       /* Make sure we are using the right buffer */
6436       if (esal != NULL) {
6437         my_esa = esal;
6438         my_esa_len = rms_nam_esll(dirnam);
6439       } else {
6440         my_esa = esa;
6441         my_esa_len = rms_nam_esl(dirnam);
6442       }
6443       my_esa[my_esa_len] = '\0';
6444       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6445         cp1 = strchr(my_esa,']');
6446         if (!cp1) cp1 = strchr(my_esa,'>');
6447         if (cp1) {  /* Should always be true */
6448           my_esa_len -= cp1 - my_esa - 1;
6449           memmove(my_esa, cp1 + 1, my_esa_len);
6450         }
6451       }
6452       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6453         /* Yep; check version while we're at it, if it's there. */
6454         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6455         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6456           /* Something other than .DIR[;1].  Bzzt. */
6457           sts = rms_free_search_context(&dirfab);
6458           PerlMem_free(esa);
6459           if (esal != NULL)
6460              PerlMem_free(esal);
6461           PerlMem_free(trndir);
6462           PerlMem_free(vmsdir);
6463           set_errno(ENOTDIR);
6464           set_vaxc_errno(RMS$_DIR);
6465           return NULL;
6466         }
6467       }
6468
6469       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6470         /* They provided at least the name; we added the type, if necessary, */
6471         strcpy(buf, my_esa);
6472         sts = rms_free_search_context(&dirfab);
6473         PerlMem_free(trndir);
6474         PerlMem_free(esa);
6475         if (esal != NULL)
6476             PerlMem_free(esal);
6477         PerlMem_free(vmsdir);
6478         return buf;
6479       }
6480       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6481         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6482         *cp1 = '\0';
6483         my_esa_len -= 9;
6484       }
6485       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6486       if (cp1 == NULL) { /* should never happen */
6487         sts = rms_free_search_context(&dirfab);
6488         PerlMem_free(trndir);
6489         PerlMem_free(esa);
6490         if (esal != NULL)
6491             PerlMem_free(esal);
6492         PerlMem_free(vmsdir);
6493         return NULL;
6494       }
6495       term = *cp1;
6496       *cp1 = '\0';
6497       retlen = strlen(my_esa);
6498       cp1 = strrchr(my_esa,'.');
6499       /* ODS-5 directory specifications can have extra "." in them. */
6500       /* Fix-me, can not scan EFS file specifications backwards */
6501       while (cp1 != NULL) {
6502         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6503           break;
6504         else {
6505            cp1--;
6506            while ((cp1 > my_esa) && (*cp1 != '.'))
6507              cp1--;
6508         }
6509         if (cp1 == my_esa)
6510           cp1 = NULL;
6511       }
6512
6513       if ((cp1) != NULL) {
6514         /* There's more than one directory in the path.  Just roll back. */
6515         *cp1 = term;
6516         strcpy(buf, my_esa);
6517       }
6518       else {
6519         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6520           /* Go back and expand rooted logical name */
6521           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6522 #ifdef NAM$M_NO_SHORT_UPCASE
6523           if (decc_efs_case_preserve)
6524             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6525 #endif
6526           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6527             sts = rms_free_search_context(&dirfab);
6528             PerlMem_free(esa);
6529             if (esal != NULL)
6530                 PerlMem_free(esal);
6531             PerlMem_free(trndir);
6532             PerlMem_free(vmsdir);
6533             set_errno(EVMSERR);
6534             set_vaxc_errno(dirfab.fab$l_sts);
6535             return NULL;
6536           }
6537
6538           /* This changes the length of the string of course */
6539           if (esal != NULL) {
6540               my_esa_len = rms_nam_esll(dirnam);
6541           } else {
6542               my_esa_len = rms_nam_esl(dirnam);
6543           }
6544
6545           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6546           cp1 = strstr(my_esa,"][");
6547           if (!cp1) cp1 = strstr(my_esa,"]<");
6548           dirlen = cp1 - my_esa;
6549           memcpy(buf, my_esa, dirlen);
6550           if (!strncmp(cp1+2,"000000]",7)) {
6551             buf[dirlen-1] = '\0';
6552             /* fix-me Not full ODS-5, just extra dots in directories for now */
6553             cp1 = buf + dirlen - 1;
6554             while (cp1 > buf)
6555             {
6556               if (*cp1 == '[')
6557                 break;
6558               if (*cp1 == '.') {
6559                 if (*(cp1-1) != '^')
6560                   break;
6561               }
6562               cp1--;
6563             }
6564             if (*cp1 == '.') *cp1 = ']';
6565             else {
6566               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6567               memmove(cp1+1,"000000]",7);
6568             }
6569           }
6570           else {
6571             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6572             buf[retlen] = '\0';
6573             /* Convert last '.' to ']' */
6574             cp1 = buf+retlen-1;
6575             while (*cp != '[') {
6576               cp1--;
6577               if (*cp1 == '.') {
6578                 /* Do not trip on extra dots in ODS-5 directories */
6579                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6580                 break;
6581               }
6582             }
6583             if (*cp1 == '.') *cp1 = ']';
6584             else {
6585               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6586               memmove(cp1+1,"000000]",7);
6587             }
6588           }
6589         }
6590         else {  /* This is a top-level dir.  Add the MFD to the path. */
6591           cp1 = my_esa;
6592           cp2 = buf;
6593           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6594           strcpy(cp2,":[000000]");
6595           cp1 += 2;
6596           strcpy(cp2+9,cp1);
6597         }
6598       }
6599       sts = rms_free_search_context(&dirfab);
6600       /* We've set up the string up through the filename.  Add the
6601          type and version, and we're done. */
6602       strcat(buf,".DIR;1");
6603
6604       /* $PARSE may have upcased filespec, so convert output to lower
6605        * case if input contained any lowercase characters. */
6606       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6607       PerlMem_free(trndir);
6608       PerlMem_free(esa);
6609       if (esal != NULL)
6610         PerlMem_free(esal);
6611       PerlMem_free(vmsdir);
6612       return buf;
6613     }
6614 }  /* end of int_fileify_dirspec() */
6615
6616
6617 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6618 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6619 {
6620     static char __fileify_retbuf[VMS_MAXRSS];
6621     char * fileified, *ret_spec, *ret_buf;
6622
6623     fileified = NULL;
6624     ret_buf = buf;
6625     if (ret_buf == NULL) {
6626         if (ts) {
6627             Newx(fileified, VMS_MAXRSS, char);
6628             if (fileified == NULL)
6629                 _ckvmssts(SS$_INSFMEM);
6630             ret_buf = fileified;
6631         } else {
6632             ret_buf = __fileify_retbuf;
6633         }
6634     }
6635
6636     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6637
6638     if (ret_spec == NULL) {
6639        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6640        if (fileified)
6641            Safefree(fileified);
6642     }
6643
6644     return ret_spec;
6645 }  /* end of do_fileify_dirspec() */
6646 /*}}}*/
6647
6648 /* External entry points */
6649 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6650 { return do_fileify_dirspec(dir,buf,0,NULL); }
6651 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6652 { return do_fileify_dirspec(dir,buf,1,NULL); }
6653 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6654 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6655 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6656 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6657
6658 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6659     char * v_spec, int v_len, char * r_spec, int r_len,
6660     char * d_spec, int d_len, char * n_spec, int n_len,
6661     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6662
6663     /* VMS specification - Try to do this the simple way */
6664     if ((v_len + r_len > 0) || (d_len > 0)) {
6665         int is_dir;
6666
6667         /* No name or extension component, already a directory */
6668         if ((n_len + e_len + vs_len) == 0) {
6669             strcpy(buf, dir);
6670             return buf;
6671         }
6672
6673         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6674         /* This results from catfile() being used instead of catdir() */
6675         /* So even though it should not work, we need to allow it */
6676
6677         /* If this is .DIR;1 then do a simple conversion */
6678         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6679         if (is_dir || (e_len == 0) && (d_len > 0)) {
6680              int len;
6681              len = v_len + r_len + d_len - 1;
6682              char dclose = d_spec[d_len - 1];
6683              strncpy(buf, dir, len);
6684              buf[len] = '.';
6685              len++;
6686              strncpy(&buf[len], n_spec, n_len);
6687              len += n_len;
6688              buf[len] = dclose;
6689              buf[len + 1] = '\0';
6690              return buf;
6691         }
6692
6693 #ifdef HAS_SYMLINK
6694         else if (d_len > 0) {
6695             /* In the olden days, a directory needed to have a .DIR */
6696             /* extension to be a valid directory, but now it could  */
6697             /* be a symbolic link */
6698             int len;
6699             len = v_len + r_len + d_len - 1;
6700             char dclose = d_spec[d_len - 1];
6701             strncpy(buf, dir, len);
6702             buf[len] = '.';
6703             len++;
6704             strncpy(&buf[len], n_spec, n_len);
6705             len += n_len;
6706             if (e_len > 0) {
6707                 if (decc_efs_charset) {
6708                     buf[len] = '^';
6709                     len++;
6710                     strncpy(&buf[len], e_spec, e_len);
6711                     len += e_len;
6712                 } else {
6713                     set_vaxc_errno(RMS$_DIR);
6714                     set_errno(ENOTDIR);
6715                     return NULL;
6716                 }
6717             }
6718             buf[len] = dclose;
6719             buf[len + 1] = '\0';
6720             return buf;
6721         }
6722 #else
6723         else {
6724             set_vaxc_errno(RMS$_DIR);
6725             set_errno(ENOTDIR);
6726             return NULL;
6727         }
6728 #endif
6729     }
6730     set_vaxc_errno(RMS$_DIR);
6731     set_errno(ENOTDIR);
6732     return NULL;
6733 }
6734
6735
6736 /* Internal routine to make sure or convert a directory to be in a */
6737 /* path specification.  No utf8 flag because it is not changed or used */
6738 static char *int_pathify_dirspec(const char *dir, char *buf)
6739 {
6740     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6741     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6742     char * exp_spec, *ret_spec;
6743     char * trndir;
6744     unsigned short int trnlnm_iter_count;
6745     STRLEN trnlen;
6746     int need_to_lower;
6747
6748     if (vms_debug_fileify) {
6749         if (dir == NULL)
6750             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6751         else
6752             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6753     }
6754
6755     /* We may need to lower case the result if we translated  */
6756     /* a logical name or got the current working directory */
6757     need_to_lower = 0;
6758
6759     if (!dir || !*dir) {
6760       set_errno(EINVAL);
6761       set_vaxc_errno(SS$_BADPARAM);
6762       return NULL;
6763     }
6764
6765     trndir = PerlMem_malloc(VMS_MAXRSS);
6766     if (trndir == NULL)
6767         _ckvmssts_noperl(SS$_INSFMEM);
6768
6769     /* If no directory specified use the current default */
6770     if (*dir)
6771         strcpy(trndir, dir);
6772     else {
6773         getcwd(trndir, VMS_MAXRSS - 1);
6774         need_to_lower = 1;
6775     }
6776
6777     /* now deal with bare names that could be logical names */
6778     trnlnm_iter_count = 0;
6779     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6780            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6781         trnlnm_iter_count++;
6782         need_to_lower = 1;
6783         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6784             break;
6785         trnlen = strlen(trndir);
6786
6787         /* Trap simple rooted lnms, and return lnm:[000000] */
6788         if (!strcmp(trndir+trnlen-2,".]")) {
6789             strcpy(buf, dir);
6790             strcat(buf, ":[000000]");
6791             PerlMem_free(trndir);
6792
6793             if (vms_debug_fileify) {
6794                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6795             }
6796             return buf;
6797         }
6798     }
6799
6800     /* At this point we do not work with *dir, but the copy in  *trndir */
6801
6802     if (need_to_lower && !decc_efs_case_preserve) {
6803         /* Legacy mode, lower case the returned value */
6804         __mystrtolower(trndir);
6805     }
6806
6807
6808     /* Some special cases, '..', '.' */
6809     sts = 0;
6810     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6811        /* Force UNIX filespec */
6812        sts = 1;
6813
6814     } else {
6815         /* Is this Unix or VMS format? */
6816         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6817                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6818                              &e_len, &vs_spec, &vs_len);
6819         if (sts == 0) {
6820
6821             /* Just a filename? */
6822             if ((v_len + r_len + d_len) == 0) {
6823
6824                 /* Now we have a problem, this could be Unix or VMS */
6825                 /* We have to guess.  .DIR usually means VMS */
6826
6827                 /* In UNIX report mode, the .DIR extension is removed */
6828                 /* if one shows up, it is for a non-directory or a directory */
6829                 /* in EFS charset mode */
6830
6831                 /* So if we are in Unix report mode, assume that this */
6832                 /* is a relative Unix directory specification */
6833
6834                 sts = 1;
6835                 if (!decc_filename_unix_report && decc_efs_charset) {
6836                     int is_dir;
6837                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6838
6839                     if (is_dir) {
6840                         /* Traditional mode, assume .DIR is directory */
6841                         buf[0] = '[';
6842                         buf[1] = '.';
6843                         strncpy(&buf[2], n_spec, n_len);
6844                         buf[n_len + 2] = ']';
6845                         buf[n_len + 3] = '\0';
6846                         PerlMem_free(trndir);
6847                         if (vms_debug_fileify) {
6848                             fprintf(stderr,
6849                                     "int_pathify_dirspec: buf = %s\n",
6850                                     buf);
6851                         }
6852                         return buf;
6853                     }
6854                 }
6855             }
6856         }
6857     }
6858     if (sts == 0) {
6859         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6860             v_spec, v_len, r_spec, r_len,
6861             d_spec, d_len, n_spec, n_len,
6862             e_spec, e_len, vs_spec, vs_len);
6863
6864         if (ret_spec != NULL) {
6865             PerlMem_free(trndir);
6866             if (vms_debug_fileify) {
6867                 fprintf(stderr,
6868                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6869             }
6870             return ret_spec;
6871         }
6872
6873         /* Simple way did not work, which means that a logical name */
6874         /* was present for the directory specification.             */
6875         /* Need to use an rmsexpand variant to decode it completely */
6876         exp_spec = PerlMem_malloc(VMS_MAXRSS);
6877         if (exp_spec == NULL)
6878             _ckvmssts_noperl(SS$_INSFMEM);
6879
6880         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6881         if (ret_spec != NULL) {
6882             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6883                                  &r_spec, &r_len, &d_spec, &d_len,
6884                                  &n_spec, &n_len, &e_spec,
6885                                  &e_len, &vs_spec, &vs_len);
6886             if (sts == 0) {
6887                 ret_spec = int_pathify_dirspec_simple(
6888                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6889                     d_spec, d_len, n_spec, n_len,
6890                     e_spec, e_len, vs_spec, vs_len);
6891
6892                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6893                     /* Legacy mode, lower case the returned value */
6894                     __mystrtolower(ret_spec);
6895                 }
6896             } else {
6897                 set_vaxc_errno(RMS$_DIR);
6898                 set_errno(ENOTDIR);
6899                 ret_spec = NULL;
6900             }
6901         }
6902         PerlMem_free(exp_spec);
6903         PerlMem_free(trndir);
6904         if (vms_debug_fileify) {
6905             if (ret_spec == NULL)
6906                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6907             else
6908                 fprintf(stderr,
6909                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6910         }
6911         return ret_spec;
6912
6913     } else {
6914         /* Unix specification, Could be trivial conversion */
6915         STRLEN dir_len;
6916         dir_len = strlen(trndir);
6917
6918         /* If the extended file character set is in effect */
6919         /* then pathify is simple */
6920
6921         if (!decc_efs_charset) {
6922             /* Have to deal with traiing '.dir' or extra '.' */
6923             /* that should not be there in legacy mode, but is */
6924
6925             char * lastdot;
6926             char * lastslash;
6927             int is_dir;
6928
6929             lastslash = strrchr(trndir, '/');
6930             if (lastslash == NULL)
6931                 lastslash = trndir;
6932             else
6933                 lastslash++;
6934
6935             lastdot = NULL;
6936
6937             /* '..' or '.' are valid directory components */
6938             is_dir = 0;
6939             if (lastslash[0] == '.') {
6940                 if (lastslash[1] == '\0') {
6941                    is_dir = 1;
6942                 } else if (lastslash[1] == '.') {
6943                     if (lastslash[2] == '\0') {
6944                         is_dir = 1;
6945                     } else {
6946                         /* And finally allow '...' */
6947                         if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6948                             is_dir = 1;
6949                         }
6950                     }
6951                 }
6952             }
6953
6954             if (!is_dir) {
6955                lastdot = strrchr(lastslash, '.');
6956             }
6957             if (lastdot != NULL) {
6958                 STRLEN e_len;
6959
6960                 /* '.dir' is discarded, and any other '.' is invalid */
6961                 e_len = strlen(lastdot);
6962
6963                 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6964
6965                 if (is_dir) {
6966                     dir_len = dir_len - 4;
6967
6968                 }
6969             }
6970         }
6971
6972         strcpy(buf, trndir);
6973         if (buf[dir_len - 1] != '/') {
6974             buf[dir_len] = '/';
6975             buf[dir_len + 1] = '\0';
6976         }
6977
6978         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6979         if (!decc_efs_charset) {
6980              int dir_start = 0;
6981              char * str = buf;
6982              if (str[0] == '.') {
6983                  char * dots = str;
6984                  int cnt = 1;
6985                  while ((dots[cnt] == '.') && (cnt < 3))
6986                      cnt++;
6987                  if (cnt <= 3) {
6988                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6989                          dir_start = 1;
6990                          str += cnt;
6991                      }
6992                  }
6993              }
6994              for (; *str; ++str) {
6995                  while (*str == '/') {
6996                      dir_start = 1;
6997                      *str++;
6998                  }
6999                  if (dir_start) {
7000
7001                      /* Have to skip up to three dots which could be */
7002                      /* directories, 3 dots being a VMS extension for Perl */
7003                      char * dots = str;
7004                      int cnt = 0;
7005                      while ((dots[cnt] == '.') && (cnt < 3)) {
7006                          cnt++;
7007                      }
7008                      if (dots[cnt] == '\0')
7009                          break;
7010                      if ((cnt > 1) && (dots[cnt] != '/')) {
7011                          dir_start = 0;
7012                      } else {
7013                          str += cnt;
7014                      }
7015
7016                      /* too many dots? */
7017                      if ((cnt == 0) || (cnt > 3)) {
7018                          dir_start = 0;
7019                      }
7020                  }
7021                  if (!dir_start && (*str == '.')) {
7022                      *str = '_';
7023                  }
7024              }
7025         }
7026         PerlMem_free(trndir);
7027         ret_spec = buf;
7028         if (vms_debug_fileify) {
7029             if (ret_spec == NULL)
7030                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
7031             else
7032                 fprintf(stderr,
7033                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
7034         }
7035         return ret_spec;
7036     }
7037 }
7038
7039 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
7040 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
7041 {
7042     static char __pathify_retbuf[VMS_MAXRSS];
7043     char * pathified, *ret_spec, *ret_buf;
7044
7045     pathified = NULL;
7046     ret_buf = buf;
7047     if (ret_buf == NULL) {
7048         if (ts) {
7049             Newx(pathified, VMS_MAXRSS, char);
7050             if (pathified == NULL)
7051                 _ckvmssts(SS$_INSFMEM);
7052             ret_buf = pathified;
7053         } else {
7054             ret_buf = __pathify_retbuf;
7055         }
7056     }
7057
7058     ret_spec = int_pathify_dirspec(dir, ret_buf);
7059
7060     if (ret_spec == NULL) {
7061        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7062        if (pathified)
7063            Safefree(pathified);
7064     }
7065
7066     return ret_spec;
7067
7068 }  /* end of do_pathify_dirspec() */
7069
7070
7071 /* External entry points */
7072 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
7073 { return do_pathify_dirspec(dir,buf,0,NULL); }
7074 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
7075 { return do_pathify_dirspec(dir,buf,1,NULL); }
7076 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
7077 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
7078 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
7079 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
7080
7081 /* Internal tounixspec routine that does not use a thread context */
7082 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
7083 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
7084 {
7085   char *dirend, *cp1, *cp3, *tmp;
7086   const char *cp2;
7087   int devlen, dirlen, retlen = VMS_MAXRSS;
7088   int expand = 1; /* guarantee room for leading and trailing slashes */
7089   unsigned short int trnlnm_iter_count;
7090   int cmp_rslt;
7091   if (utf8_fl != NULL)
7092     *utf8_fl = 0;
7093
7094   if (vms_debug_fileify) {
7095       if (spec == NULL)
7096           fprintf(stderr, "int_tounixspec: spec = NULL\n");
7097       else
7098           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7099   }
7100
7101
7102   if (spec == NULL) {
7103       set_errno(EINVAL);
7104       set_vaxc_errno(SS$_BADPARAM);
7105       return NULL;
7106   }
7107   if (strlen(spec) > (VMS_MAXRSS-1)) {
7108       set_errno(E2BIG);
7109       set_vaxc_errno(SS$_BUFFEROVF);
7110       return NULL;
7111   }
7112
7113   /* New VMS specific format needs translation
7114    * glob passes filenames with trailing '\n' and expects this preserved.
7115    */
7116   if (decc_posix_compliant_pathnames) {
7117     if (strncmp(spec, "\"^UP^", 5) == 0) {
7118       char * uspec;
7119       char *tunix;
7120       int tunix_len;
7121       int nl_flag;
7122
7123       tunix = PerlMem_malloc(VMS_MAXRSS);
7124       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7125       strcpy(tunix, spec);
7126       tunix_len = strlen(tunix);
7127       nl_flag = 0;
7128       if (tunix[tunix_len - 1] == '\n') {
7129         tunix[tunix_len - 1] = '\"';
7130         tunix[tunix_len] = '\0';
7131         tunix_len--;
7132         nl_flag = 1;
7133       }
7134       uspec = decc$translate_vms(tunix);
7135       PerlMem_free(tunix);
7136       if ((int)uspec > 0) {
7137         strcpy(rslt,uspec);
7138         if (nl_flag) {
7139           strcat(rslt,"\n");
7140         }
7141         else {
7142           /* If we can not translate it, makemaker wants as-is */
7143           strcpy(rslt, spec);
7144         }
7145         return rslt;
7146       }
7147     }
7148   }
7149
7150   cmp_rslt = 0; /* Presume VMS */
7151   cp1 = strchr(spec, '/');
7152   if (cp1 == NULL)
7153     cmp_rslt = 0;
7154
7155     /* Look for EFS ^/ */
7156     if (decc_efs_charset) {
7157       while (cp1 != NULL) {
7158         cp2 = cp1 - 1;
7159         if (*cp2 != '^') {
7160           /* Found illegal VMS, assume UNIX */
7161           cmp_rslt = 1;
7162           break;
7163         }
7164       cp1++;
7165       cp1 = strchr(cp1, '/');
7166     }
7167   }
7168
7169   /* Look for "." and ".." */
7170   if (decc_filename_unix_report) {
7171     if (spec[0] == '.') {
7172       if ((spec[1] == '\0') || (spec[1] == '\n')) {
7173         cmp_rslt = 1;
7174       }
7175       else {
7176         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7177           cmp_rslt = 1;
7178         }
7179       }
7180     }
7181   }
7182   /* This is already UNIX or at least nothing VMS understands */
7183   if (cmp_rslt) {
7184     strcpy(rslt,spec);
7185     if (vms_debug_fileify) {
7186         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7187     }
7188     return rslt;
7189   }
7190
7191   cp1 = rslt;
7192   cp2 = spec;
7193   dirend = strrchr(spec,']');
7194   if (dirend == NULL) dirend = strrchr(spec,'>');
7195   if (dirend == NULL) dirend = strchr(spec,':');
7196   if (dirend == NULL) {
7197     strcpy(rslt,spec);
7198     if (vms_debug_fileify) {
7199         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7200     }
7201     return rslt;
7202   }
7203
7204   /* Special case 1 - sys$posix_root = / */
7205 #if __CRTL_VER >= 70000000
7206   if (!decc_disable_posix_root) {
7207     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7208       *cp1 = '/';
7209       cp1++;
7210       cp2 = cp2 + 15;
7211       }
7212   }
7213 #endif
7214
7215   /* Special case 2 - Convert NLA0: to /dev/null */
7216 #if __CRTL_VER < 70000000
7217   cmp_rslt = strncmp(spec,"NLA0:", 5);
7218   if (cmp_rslt != 0)
7219      cmp_rslt = strncmp(spec,"nla0:", 5);
7220 #else
7221   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7222 #endif
7223   if (cmp_rslt == 0) {
7224     strcpy(rslt, "/dev/null");
7225     cp1 = cp1 + 9;
7226     cp2 = cp2 + 5;
7227     if (spec[6] != '\0') {
7228       cp1[9] == '/';
7229       cp1++;
7230       cp2++;
7231     }
7232   }
7233
7234    /* Also handle special case "SYS$SCRATCH:" */
7235 #if __CRTL_VER < 70000000
7236   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
7237   if (cmp_rslt != 0)
7238      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
7239 #else
7240   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7241 #endif
7242   tmp = PerlMem_malloc(VMS_MAXRSS);
7243   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7244   if (cmp_rslt == 0) {
7245   int islnm;
7246
7247     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7248     if (!islnm) {
7249       strcpy(rslt, "/tmp");
7250       cp1 = cp1 + 4;
7251       cp2 = cp2 + 12;
7252       if (spec[12] != '\0') {
7253         cp1[4] == '/';
7254         cp1++;
7255         cp2++;
7256       }
7257     }
7258   }
7259
7260   if (*cp2 != '[' && *cp2 != '<') {
7261     *(cp1++) = '/';
7262   }
7263   else {  /* the VMS spec begins with directories */
7264     cp2++;
7265     if (*cp2 == ']' || *cp2 == '>') {
7266       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7267       PerlMem_free(tmp);
7268       return rslt;
7269     }
7270     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7271       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7272         PerlMem_free(tmp);
7273         if (vms_debug_fileify) {
7274             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7275         }
7276         return NULL;
7277       }
7278       trnlnm_iter_count = 0;
7279       do {
7280         cp3 = tmp;
7281         while (*cp3 != ':' && *cp3) cp3++;
7282         *(cp3++) = '\0';
7283         if (strchr(cp3,']') != NULL) break;
7284         trnlnm_iter_count++;
7285         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7286       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7287       cp1 = rslt;
7288       cp3 = tmp;
7289       *(cp1++) = '/';
7290       while (*cp3) {
7291         *(cp1++) = *(cp3++);
7292         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7293             PerlMem_free(tmp);
7294             set_errno(ENAMETOOLONG);
7295             set_vaxc_errno(SS$_BUFFEROVF);
7296             if (vms_debug_fileify) {
7297                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7298             }
7299             return NULL; /* No room */
7300         }
7301       }
7302       *(cp1++) = '/';
7303     }
7304     if ((*cp2 == '^')) {
7305         /* EFS file escape, pass the next character as is */
7306         /* Fix me: HEX encoding for Unicode not implemented */
7307         cp2++;
7308     }
7309     else if ( *cp2 == '.') {
7310       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7311         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7312         cp2 += 3;
7313       }
7314       else cp2++;
7315     }
7316   }
7317   PerlMem_free(tmp);
7318   for (; cp2 <= dirend; cp2++) {
7319     if ((*cp2 == '^')) {
7320         /* EFS file escape, pass the next character as is */
7321         /* Fix me: HEX encoding for Unicode not implemented */
7322         *(cp1++) = *(++cp2);
7323         /* An escaped dot stays as is -- don't convert to slash */
7324         if (*cp2 == '.') cp2++;
7325     }
7326     if (*cp2 == ':') {
7327       *(cp1++) = '/';
7328       if (*(cp2+1) == '[') cp2++;
7329     }
7330     else if (*cp2 == ']' || *cp2 == '>') {
7331       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7332     }
7333     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7334       *(cp1++) = '/';
7335       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7336         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7337                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7338         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7339             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7340       }
7341       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7342         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7343         cp2 += 2;
7344       }
7345     }
7346     else if (*cp2 == '-') {
7347       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7348         while (*cp2 == '-') {
7349           cp2++;
7350           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7351         }
7352         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7353                                                          /* filespecs like */
7354           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7355           if (vms_debug_fileify) {
7356               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7357           }
7358           return NULL;
7359         }
7360       }
7361       else *(cp1++) = *cp2;
7362     }
7363     else *(cp1++) = *cp2;
7364   }
7365   /* Translate the rest of the filename. */
7366   while (*cp2) {
7367       int dot_seen;
7368       dot_seen = 0;
7369       switch(*cp2) {
7370       /* Fixme - for compatibility with the CRTL we should be removing */
7371       /* spaces from the file specifications, but this may show that */
7372       /* some tests that were appearing to pass are not really passing */
7373       case '%':
7374           cp2++;
7375           *(cp1++) = '?';
7376           break;
7377       case '^':
7378           /* Fix me hex expansions not implemented */
7379           cp2++;  /* '^.' --> '.' and other. */
7380           if (*cp2) {
7381               if (*cp2 == '_') {
7382                   cp2++;
7383                   *(cp1++) = ' ';
7384               } else {
7385                   *(cp1++) = *(cp2++);
7386               }
7387           }
7388           break;
7389       case ';':
7390           if (decc_filename_unix_no_version) {
7391               /* Easy, drop the version */
7392               while (*cp2)
7393                   cp2++;
7394               break;
7395           } else {
7396               /* Punt - passing the version as a dot will probably */
7397               /* break perl in weird ways, but so did passing */
7398               /* through the ; as a version.  Follow the CRTL and */
7399               /* hope for the best. */
7400               cp2++;
7401               *(cp1++) = '.';
7402           }
7403           break;
7404       case '.':
7405           if (dot_seen) {
7406               /* We will need to fix this properly later */
7407               /* As Perl may be installed on an ODS-5 volume, but not */
7408               /* have the EFS_CHARSET enabled, it still may encounter */
7409               /* filenames with extra dots in them, and a precedent got */
7410               /* set which allowed them to work, that we will uphold here */
7411               /* If extra dots are present in a name and no ^ is on them */
7412               /* VMS assumes that the first one is the extension delimiter */
7413               /* the rest have an implied ^. */
7414
7415               /* this is also a conflict as the . is also a version */
7416               /* delimiter in VMS, */
7417
7418               *(cp1++) = *(cp2++);
7419               break;
7420           }
7421           dot_seen = 1;
7422           /* This is an extension */
7423           if (decc_readdir_dropdotnotype) {
7424               cp2++;
7425               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7426                   /* Drop the dot for the extension */
7427                   break;
7428               } else {
7429                   *(cp1++) = '.';
7430               }
7431               break;
7432           }
7433       default:
7434           *(cp1++) = *(cp2++);
7435       }
7436   }
7437   *cp1 = '\0';
7438
7439   /* This still leaves /000000/ when working with a
7440    * VMS device root or concealed root.
7441    */
7442   {
7443   int ulen;
7444   char * zeros;
7445
7446       ulen = strlen(rslt);
7447
7448       /* Get rid of "000000/ in rooted filespecs */
7449       if (ulen > 7) {
7450         zeros = strstr(rslt, "/000000/");
7451         if (zeros != NULL) {
7452           int mlen;
7453           mlen = ulen - (zeros - rslt) - 7;
7454           memmove(zeros, &zeros[7], mlen);
7455           ulen = ulen - 7;
7456           rslt[ulen] = '\0';
7457         }
7458       }
7459   }
7460
7461   if (vms_debug_fileify) {
7462       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7463   }
7464   return rslt;
7465
7466 }  /* end of int_tounixspec() */
7467
7468
7469 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7470 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7471 {
7472     static char __tounixspec_retbuf[VMS_MAXRSS];
7473     char * unixspec, *ret_spec, *ret_buf;
7474
7475     unixspec = NULL;
7476     ret_buf = buf;
7477     if (ret_buf == NULL) {
7478         if (ts) {
7479             Newx(unixspec, VMS_MAXRSS, char);
7480             if (unixspec == NULL)
7481                 _ckvmssts(SS$_INSFMEM);
7482             ret_buf = unixspec;
7483         } else {
7484             ret_buf = __tounixspec_retbuf;
7485         }
7486     }
7487
7488     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7489
7490     if (ret_spec == NULL) {
7491        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7492        if (unixspec)
7493            Safefree(unixspec);
7494     }
7495
7496     return ret_spec;
7497
7498 }  /* end of do_tounixspec() */
7499 /*}}}*/
7500 /* External entry points */
7501 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7502   { return do_tounixspec(spec,buf,0, NULL); }
7503 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7504   { return do_tounixspec(spec,buf,1, NULL); }
7505 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7506   { return do_tounixspec(spec,buf,0, utf8_fl); }
7507 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7508   { return do_tounixspec(spec,buf,1, utf8_fl); }
7509
7510 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7511
7512 /*
7513  This procedure is used to identify if a path is based in either
7514  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7515  it returns the OpenVMS format directory for it.
7516
7517  It is expecting specifications of only '/' or '/xxxx/'
7518
7519  If a posix root does not exist, or 'xxxx' is not a directory
7520  in the posix root, it returns a failure.
7521
7522  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7523
7524  It is used only internally by posix_to_vmsspec_hardway().
7525  */
7526
7527 static int posix_root_to_vms
7528   (char *vmspath, int vmspath_len,
7529    const char *unixpath,
7530    const int * utf8_fl)
7531 {
7532 int sts;
7533 struct FAB myfab = cc$rms_fab;
7534 rms_setup_nam(mynam);
7535 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7536 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7537 char * esa, * esal, * rsa, * rsal;
7538 char *vms_delim;
7539 int dir_flag;
7540 int unixlen;
7541
7542     dir_flag = 0;
7543     vmspath[0] = '\0';
7544     unixlen = strlen(unixpath);
7545     if (unixlen == 0) {
7546       return RMS$_FNF;
7547     }
7548
7549 #if __CRTL_VER >= 80200000
7550   /* If not a posix spec already, convert it */
7551   if (decc_posix_compliant_pathnames) {
7552     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7553       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7554     }
7555     else {
7556       /* This is already a VMS specification, no conversion */
7557       unixlen--;
7558       strncpy(vmspath,unixpath, vmspath_len);
7559     }
7560   }
7561   else
7562 #endif
7563   {
7564   int path_len;
7565   int i,j;
7566
7567      /* Check to see if this is under the POSIX root */
7568      if (decc_disable_posix_root) {
7569         return RMS$_FNF;
7570      }
7571
7572      /* Skip leading / */
7573      if (unixpath[0] == '/') {
7574         unixpath++;
7575         unixlen--;
7576      }
7577
7578
7579      strcpy(vmspath,"SYS$POSIX_ROOT:");
7580
7581      /* If this is only the / , or blank, then... */
7582      if (unixpath[0] == '\0') {
7583         /* by definition, this is the answer */
7584         return SS$_NORMAL;
7585      }
7586
7587      /* Need to look up a directory */
7588      vmspath[15] = '[';
7589      vmspath[16] = '\0';
7590
7591      /* Copy and add '^' escape characters as needed */
7592      j = 16;
7593      i = 0;
7594      while (unixpath[i] != 0) {
7595      int k;
7596
7597         j += copy_expand_unix_filename_escape
7598             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7599         i += k;
7600      }
7601
7602      path_len = strlen(vmspath);
7603      if (vmspath[path_len - 1] == '/')
7604         path_len--;
7605      vmspath[path_len] = ']';
7606      path_len++;
7607      vmspath[path_len] = '\0';
7608
7609   }
7610   vmspath[vmspath_len] = 0;
7611   if (unixpath[unixlen - 1] == '/')
7612   dir_flag = 1;
7613   esal = PerlMem_malloc(VMS_MAXRSS);
7614   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7615   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7616   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7617   rsal = PerlMem_malloc(VMS_MAXRSS);
7618   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7619   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7620   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7621   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7622   rms_bind_fab_nam(myfab, mynam);
7623   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7624   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7625   if (decc_efs_case_preserve)
7626     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7627 #ifdef NAML$M_OPEN_SPECIAL
7628   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7629 #endif
7630
7631   /* Set up the remaining naml fields */
7632   sts = sys$parse(&myfab);
7633
7634   /* It failed! Try again as a UNIX filespec */
7635   if (!(sts & 1)) {
7636     PerlMem_free(esal);
7637     PerlMem_free(esa);
7638     PerlMem_free(rsal);
7639     PerlMem_free(rsa);
7640     return sts;
7641   }
7642
7643    /* get the Device ID and the FID */
7644    sts = sys$search(&myfab);
7645
7646    /* These are no longer needed */
7647    PerlMem_free(esa);
7648    PerlMem_free(rsal);
7649    PerlMem_free(rsa);
7650
7651    /* on any failure, returned the POSIX ^UP^ filespec */
7652    if (!(sts & 1)) {
7653       PerlMem_free(esal);
7654       return sts;
7655    }
7656    specdsc.dsc$a_pointer = vmspath;
7657    specdsc.dsc$w_length = vmspath_len;
7658
7659    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7660    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7661    sts = lib$fid_to_name
7662       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7663
7664   /* on any failure, returned the POSIX ^UP^ filespec */
7665   if (!(sts & 1)) {
7666      /* This can happen if user does not have permission to read directories */
7667      if (strncmp(unixpath,"\"^UP^",5) != 0)
7668        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7669      else
7670        strcpy(vmspath, unixpath);
7671   }
7672   else {
7673     vmspath[specdsc.dsc$w_length] = 0;
7674
7675     /* Are we expecting a directory? */
7676     if (dir_flag != 0) {
7677     int i;
7678     char *eptr;
7679
7680       eptr = NULL;
7681
7682       i = specdsc.dsc$w_length - 1;
7683       while (i > 0) {
7684       int zercnt;
7685         zercnt = 0;
7686         /* Version must be '1' */
7687         if (vmspath[i--] != '1')
7688           break;
7689         /* Version delimiter is one of ".;" */
7690         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7691           break;
7692         i--;
7693         if (vmspath[i--] != 'R')
7694           break;
7695         if (vmspath[i--] != 'I')
7696           break;
7697         if (vmspath[i--] != 'D')
7698           break;
7699         if (vmspath[i--] != '.')
7700           break;
7701         eptr = &vmspath[i+1];
7702         while (i > 0) {
7703           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7704             if (vmspath[i-1] != '^') {
7705               if (zercnt != 6) {
7706                 *eptr = vmspath[i];
7707                 eptr[1] = '\0';
7708                 vmspath[i] = '.';
7709                 break;
7710               }
7711               else {
7712                 /* Get rid of 6 imaginary zero directory filename */
7713                 vmspath[i+1] = '\0';
7714               }
7715             }
7716           }
7717           if (vmspath[i] == '0')
7718             zercnt++;
7719           else
7720             zercnt = 10;
7721           i--;
7722         }
7723         break;
7724       }
7725     }
7726   }
7727   PerlMem_free(esal);
7728   return sts;
7729 }
7730
7731 /* /dev/mumble needs to be handled special.
7732    /dev/null becomes NLA0:, And there is the potential for other stuff
7733    like /dev/tty which may need to be mapped to something.
7734 */
7735
7736 static int
7737 slash_dev_special_to_vms
7738    (const char * unixptr,
7739     char * vmspath,
7740     int vmspath_len)
7741 {
7742 char * nextslash;
7743 int len;
7744 int cmp;
7745 int islnm;
7746
7747     unixptr += 4;
7748     nextslash = strchr(unixptr, '/');
7749     len = strlen(unixptr);
7750     if (nextslash != NULL)
7751         len = nextslash - unixptr;
7752     cmp = strncmp("null", unixptr, 5);
7753     if (cmp == 0) {
7754         if (vmspath_len >= 6) {
7755             strcpy(vmspath, "_NLA0:");
7756             return SS$_NORMAL;
7757         }
7758     }
7759 }
7760
7761
7762 /* The built in routines do not understand perl's special needs, so
7763     doing a manual conversion from UNIX to VMS
7764
7765     If the utf8_fl is not null and points to a non-zero value, then
7766     treat 8 bit characters as UTF-8.
7767
7768     The sequence starting with '$(' and ending with ')' will be passed
7769     through with out interpretation instead of being escaped.
7770
7771   */
7772 static int posix_to_vmsspec_hardway
7773   (char *vmspath, int vmspath_len,
7774    const char *unixpath,
7775    int dir_flag,
7776    int * utf8_fl) {
7777
7778 char *esa;
7779 const char *unixptr;
7780 const char *unixend;
7781 char *vmsptr;
7782 const char *lastslash;
7783 const char *lastdot;
7784 int unixlen;
7785 int vmslen;
7786 int dir_start;
7787 int dir_dot;
7788 int quoted;
7789 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7790 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7791
7792   if (utf8_fl != NULL)
7793     *utf8_fl = 0;
7794
7795   unixptr = unixpath;
7796   dir_dot = 0;
7797
7798   /* Ignore leading "/" characters */
7799   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7800     unixptr++;
7801   }
7802   unixlen = strlen(unixptr);
7803
7804   /* Do nothing with blank paths */
7805   if (unixlen == 0) {
7806     vmspath[0] = '\0';
7807     return SS$_NORMAL;
7808   }
7809
7810   quoted = 0;
7811   /* This could have a "^UP^ on the front */
7812   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7813     quoted = 1;
7814     unixptr+= 5;
7815     unixlen-= 5;
7816   }
7817
7818   lastslash = strrchr(unixptr,'/');
7819   lastdot = strrchr(unixptr,'.');
7820   unixend = strrchr(unixptr,'\"');
7821   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7822     unixend = unixptr + unixlen;
7823   }
7824
7825   /* last dot is last dot or past end of string */
7826   if (lastdot == NULL)
7827     lastdot = unixptr + unixlen;
7828
7829   /* if no directories, set last slash to beginning of string */
7830   if (lastslash == NULL) {
7831     lastslash = unixptr;
7832   }
7833   else {
7834     /* Watch out for trailing "." after last slash, still a directory */
7835     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7836       lastslash = unixptr + unixlen;
7837     }
7838
7839     /* Watch out for traiing ".." after last slash, still a directory */
7840     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7841       lastslash = unixptr + unixlen;
7842     }
7843
7844     /* dots in directories are aways escaped */
7845     if (lastdot < lastslash)
7846       lastdot = unixptr + unixlen;
7847   }
7848
7849   /* if (unixptr < lastslash) then we are in a directory */
7850
7851   dir_start = 0;
7852
7853   vmsptr = vmspath;
7854   vmslen = 0;
7855
7856   /* Start with the UNIX path */
7857   if (*unixptr != '/') {
7858     /* relative paths */
7859
7860     /* If allowing logical names on relative pathnames, then handle here */
7861     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7862         !decc_posix_compliant_pathnames) {
7863     char * nextslash;
7864     int seg_len;
7865     char * trn;
7866     int islnm;
7867
7868         /* Find the next slash */
7869         nextslash = strchr(unixptr,'/');
7870
7871         esa = PerlMem_malloc(vmspath_len);
7872         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7873
7874         trn = PerlMem_malloc(VMS_MAXRSS);
7875         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7876
7877         if (nextslash != NULL) {
7878
7879             seg_len = nextslash - unixptr;
7880             strncpy(esa, unixptr, seg_len);
7881             esa[seg_len] = 0;
7882         }
7883         else {
7884             strcpy(esa, unixptr);
7885             seg_len = strlen(unixptr);
7886         }
7887         /* trnlnm(section) */
7888         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7889
7890         if (islnm) {
7891             /* Now fix up the directory */
7892
7893             /* Split up the path to find the components */
7894             sts = vms_split_path
7895                   (trn,
7896                    &v_spec,
7897                    &v_len,
7898                    &r_spec,
7899                    &r_len,
7900                    &d_spec,
7901                    &d_len,
7902                    &n_spec,
7903                    &n_len,
7904                    &e_spec,
7905                    &e_len,
7906                    &vs_spec,
7907                    &vs_len);
7908
7909             while (sts == 0) {
7910             char * strt;
7911             int cmp;
7912
7913                 /* A logical name must be a directory  or the full
7914                    specification.  It is only a full specification if
7915                    it is the only component */
7916                 if ((unixptr[seg_len] == '\0') ||
7917                     (unixptr[seg_len+1] == '\0')) {
7918
7919                     /* Is a directory being required? */
7920                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7921                         /* Not a logical name */
7922                         break;
7923                     }
7924
7925
7926                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7927                         /* This must be a directory */
7928                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7929                             strcpy(vmsptr, esa);
7930                             vmslen=strlen(vmsptr);
7931                             vmsptr[vmslen] = ':';
7932                             vmslen++;
7933                             vmsptr[vmslen] = '\0';
7934                             return SS$_NORMAL;
7935                         }
7936                     }
7937
7938                 }
7939
7940
7941                 /* must be dev/directory - ignore version */
7942                 if ((n_len + e_len) != 0)
7943                     break;
7944
7945                 /* transfer the volume */
7946                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7947                     strncpy(vmsptr, v_spec, v_len);
7948                     vmsptr += v_len;
7949                     vmsptr[0] = '\0';
7950                     vmslen += v_len;
7951                 }
7952
7953                 /* unroot the rooted directory */
7954                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7955                     r_spec[0] = '[';
7956                     r_spec[r_len - 1] = ']';
7957
7958                     /* This should not be there, but nothing is perfect */
7959                     if (r_len > 9) {
7960                         cmp = strcmp(&r_spec[1], "000000.");
7961                         if (cmp == 0) {
7962                             r_spec += 7;
7963                             r_spec[7] = '[';
7964                             r_len -= 7;
7965                             if (r_len == 2)
7966                                 r_len = 0;
7967                         }
7968                     }
7969                     if (r_len > 0) {
7970                         strncpy(vmsptr, r_spec, r_len);
7971                         vmsptr += r_len;
7972                         vmslen += r_len;
7973                         vmsptr[0] = '\0';
7974                     }
7975                 }
7976                 /* Bring over the directory. */
7977                 if ((d_len > 0) &&
7978                     ((d_len + vmslen) < vmspath_len)) {
7979                     d_spec[0] = '[';
7980                     d_spec[d_len - 1] = ']';
7981                     if (d_len > 9) {
7982                         cmp = strcmp(&d_spec[1], "000000.");
7983                         if (cmp == 0) {
7984                             d_spec += 7;
7985                             d_spec[7] = '[';
7986                             d_len -= 7;
7987                             if (d_len == 2)
7988                                 d_len = 0;
7989                         }
7990                     }
7991
7992                     if (r_len > 0) {
7993                         /* Remove the redundant root */
7994                         if (r_len > 0) {
7995                             /* remove the ][ */
7996                             vmsptr--;
7997                             vmslen--;
7998                             d_spec++;
7999                             d_len--;
8000                         }
8001                         strncpy(vmsptr, d_spec, d_len);
8002                             vmsptr += d_len;
8003                             vmslen += d_len;
8004                             vmsptr[0] = '\0';
8005                     }
8006                 }
8007                 break;
8008             }
8009         }
8010
8011         PerlMem_free(esa);
8012         PerlMem_free(trn);
8013     }
8014
8015     if (lastslash > unixptr) {
8016     int dotdir_seen;
8017
8018       /* skip leading ./ */
8019       dotdir_seen = 0;
8020       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
8021         dotdir_seen = 1;
8022         unixptr++;
8023         unixptr++;
8024       }
8025
8026       /* Are we still in a directory? */
8027       if (unixptr <= lastslash) {
8028         *vmsptr++ = '[';
8029         vmslen = 1;
8030         dir_start = 1;
8031
8032         /* if not backing up, then it is relative forward. */
8033         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
8034               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
8035           *vmsptr++ = '.';
8036           vmslen++;
8037           dir_dot = 1;
8038           }
8039        }
8040        else {
8041          if (dotdir_seen) {
8042            /* Perl wants an empty directory here to tell the difference
8043             * between a DCL commmand and a filename
8044             */
8045           *vmsptr++ = '[';
8046           *vmsptr++ = ']';
8047           vmslen = 2;
8048         }
8049       }
8050     }
8051     else {
8052       /* Handle two special files . and .. */
8053       if (unixptr[0] == '.') {
8054         if (&unixptr[1] == unixend) {
8055           *vmsptr++ = '[';
8056           *vmsptr++ = ']';
8057           vmslen += 2;
8058           *vmsptr++ = '\0';
8059           return SS$_NORMAL;
8060         }
8061         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
8062           *vmsptr++ = '[';
8063           *vmsptr++ = '-';
8064           *vmsptr++ = ']';
8065           vmslen += 3;
8066           *vmsptr++ = '\0';
8067           return SS$_NORMAL;
8068         }
8069       }
8070     }
8071   }
8072   else {        /* Absolute PATH handling */
8073   int sts;
8074   char * nextslash;
8075   int seg_len;
8076     /* Need to find out where root is */
8077
8078     /* In theory, this procedure should never get an absolute POSIX pathname
8079      * that can not be found on the POSIX root.
8080      * In practice, that can not be relied on, and things will show up
8081      * here that are a VMS device name or concealed logical name instead.
8082      * So to make things work, this procedure must be tolerant.
8083      */
8084     esa = PerlMem_malloc(vmspath_len);
8085     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8086
8087     sts = SS$_NORMAL;
8088     nextslash = strchr(&unixptr[1],'/');
8089     seg_len = 0;
8090     if (nextslash != NULL) {
8091     int cmp;
8092       seg_len = nextslash - &unixptr[1];
8093       strncpy(vmspath, unixptr, seg_len + 1);
8094       vmspath[seg_len+1] = 0;
8095       cmp = 1;
8096       if (seg_len == 3) {
8097         cmp = strncmp(vmspath, "dev", 4);
8098         if (cmp == 0) {
8099             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
8100             if (sts = SS$_NORMAL)
8101                 return SS$_NORMAL;
8102         }
8103       }
8104       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
8105     }
8106
8107     if ($VMS_STATUS_SUCCESS(sts)) {
8108       /* This is verified to be a real path */
8109
8110       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8111       if ($VMS_STATUS_SUCCESS(sts)) {
8112         strcpy(vmspath, esa);
8113         vmslen = strlen(vmspath);
8114         vmsptr = vmspath + vmslen;
8115         unixptr++;
8116         if (unixptr < lastslash) {
8117         char * rptr;
8118           vmsptr--;
8119           *vmsptr++ = '.';
8120           dir_start = 1;
8121           dir_dot = 1;
8122           if (vmslen > 7) {
8123           int cmp;
8124             rptr = vmsptr - 7;
8125             cmp = strcmp(rptr,"000000.");
8126             if (cmp == 0) {
8127               vmslen -= 7;
8128               vmsptr -= 7;
8129               vmsptr[1] = '\0';
8130             } /* removing 6 zeros */
8131           } /* vmslen < 7, no 6 zeros possible */
8132         } /* Not in a directory */
8133       } /* Posix root found */
8134       else {
8135         /* No posix root, fall back to default directory */
8136         strcpy(vmspath, "SYS$DISK:[");
8137         vmsptr = &vmspath[10];
8138         vmslen = 10;
8139         if (unixptr > lastslash) {
8140            *vmsptr = ']';
8141            vmsptr++;
8142            vmslen++;
8143         }
8144         else {
8145            dir_start = 1;
8146         }
8147       }
8148     } /* end of verified real path handling */
8149     else {
8150     int add_6zero;
8151     int islnm;
8152
8153       /* Ok, we have a device or a concealed root that is not in POSIX
8154        * or we have garbage.  Make the best of it.
8155        */
8156
8157       /* Posix to VMS destroyed this, so copy it again */
8158       strncpy(vmspath, &unixptr[1], seg_len);
8159       vmspath[seg_len] = 0;
8160       vmslen = seg_len;
8161       vmsptr = &vmsptr[vmslen];
8162       islnm = 0;
8163
8164       /* Now do we need to add the fake 6 zero directory to it? */
8165       add_6zero = 1;
8166       if ((*lastslash == '/') && (nextslash < lastslash)) {
8167         /* No there is another directory */
8168         add_6zero = 0;
8169       }
8170       else {
8171       int trnend;
8172       int cmp;
8173
8174         /* now we have foo:bar or foo:[000000]bar to decide from */
8175         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8176
8177         if (!islnm && !decc_posix_compliant_pathnames) {
8178
8179             cmp = strncmp("bin", vmspath, 4);
8180             if (cmp == 0) {
8181                 /* bin => SYS$SYSTEM: */
8182                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8183             }
8184             else {
8185                 /* tmp => SYS$SCRATCH: */
8186                 cmp = strncmp("tmp", vmspath, 4);
8187                 if (cmp == 0) {
8188                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8189                 }
8190             }
8191         }
8192
8193         trnend = islnm ? islnm - 1 : 0;
8194
8195         /* if this was a logical name, ']' or '>' must be present */
8196         /* if not a logical name, then assume a device and hope. */
8197         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8198
8199         /* if log name and trailing '.' then rooted - treat as device */
8200         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8201
8202         /* Fix me, if not a logical name, a device lookup should be
8203          * done to see if the device is file structured.  If the device
8204          * is not file structured, the 6 zeros should not be put on.
8205          *
8206          * As it is, perl is occasionally looking for dev:[000000]tty.
8207          * which looks a little strange.
8208          *
8209          * Not that easy to detect as "/dev" may be file structured with
8210          * special device files.
8211          */
8212
8213         if ((add_6zero == 0) && (*nextslash == '/') &&
8214             (&nextslash[1] == unixend)) {
8215           /* No real directory present */
8216           add_6zero = 1;
8217         }
8218       }
8219
8220       /* Put the device delimiter on */
8221       *vmsptr++ = ':';
8222       vmslen++;
8223       unixptr = nextslash;
8224       unixptr++;
8225
8226       /* Start directory if needed */
8227       if (!islnm || add_6zero) {
8228         *vmsptr++ = '[';
8229         vmslen++;
8230         dir_start = 1;
8231       }
8232
8233       /* add fake 000000] if needed */
8234       if (add_6zero) {
8235         *vmsptr++ = '0';
8236         *vmsptr++ = '0';
8237         *vmsptr++ = '0';
8238         *vmsptr++ = '0';
8239         *vmsptr++ = '0';
8240         *vmsptr++ = '0';
8241         *vmsptr++ = ']';
8242         vmslen += 7;
8243         dir_start = 0;
8244       }
8245
8246     } /* non-POSIX translation */
8247     PerlMem_free(esa);
8248   } /* End of relative/absolute path handling */
8249
8250   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8251   int dash_flag;
8252   int in_cnt;
8253   int out_cnt;
8254
8255     dash_flag = 0;
8256
8257     if (dir_start != 0) {
8258
8259       /* First characters in a directory are handled special */
8260       while ((*unixptr == '/') ||
8261              ((*unixptr == '.') &&
8262               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8263                 (&unixptr[1]==unixend)))) {
8264       int loop_flag;
8265
8266         loop_flag = 0;
8267
8268         /* Skip redundant / in specification */
8269         while ((*unixptr == '/') && (dir_start != 0)) {
8270           loop_flag = 1;
8271           unixptr++;
8272           if (unixptr == lastslash)
8273             break;
8274         }
8275         if (unixptr == lastslash)
8276           break;
8277
8278         /* Skip redundant ./ characters */
8279         while ((*unixptr == '.') &&
8280                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8281           loop_flag = 1;
8282           unixptr++;
8283           if (unixptr == lastslash)
8284             break;
8285           if (*unixptr == '/')
8286             unixptr++;
8287         }
8288         if (unixptr == lastslash)
8289           break;
8290
8291         /* Skip redundant ../ characters */
8292         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8293              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8294           /* Set the backing up flag */
8295           loop_flag = 1;
8296           dir_dot = 0;
8297           dash_flag = 1;
8298           *vmsptr++ = '-';
8299           vmslen++;
8300           unixptr++; /* first . */
8301           unixptr++; /* second . */
8302           if (unixptr == lastslash)
8303             break;
8304           if (*unixptr == '/') /* The slash */
8305             unixptr++;
8306         }
8307         if (unixptr == lastslash)
8308           break;
8309
8310         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8311         /* Not needed when VMS is pretending to be UNIX. */
8312
8313         /* Is this loop stuck because of too many dots? */
8314         if (loop_flag == 0) {
8315           /* Exit the loop and pass the rest through */
8316           break;
8317         }
8318       }
8319
8320       /* Are we done with directories yet? */
8321       if (unixptr >= lastslash) {
8322
8323         /* Watch out for trailing dots */
8324         if (dir_dot != 0) {
8325             vmslen --;
8326             vmsptr--;
8327         }
8328         *vmsptr++ = ']';
8329         vmslen++;
8330         dash_flag = 0;
8331         dir_start = 0;
8332         if (*unixptr == '/')
8333           unixptr++;
8334       }
8335       else {
8336         /* Have we stopped backing up? */
8337         if (dash_flag) {
8338           *vmsptr++ = '.';
8339           vmslen++;
8340           dash_flag = 0;
8341           /* dir_start continues to be = 1 */
8342         }
8343         if (*unixptr == '-') {
8344           *vmsptr++ = '^';
8345           *vmsptr++ = *unixptr++;
8346           vmslen += 2;
8347           dir_start = 0;
8348
8349           /* Now are we done with directories yet? */
8350           if (unixptr >= lastslash) {
8351
8352             /* Watch out for trailing dots */
8353             if (dir_dot != 0) {
8354               vmslen --;
8355               vmsptr--;
8356             }
8357
8358             *vmsptr++ = ']';
8359             vmslen++;
8360             dash_flag = 0;
8361             dir_start = 0;
8362           }
8363         }
8364       }
8365     }
8366
8367     /* All done? */
8368     if (unixptr >= unixend)
8369       break;
8370
8371     /* Normal characters - More EFS work probably needed */
8372     dir_start = 0;
8373     dir_dot = 0;
8374
8375     switch(*unixptr) {
8376     case '/':
8377         /* remove multiple / */
8378         while (unixptr[1] == '/') {
8379            unixptr++;
8380         }
8381         if (unixptr == lastslash) {
8382           /* Watch out for trailing dots */
8383           if (dir_dot != 0) {
8384             vmslen --;
8385             vmsptr--;
8386           }
8387           *vmsptr++ = ']';
8388         }
8389         else {
8390           dir_start = 1;
8391           *vmsptr++ = '.';
8392           dir_dot = 1;
8393
8394           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8395           /* Not needed when VMS is pretending to be UNIX. */
8396
8397         }
8398         dash_flag = 0;
8399         if (unixptr != unixend)
8400           unixptr++;
8401         vmslen++;
8402         break;
8403     case '.':
8404         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8405             (&unixptr[1] == unixend)) {
8406           *vmsptr++ = '^';
8407           *vmsptr++ = '.';
8408           vmslen += 2;
8409           unixptr++;
8410
8411           /* trailing dot ==> '^..' on VMS */
8412           if (unixptr == unixend) {
8413             *vmsptr++ = '.';
8414             vmslen++;
8415             unixptr++;
8416           }
8417           break;
8418         }
8419
8420         *vmsptr++ = *unixptr++;
8421         vmslen ++;
8422         break;
8423     case '"':
8424         if (quoted && (&unixptr[1] == unixend)) {
8425             unixptr++;
8426             break;
8427         }
8428         in_cnt = copy_expand_unix_filename_escape
8429                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8430         vmsptr += out_cnt;
8431         unixptr += in_cnt;
8432         break;
8433     case '~':
8434     case ';':
8435     case '\\':
8436     case '?':
8437     case ' ':
8438     default:
8439         in_cnt = copy_expand_unix_filename_escape
8440                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8441         vmsptr += out_cnt;
8442         unixptr += in_cnt;
8443         break;
8444     }
8445   }
8446
8447   /* Make sure directory is closed */
8448   if (unixptr == lastslash) {
8449     char *vmsptr2;
8450     vmsptr2 = vmsptr - 1;
8451
8452     if (*vmsptr2 != ']') {
8453       *vmsptr2--;
8454
8455       /* directories do not end in a dot bracket */
8456       if (*vmsptr2 == '.') {
8457         vmsptr2--;
8458
8459         /* ^. is allowed */
8460         if (*vmsptr2 != '^') {
8461           vmsptr--; /* back up over the dot */
8462         }
8463       }
8464       *vmsptr++ = ']';
8465     }
8466   }
8467   else {
8468     char *vmsptr2;
8469     /* Add a trailing dot if a file with no extension */
8470     vmsptr2 = vmsptr - 1;
8471     if ((vmslen > 1) &&
8472         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8473         (*vmsptr2 != ')') && (*lastdot != '.')) {
8474         *vmsptr++ = '.';
8475         vmslen++;
8476     }
8477   }
8478
8479   *vmsptr = '\0';
8480   return SS$_NORMAL;
8481 }
8482 #endif
8483
8484  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8485 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8486 {
8487 char * result;
8488 int utf8_flag;
8489
8490    /* If a UTF8 flag is being passed, honor it */
8491    utf8_flag = 0;
8492    if (utf8_fl != NULL) {
8493      utf8_flag = *utf8_fl;
8494     *utf8_fl = 0;
8495    }
8496
8497    if (utf8_flag) {
8498      /* If there is a possibility of UTF8, then if any UTF8 characters
8499         are present, then they must be converted to VTF-7
8500       */
8501      result = strcpy(rslt, path); /* FIX-ME */
8502    }
8503    else
8504      result = strcpy(rslt, path);
8505
8506    return result;
8507 }
8508
8509
8510
8511 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8512 static char *int_tovmsspec
8513    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8514   char *dirend;
8515   char *lastdot;
8516   char *vms_delim;
8517   register char *cp1;
8518   const char *cp2;
8519   unsigned long int infront = 0, hasdir = 1;
8520   int rslt_len;
8521   int no_type_seen;
8522   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8523   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8524
8525   if (vms_debug_fileify) {
8526       if (path == NULL)
8527           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8528       else
8529           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8530   }
8531
8532   if (path == NULL) {
8533       /* If we fail, we should be setting errno */
8534       set_errno(EINVAL);
8535       set_vaxc_errno(SS$_BADPARAM);
8536       return NULL;
8537   }
8538   rslt_len = VMS_MAXRSS-1;
8539
8540   /* '.' and '..' are "[]" and "[-]" for a quick check */
8541   if (path[0] == '.') {
8542     if (path[1] == '\0') {
8543       strcpy(rslt,"[]");
8544       if (utf8_flag != NULL)
8545         *utf8_flag = 0;
8546       return rslt;
8547     }
8548     else {
8549       if (path[1] == '.' && path[2] == '\0') {
8550         strcpy(rslt,"[-]");
8551         if (utf8_flag != NULL)
8552            *utf8_flag = 0;
8553         return rslt;
8554       }
8555     }
8556   }
8557
8558    /* Posix specifications are now a native VMS format */
8559   /*--------------------------------------------------*/
8560 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8561   if (decc_posix_compliant_pathnames) {
8562     if (strncmp(path,"\"^UP^",5) == 0) {
8563       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8564       return rslt;
8565     }
8566   }
8567 #endif
8568
8569   /* This is really the only way to see if this is already in VMS format */
8570   sts = vms_split_path
8571        (path,
8572         &v_spec,
8573         &v_len,
8574         &r_spec,
8575         &r_len,
8576         &d_spec,
8577         &d_len,
8578         &n_spec,
8579         &n_len,
8580         &e_spec,
8581         &e_len,
8582         &vs_spec,
8583         &vs_len);
8584   if (sts == 0) {
8585     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8586        replacement, because the above parse just took care of most of
8587        what is needed to do vmspath when the specification is already
8588        in VMS format.
8589
8590        And if it is not already, it is easier to do the conversion as
8591        part of this routine than to call this routine and then work on
8592        the result.
8593      */
8594
8595     /* If VMS punctuation was found, it is already VMS format */
8596     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8597       if (utf8_flag != NULL)
8598         *utf8_flag = 0;
8599       strcpy(rslt, path);
8600       if (vms_debug_fileify) {
8601           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8602       }
8603       return rslt;
8604     }
8605     /* Now, what to do with trailing "." cases where there is no
8606        extension?  If this is a UNIX specification, and EFS characters
8607        are enabled, then the trailing "." should be converted to a "^.".
8608        But if this was already a VMS specification, then it should be
8609        left alone.
8610
8611        So in the case of ambiguity, leave the specification alone.
8612      */
8613
8614
8615     /* If there is a possibility of UTF8, then if any UTF8 characters
8616         are present, then they must be converted to VTF-7
8617      */
8618     if (utf8_flag != NULL)
8619       *utf8_flag = 0;
8620     strcpy(rslt, path);
8621     if (vms_debug_fileify) {
8622         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8623     }
8624     return rslt;
8625   }
8626
8627   dirend = strrchr(path,'/');
8628
8629   if (dirend == NULL) {
8630      char *macro_start;
8631      int has_macro;
8632
8633      /* If we get here with no UNIX directory delimiters, then this is
8634         not a complete file specification, either garbage a UNIX glob
8635         specification that can not be converted to a VMS wildcard, or
8636         it a UNIX shell macro.  MakeMaker wants shell macros passed
8637         through AS-IS,
8638
8639         utf8 flag setting needs to be preserved.
8640       */
8641       hasdir = 0;
8642
8643       has_macro = 0;
8644       macro_start = strchr(path,'$');
8645       if (macro_start != NULL) {
8646           if (macro_start[1] == '(') {
8647               has_macro = 1;
8648           }
8649       }
8650       if ((decc_efs_charset == 0) || (has_macro)) {
8651           strcpy(rslt, path);
8652           if (vms_debug_fileify) {
8653               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8654           }
8655           return rslt;
8656       }
8657   }
8658
8659 /* If POSIX mode active, handle the conversion */
8660 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8661   if (decc_efs_charset) {
8662     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8663     if (vms_debug_fileify) {
8664         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8665     }
8666     return rslt;
8667   }
8668 #endif
8669
8670   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8671     if (!*(dirend+2)) dirend +=2;
8672     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8673     if (decc_efs_charset == 0) {
8674       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8675     }
8676   }
8677
8678   cp1 = rslt;
8679   cp2 = path;
8680   lastdot = strrchr(cp2,'.');
8681   if (*cp2 == '/') {
8682     char *trndev;
8683     int islnm, rooted;
8684     STRLEN trnend;
8685
8686     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8687     if (!*(cp2+1)) {
8688       if (decc_disable_posix_root) {
8689         strcpy(rslt,"sys$disk:[000000]");
8690       }
8691       else {
8692         strcpy(rslt,"sys$posix_root:[000000]");
8693       }
8694       if (utf8_flag != NULL)
8695         *utf8_flag = 0;
8696       if (vms_debug_fileify) {
8697           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8698       }
8699       return rslt;
8700     }
8701     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8702     *cp1 = '\0';
8703     trndev = PerlMem_malloc(VMS_MAXRSS);
8704     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8705     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8706
8707      /* DECC special handling */
8708     if (!islnm) {
8709       if (strcmp(rslt,"bin") == 0) {
8710         strcpy(rslt,"sys$system");
8711         cp1 = rslt + 10;
8712         *cp1 = 0;
8713         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8714       }
8715       else if (strcmp(rslt,"tmp") == 0) {
8716         strcpy(rslt,"sys$scratch");
8717         cp1 = rslt + 11;
8718         *cp1 = 0;
8719         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8720       }
8721       else if (!decc_disable_posix_root) {
8722         strcpy(rslt, "sys$posix_root");
8723         cp1 = rslt + 14;
8724         *cp1 = 0;
8725         cp2 = path;
8726         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8727         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8728       }
8729       else if (strcmp(rslt,"dev") == 0) {
8730         if (strncmp(cp2,"/null", 5) == 0) {
8731           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8732             strcpy(rslt,"NLA0");
8733             cp1 = rslt + 4;
8734             *cp1 = 0;
8735             cp2 = cp2 + 5;
8736             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8737           }
8738         }
8739       }
8740     }
8741
8742     trnend = islnm ? strlen(trndev) - 1 : 0;
8743     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8744     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8745     /* If the first element of the path is a logical name, determine
8746      * whether it has to be translated so we can add more directories. */
8747     if (!islnm || rooted) {
8748       *(cp1++) = ':';
8749       *(cp1++) = '[';
8750       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8751       else cp2++;
8752     }
8753     else {
8754       if (cp2 != dirend) {
8755         strcpy(rslt,trndev);
8756         cp1 = rslt + trnend;
8757         if (*cp2 != 0) {
8758           *(cp1++) = '.';
8759           cp2++;
8760         }
8761       }
8762       else {
8763         if (decc_disable_posix_root) {
8764           *(cp1++) = ':';
8765           hasdir = 0;
8766         }
8767       }
8768     }
8769     PerlMem_free(trndev);
8770   }
8771   else {
8772     *(cp1++) = '[';
8773     if (*cp2 == '.') {
8774       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8775         cp2 += 2;         /* skip over "./" - it's redundant */
8776         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8777       }
8778       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8779         *(cp1++) = '-';                                 /* "../" --> "-" */
8780         cp2 += 3;
8781       }
8782       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8783                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8784         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8785         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8786         cp2 += 4;
8787       }
8788       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8789         /* Escape the extra dots in EFS file specifications */
8790         *(cp1++) = '^';
8791       }
8792       if (cp2 > dirend) cp2 = dirend;
8793     }
8794     else *(cp1++) = '.';
8795   }
8796   for (; cp2 < dirend; cp2++) {
8797     if (*cp2 == '/') {
8798       if (*(cp2-1) == '/') continue;
8799       if (*(cp1-1) != '.') *(cp1++) = '.';
8800       infront = 0;
8801     }
8802     else if (!infront && *cp2 == '.') {
8803       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8804       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8805       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8806         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8807         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8808         else {  /* back up over previous directory name */
8809           cp1--;
8810           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8811           if (*(cp1-1) == '[') {
8812             memcpy(cp1,"000000.",7);
8813             cp1 += 7;
8814           }
8815         }
8816         cp2 += 2;
8817         if (cp2 == dirend) break;
8818       }
8819       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8820                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8821         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8822         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8823         if (!*(cp2+3)) {
8824           *(cp1++) = '.';  /* Simulate trailing '/' */
8825           cp2 += 2;  /* for loop will incr this to == dirend */
8826         }
8827         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8828       }
8829       else {
8830         if (decc_efs_charset == 0)
8831           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8832         else {
8833           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8834           *(cp1++) = '.';
8835         }
8836       }
8837     }
8838     else {
8839       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8840       if (*cp2 == '.') {
8841         if (decc_efs_charset == 0)
8842           *(cp1++) = '_';
8843         else {
8844           *(cp1++) = '^';
8845           *(cp1++) = '.';
8846         }
8847       }
8848       else                  *(cp1++) =  *cp2;
8849       infront = 1;
8850     }
8851   }
8852   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8853   if (hasdir) *(cp1++) = ']';
8854   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8855   /* fixme for ODS5 */
8856   no_type_seen = 0;
8857   if (cp2 > lastdot)
8858     no_type_seen = 1;
8859   while (*cp2) {
8860     switch(*cp2) {
8861     case '?':
8862         if (decc_efs_charset == 0)
8863           *(cp1++) = '%';
8864         else
8865           *(cp1++) = '?';
8866         cp2++;
8867     case ' ':
8868         *(cp1)++ = '^';
8869         *(cp1)++ = '_';
8870         cp2++;
8871         break;
8872     case '.':
8873         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8874             decc_readdir_dropdotnotype) {
8875           *(cp1)++ = '^';
8876           *(cp1)++ = '.';
8877           cp2++;
8878
8879           /* trailing dot ==> '^..' on VMS */
8880           if (*cp2 == '\0') {
8881             *(cp1++) = '.';
8882             no_type_seen = 0;
8883           }
8884         }
8885         else {
8886           *(cp1++) = *(cp2++);
8887           no_type_seen = 0;
8888         }
8889         break;
8890     case '$':
8891          /* This could be a macro to be passed through */
8892         *(cp1++) = *(cp2++);
8893         if (*cp2 == '(') {
8894         const char * save_cp2;
8895         char * save_cp1;
8896         int is_macro;
8897
8898             /* paranoid check */
8899             save_cp2 = cp2;
8900             save_cp1 = cp1;
8901             is_macro = 0;
8902
8903             /* Test through */
8904             *(cp1++) = *(cp2++);
8905             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8906                 *(cp1++) = *(cp2++);
8907                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8908                     *(cp1++) = *(cp2++);
8909                 }
8910                 if (*cp2 == ')') {
8911                     *(cp1++) = *(cp2++);
8912                     is_macro = 1;
8913                 }
8914             }
8915             if (is_macro == 0) {
8916                 /* Not really a macro - never mind */
8917                 cp2 = save_cp2;
8918                 cp1 = save_cp1;
8919             }
8920         }
8921         break;
8922     case '\"':
8923     case '~':
8924     case '`':
8925     case '!':
8926     case '#':
8927     case '%':
8928     case '^':
8929         /* Don't escape again if following character is
8930          * already something we escape.
8931          */
8932         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8933             *(cp1++) = *(cp2++);
8934             break;
8935         }
8936         /* But otherwise fall through and escape it. */
8937     case '&':
8938     case '(':
8939     case ')':
8940     case '=':
8941     case '+':
8942     case '\'':
8943     case '@':
8944     case '[':
8945     case ']':
8946     case '{':
8947     case '}':
8948     case ':':
8949     case '\\':
8950     case '|':
8951     case '<':
8952     case '>':
8953         *(cp1++) = '^';
8954         *(cp1++) = *(cp2++);
8955         break;
8956     case ';':
8957         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8958          * which is wrong.  UNIX notation should be ".dir." unless
8959          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8960          * changing this behavior could break more things at this time.
8961          * efs character set effectively does not allow "." to be a version
8962          * delimiter as a further complication about changing this.
8963          */
8964         if (decc_filename_unix_report != 0) {
8965           *(cp1++) = '^';
8966         }
8967         *(cp1++) = *(cp2++);
8968         break;
8969     default:
8970         *(cp1++) = *(cp2++);
8971     }
8972   }
8973   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8974   char *lcp1;
8975     lcp1 = cp1;
8976     lcp1--;
8977      /* Fix me for "^]", but that requires making sure that you do
8978       * not back up past the start of the filename
8979       */
8980     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8981       *cp1++ = '.';
8982   }
8983   *cp1 = '\0';
8984
8985   if (utf8_flag != NULL)
8986     *utf8_flag = 0;
8987   if (vms_debug_fileify) {
8988       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8989   }
8990   return rslt;
8991
8992 }  /* end of int_tovmsspec() */
8993
8994
8995 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8996 static char *mp_do_tovmsspec
8997    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8998   static char __tovmsspec_retbuf[VMS_MAXRSS];
8999     char * vmsspec, *ret_spec, *ret_buf;
9000
9001     vmsspec = NULL;
9002     ret_buf = buf;
9003     if (ret_buf == NULL) {
9004         if (ts) {
9005             Newx(vmsspec, VMS_MAXRSS, char);
9006             if (vmsspec == NULL)
9007                 _ckvmssts(SS$_INSFMEM);
9008             ret_buf = vmsspec;
9009         } else {
9010             ret_buf = __tovmsspec_retbuf;
9011         }
9012     }
9013
9014     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
9015
9016     if (ret_spec == NULL) {
9017        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
9018        if (vmsspec)
9019            Safefree(vmsspec);
9020     }
9021
9022     return ret_spec;
9023
9024 }  /* end of mp_do_tovmsspec() */
9025 /*}}}*/
9026 /* External entry points */
9027 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
9028   { return do_tovmsspec(path,buf,0,NULL); }
9029 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
9030   { return do_tovmsspec(path,buf,1,NULL); }
9031 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9032   { return do_tovmsspec(path,buf,0,utf8_fl); }
9033 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9034   { return do_tovmsspec(path,buf,1,utf8_fl); }
9035
9036 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
9037 /* Internal routine for use with out an explict context present */
9038 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
9039
9040     char * ret_spec, *pathified;
9041
9042     if (path == NULL)
9043         return NULL;
9044
9045     pathified = PerlMem_malloc(VMS_MAXRSS);
9046     if (pathified == NULL)
9047         _ckvmssts_noperl(SS$_INSFMEM);
9048
9049     ret_spec = int_pathify_dirspec(path, pathified);
9050
9051     if (ret_spec == NULL) {
9052         PerlMem_free(pathified);
9053         return NULL;
9054     }
9055
9056     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
9057
9058     PerlMem_free(pathified);
9059     return ret_spec;
9060
9061 }
9062
9063 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
9064 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9065   static char __tovmspath_retbuf[VMS_MAXRSS];
9066   int vmslen;
9067   char *pathified, *vmsified, *cp;
9068
9069   if (path == NULL) return NULL;
9070   pathified = PerlMem_malloc(VMS_MAXRSS);
9071   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9072   if (int_pathify_dirspec(path, pathified) == NULL) {
9073     PerlMem_free(pathified);
9074     return NULL;
9075   }
9076
9077   vmsified = NULL;
9078   if (buf == NULL)
9079      Newx(vmsified, VMS_MAXRSS, char);
9080   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
9081     PerlMem_free(pathified);
9082     if (vmsified) Safefree(vmsified);
9083     return NULL;
9084   }
9085   PerlMem_free(pathified);
9086   if (buf) {
9087     return buf;
9088   }
9089   else if (ts) {
9090     vmslen = strlen(vmsified);
9091     Newx(cp,vmslen+1,char);
9092     memcpy(cp,vmsified,vmslen);
9093     cp[vmslen] = '\0';
9094     Safefree(vmsified);
9095     return cp;
9096   }
9097   else {
9098     strcpy(__tovmspath_retbuf,vmsified);
9099     Safefree(vmsified);
9100     return __tovmspath_retbuf;
9101   }
9102
9103 }  /* end of do_tovmspath() */
9104 /*}}}*/
9105 /* External entry points */
9106 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
9107   { return do_tovmspath(path,buf,0, NULL); }
9108 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
9109   { return do_tovmspath(path,buf,1, NULL); }
9110 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
9111   { return do_tovmspath(path,buf,0,utf8_fl); }
9112 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
9113   { return do_tovmspath(path,buf,1,utf8_fl); }
9114
9115
9116 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
9117 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9118   static char __tounixpath_retbuf[VMS_MAXRSS];
9119   int unixlen;
9120   char *pathified, *unixified, *cp;
9121
9122   if (path == NULL) return NULL;
9123   pathified = PerlMem_malloc(VMS_MAXRSS);
9124   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9125   if (int_pathify_dirspec(path, pathified) == NULL) {
9126     PerlMem_free(pathified);
9127     return NULL;
9128   }
9129
9130   unixified = NULL;
9131   if (buf == NULL) {
9132       Newx(unixified, VMS_MAXRSS, char);
9133   }
9134   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
9135     PerlMem_free(pathified);
9136     if (unixified) Safefree(unixified);
9137     return NULL;
9138   }
9139   PerlMem_free(pathified);
9140   if (buf) {
9141     return buf;
9142   }
9143   else if (ts) {
9144     unixlen = strlen(unixified);
9145     Newx(cp,unixlen+1,char);
9146     memcpy(cp,unixified,unixlen);
9147     cp[unixlen] = '\0';
9148     Safefree(unixified);
9149     return cp;
9150   }
9151   else {
9152     strcpy(__tounixpath_retbuf,unixified);
9153     Safefree(unixified);
9154     return __tounixpath_retbuf;
9155   }
9156
9157 }  /* end of do_tounixpath() */
9158 /*}}}*/
9159 /* External entry points */
9160 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
9161   { return do_tounixpath(path,buf,0,NULL); }
9162 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9163   { return do_tounixpath(path,buf,1,NULL); }
9164 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9165   { return do_tounixpath(path,buf,0,utf8_fl); }
9166 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9167   { return do_tounixpath(path,buf,1,utf8_fl); }
9168
9169 /*
9170  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
9171  *
9172  *****************************************************************************
9173  *                                                                           *
9174  *  Copyright (C) 1989-1994, 2007 by                                         *
9175  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
9176  *                                                                           *
9177  *  Permission is hereby granted for the reproduction of this software       *
9178  *  on condition that this copyright notice is included in source            *
9179  *  distributions of the software.  The code may be modified and             *
9180  *  distributed under the same terms as Perl itself.                         *
9181  *                                                                           *
9182  *  27-Aug-1994 Modified for inclusion in perl5                              *
9183  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
9184  *****************************************************************************
9185  */
9186
9187 /*
9188  * getredirection() is intended to aid in porting C programs
9189  * to VMS (Vax-11 C).  The native VMS environment does not support
9190  * '>' and '<' I/O redirection, or command line wild card expansion,
9191  * or a command line pipe mechanism using the '|' AND background
9192  * command execution '&'.  All of these capabilities are provided to any
9193  * C program which calls this procedure as the first thing in the
9194  * main program.
9195  * The piping mechanism will probably work with almost any 'filter' type
9196  * of program.  With suitable modification, it may useful for other
9197  * portability problems as well.
9198  *
9199  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
9200  */
9201 struct list_item
9202     {
9203     struct list_item *next;
9204     char *value;
9205     };
9206
9207 static void add_item(struct list_item **head,
9208                      struct list_item **tail,
9209                      char *value,
9210                      int *count);
9211
9212 static void mp_expand_wild_cards(pTHX_ char *item,
9213                                 struct list_item **head,
9214                                 struct list_item **tail,
9215                                 int *count);
9216
9217 static int background_process(pTHX_ int argc, char **argv);
9218
9219 static void pipe_and_fork(pTHX_ char **cmargv);
9220
9221 /*{{{ void getredirection(int *ac, char ***av)*/
9222 static void
9223 mp_getredirection(pTHX_ int *ac, char ***av)
9224 /*
9225  * Process vms redirection arg's.  Exit if any error is seen.
9226  * If getredirection() processes an argument, it is erased
9227  * from the vector.  getredirection() returns a new argc and argv value.
9228  * In the event that a background command is requested (by a trailing "&"),
9229  * this routine creates a background subprocess, and simply exits the program.
9230  *
9231  * Warning: do not try to simplify the code for vms.  The code
9232  * presupposes that getredirection() is called before any data is
9233  * read from stdin or written to stdout.
9234  *
9235  * Normal usage is as follows:
9236  *
9237  *      main(argc, argv)
9238  *      int             argc;
9239  *      char            *argv[];
9240  *      {
9241  *              getredirection(&argc, &argv);
9242  *      }
9243  */
9244 {
9245     int                 argc = *ac;     /* Argument Count         */
9246     char                **argv = *av;   /* Argument Vector        */
9247     char                *ap;            /* Argument pointer       */
9248     int                 j;              /* argv[] index           */
9249     int                 item_count = 0; /* Count of Items in List */
9250     struct list_item    *list_head = 0; /* First Item in List       */
9251     struct list_item    *list_tail;     /* Last Item in List        */
9252     char                *in = NULL;     /* Input File Name          */
9253     char                *out = NULL;    /* Output File Name         */
9254     char                *outmode = "w"; /* Mode to Open Output File */
9255     char                *err = NULL;    /* Error File Name          */
9256     char                *errmode = "w"; /* Mode to Open Error File  */
9257     int                 cmargc = 0;     /* Piped Command Arg Count  */
9258     char                **cmargv = NULL;/* Piped Command Arg Vector */
9259
9260     /*
9261      * First handle the case where the last thing on the line ends with
9262      * a '&'.  This indicates the desire for the command to be run in a
9263      * subprocess, so we satisfy that desire.
9264      */
9265     ap = argv[argc-1];
9266     if (0 == strcmp("&", ap))
9267        exit(background_process(aTHX_ --argc, argv));
9268     if (*ap && '&' == ap[strlen(ap)-1])
9269         {
9270         ap[strlen(ap)-1] = '\0';
9271        exit(background_process(aTHX_ argc, argv));
9272         }
9273     /*
9274      * Now we handle the general redirection cases that involve '>', '>>',
9275      * '<', and pipes '|'.
9276      */
9277     for (j = 0; j < argc; ++j)
9278         {
9279         if (0 == strcmp("<", argv[j]))
9280             {
9281             if (j+1 >= argc)
9282                 {
9283                 fprintf(stderr,"No input file after < on command line");
9284                 exit(LIB$_WRONUMARG);
9285                 }
9286             in = argv[++j];
9287             continue;
9288             }
9289         if ('<' == *(ap = argv[j]))
9290             {
9291             in = 1 + ap;
9292             continue;
9293             }
9294         if (0 == strcmp(">", ap))
9295             {
9296             if (j+1 >= argc)
9297                 {
9298                 fprintf(stderr,"No output file after > on command line");
9299                 exit(LIB$_WRONUMARG);
9300                 }
9301             out = argv[++j];
9302             continue;
9303             }
9304         if ('>' == *ap)
9305             {
9306             if ('>' == ap[1])
9307                 {
9308                 outmode = "a";
9309                 if ('\0' == ap[2])
9310                     out = argv[++j];
9311                 else
9312                     out = 2 + ap;
9313                 }
9314             else
9315                 out = 1 + ap;
9316             if (j >= argc)
9317                 {
9318                 fprintf(stderr,"No output file after > or >> on command line");
9319                 exit(LIB$_WRONUMARG);
9320                 }
9321             continue;
9322             }
9323         if (('2' == *ap) && ('>' == ap[1]))
9324             {
9325             if ('>' == ap[2])
9326                 {
9327                 errmode = "a";
9328                 if ('\0' == ap[3])
9329                     err = argv[++j];
9330                 else
9331                     err = 3 + ap;
9332                 }
9333             else
9334                 if ('\0' == ap[2])
9335                     err = argv[++j];
9336                 else
9337                     err = 2 + ap;
9338             if (j >= argc)
9339                 {
9340                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9341                 exit(LIB$_WRONUMARG);
9342                 }
9343             continue;
9344             }
9345         if (0 == strcmp("|", argv[j]))
9346             {
9347             if (j+1 >= argc)
9348                 {
9349                 fprintf(stderr,"No command into which to pipe on command line");
9350                 exit(LIB$_WRONUMARG);
9351                 }
9352             cmargc = argc-(j+1);
9353             cmargv = &argv[j+1];
9354             argc = j;
9355             continue;
9356             }
9357         if ('|' == *(ap = argv[j]))
9358             {
9359             ++argv[j];
9360             cmargc = argc-j;
9361             cmargv = &argv[j];
9362             argc = j;
9363             continue;
9364             }
9365         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9366         }
9367     /*
9368      * Allocate and fill in the new argument vector, Some Unix's terminate
9369      * the list with an extra null pointer.
9370      */
9371     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9372     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9373     *av = argv;
9374     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9375         argv[j] = list_head->value;
9376     *ac = item_count;
9377     if (cmargv != NULL)
9378         {
9379         if (out != NULL)
9380             {
9381             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9382             exit(LIB$_INVARGORD);
9383             }
9384         pipe_and_fork(aTHX_ cmargv);
9385         }
9386
9387     /* Check for input from a pipe (mailbox) */
9388
9389     if (in == NULL && 1 == isapipe(0))
9390         {
9391         char mbxname[L_tmpnam];
9392         long int bufsize;
9393         long int dvi_item = DVI$_DEVBUFSIZ;
9394         $DESCRIPTOR(mbxnam, "");
9395         $DESCRIPTOR(mbxdevnam, "");
9396
9397         /* Input from a pipe, reopen it in binary mode to disable       */
9398         /* carriage control processing.                                 */
9399
9400         fgetname(stdin, mbxname, 1);
9401         mbxnam.dsc$a_pointer = mbxname;
9402         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9403         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9404         mbxdevnam.dsc$a_pointer = mbxname;
9405         mbxdevnam.dsc$w_length = sizeof(mbxname);
9406         dvi_item = DVI$_DEVNAM;
9407         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9408         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9409         set_errno(0);
9410         set_vaxc_errno(1);
9411         freopen(mbxname, "rb", stdin);
9412         if (errno != 0)
9413             {
9414             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9415             exit(vaxc$errno);
9416             }
9417         }
9418     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9419         {
9420         fprintf(stderr,"Can't open input file %s as stdin",in);
9421         exit(vaxc$errno);
9422         }
9423     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9424         {
9425         fprintf(stderr,"Can't open output file %s as stdout",out);
9426         exit(vaxc$errno);
9427         }
9428         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9429
9430     if (err != NULL) {
9431         if (strcmp(err,"&1") == 0) {
9432             dup2(fileno(stdout), fileno(stderr));
9433             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9434         } else {
9435         FILE *tmperr;
9436         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9437             {
9438             fprintf(stderr,"Can't open error file %s as stderr",err);
9439             exit(vaxc$errno);
9440             }
9441             fclose(tmperr);
9442            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9443                 {
9444                 exit(vaxc$errno);
9445                 }
9446             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9447         }
9448         }
9449 #ifdef ARGPROC_DEBUG
9450     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9451     for (j = 0; j < *ac;  ++j)
9452         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9453 #endif
9454    /* Clear errors we may have hit expanding wildcards, so they don't
9455       show up in Perl's $! later */
9456    set_errno(0); set_vaxc_errno(1);
9457 }  /* end of getredirection() */
9458 /*}}}*/
9459
9460 static void add_item(struct list_item **head,
9461                      struct list_item **tail,
9462                      char *value,
9463                      int *count)
9464 {
9465     if (*head == 0)
9466         {
9467         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9468         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9469         *tail = *head;
9470         }
9471     else {
9472         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9473         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9474         *tail = (*tail)->next;
9475         }
9476     (*tail)->value = value;
9477     ++(*count);
9478 }
9479
9480 static void mp_expand_wild_cards(pTHX_ char *item,
9481                               struct list_item **head,
9482                               struct list_item **tail,
9483                               int *count)
9484 {
9485 int expcount = 0;
9486 unsigned long int context = 0;
9487 int isunix = 0;
9488 int item_len = 0;
9489 char *had_version;
9490 char *had_device;
9491 int had_directory;
9492 char *devdir,*cp;
9493 char *vmsspec;
9494 $DESCRIPTOR(filespec, "");
9495 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9496 $DESCRIPTOR(resultspec, "");
9497 unsigned long int lff_flags = 0;
9498 int sts;
9499 int rms_sts;
9500
9501 #ifdef VMS_LONGNAME_SUPPORT
9502     lff_flags = LIB$M_FIL_LONG_NAMES;
9503 #endif
9504
9505     for (cp = item; *cp; cp++) {
9506         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9507         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9508     }
9509     if (!*cp || isspace(*cp))
9510         {
9511         add_item(head, tail, item, count);
9512         return;
9513         }
9514     else
9515         {
9516      /* "double quoted" wild card expressions pass as is */
9517      /* From DCL that means using e.g.:                  */
9518      /* perl program """perl.*"""                        */
9519      item_len = strlen(item);
9520      if ( '"' == *item && '"' == item[item_len-1] )
9521        {
9522        item++;
9523        item[item_len-2] = '\0';
9524        add_item(head, tail, item, count);
9525        return;
9526        }
9527      }
9528     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9529     resultspec.dsc$b_class = DSC$K_CLASS_D;
9530     resultspec.dsc$a_pointer = NULL;
9531     vmsspec = PerlMem_malloc(VMS_MAXRSS);
9532     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9533     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9534       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9535     if (!isunix || !filespec.dsc$a_pointer)
9536       filespec.dsc$a_pointer = item;
9537     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9538     /*
9539      * Only return version specs, if the caller specified a version
9540      */
9541     had_version = strchr(item, ';');
9542     /*
9543      * Only return device and directory specs, if the caller specifed either.
9544      */
9545     had_device = strchr(item, ':');
9546     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9547
9548     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9549                                  (&filespec, &resultspec, &context,
9550                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9551         {
9552         char *string;
9553         char *c;
9554
9555         string = PerlMem_malloc(resultspec.dsc$w_length+1);
9556         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9557         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
9558         string[resultspec.dsc$w_length] = '\0';
9559         if (NULL == had_version)
9560             *(strrchr(string, ';')) = '\0';
9561         if ((!had_directory) && (had_device == NULL))
9562             {
9563             if (NULL == (devdir = strrchr(string, ']')))
9564                 devdir = strrchr(string, '>');
9565             strcpy(string, devdir + 1);
9566             }
9567         /*
9568          * Be consistent with what the C RTL has already done to the rest of
9569          * the argv items and lowercase all of these names.
9570          */
9571         if (!decc_efs_case_preserve) {
9572             for (c = string; *c; ++c)
9573             if (isupper(*c))
9574                 *c = tolower(*c);
9575         }
9576         if (isunix) trim_unixpath(string,item,1);
9577         add_item(head, tail, string, count);
9578         ++expcount;
9579     }
9580     PerlMem_free(vmsspec);
9581     if (sts != RMS$_NMF)
9582         {
9583         set_vaxc_errno(sts);
9584         switch (sts)
9585             {
9586             case RMS$_FNF: case RMS$_DNF:
9587                 set_errno(ENOENT); break;
9588             case RMS$_DIR:
9589                 set_errno(ENOTDIR); break;
9590             case RMS$_DEV:
9591                 set_errno(ENODEV); break;
9592             case RMS$_FNM: case RMS$_SYN:
9593                 set_errno(EINVAL); break;
9594             case RMS$_PRV:
9595                 set_errno(EACCES); break;
9596             default:
9597                 _ckvmssts_noperl(sts);
9598             }
9599         }
9600     if (expcount == 0)
9601         add_item(head, tail, item, count);
9602     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9603     _ckvmssts_noperl(lib$find_file_end(&context));
9604 }
9605
9606 static int child_st[2];/* Event Flag set when child process completes   */
9607
9608 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9609
9610 static unsigned long int exit_handler(int *status)
9611 {
9612 short iosb[4];
9613
9614     if (0 == child_st[0])
9615         {
9616 #ifdef ARGPROC_DEBUG
9617         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9618 #endif
9619         fflush(stdout);     /* Have to flush pipe for binary data to    */
9620                             /* terminate properly -- <tp@mccall.com>    */
9621         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9622         sys$dassgn(child_chan);
9623         fclose(stdout);
9624         sys$synch(0, child_st);
9625         }
9626     return(1);
9627 }
9628
9629 static void sig_child(int chan)
9630 {
9631 #ifdef ARGPROC_DEBUG
9632     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9633 #endif
9634     if (child_st[0] == 0)
9635         child_st[0] = 1;
9636 }
9637
9638 static struct exit_control_block exit_block =
9639     {
9640     0,
9641     exit_handler,
9642     1,
9643     &exit_block.exit_status,
9644     0
9645     };
9646
9647 static void
9648 pipe_and_fork(pTHX_ char **cmargv)
9649 {
9650     PerlIO *fp;
9651     struct dsc$descriptor_s *vmscmd;
9652     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9653     int sts, j, l, ismcr, quote, tquote = 0;
9654
9655     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9656     vms_execfree(vmscmd);
9657
9658     j = l = 0;
9659     p = subcmd;
9660     q = cmargv[0];
9661     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9662               && toupper(*(q+2)) == 'R' && !*(q+3);
9663
9664     while (q && l < MAX_DCL_LINE_LENGTH) {
9665         if (!*q) {
9666             if (j > 0 && quote) {
9667                 *p++ = '"';
9668                 l++;
9669             }
9670             q = cmargv[++j];
9671             if (q) {
9672                 if (ismcr && j > 1) quote = 1;
9673                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9674                 *p++ = ' ';
9675                 l++;
9676                 if (quote || tquote) {
9677                     *p++ = '"';
9678                     l++;
9679                 }
9680             }
9681         } else {
9682             if ((quote||tquote) && *q == '"') {
9683                 *p++ = '"';
9684                 l++;
9685             }
9686             *p++ = *q++;
9687             l++;
9688         }
9689     }
9690     *p = '\0';
9691
9692     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9693     if (fp == NULL) {
9694         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9695     }
9696 }
9697
9698 static int background_process(pTHX_ int argc, char **argv)
9699 {
9700 char command[MAX_DCL_SYMBOL + 1] = "$";
9701 $DESCRIPTOR(value, "");
9702 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9703 static $DESCRIPTOR(null, "NLA0:");
9704 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9705 char pidstring[80];
9706 $DESCRIPTOR(pidstr, "");
9707 int pid;
9708 unsigned long int flags = 17, one = 1, retsts;
9709 int len;
9710
9711     strcat(command, argv[0]);
9712     len = strlen(command);
9713     while (--argc && (len < MAX_DCL_SYMBOL))
9714         {
9715         strcat(command, " \"");
9716         strcat(command, *(++argv));
9717         strcat(command, "\"");
9718         len = strlen(command);
9719         }
9720     value.dsc$a_pointer = command;
9721     value.dsc$w_length = strlen(value.dsc$a_pointer);
9722     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9723     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9724     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9725         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9726     }
9727     else {
9728         _ckvmssts_noperl(retsts);
9729     }
9730 #ifdef ARGPROC_DEBUG
9731     PerlIO_printf(Perl_debug_log, "%s\n", command);
9732 #endif
9733     sprintf(pidstring, "%08X", pid);
9734     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9735     pidstr.dsc$a_pointer = pidstring;
9736     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9737     lib$set_symbol(&pidsymbol, &pidstr);
9738     return(SS$_NORMAL);
9739 }
9740 /*}}}*/
9741 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9742
9743
9744 /* OS-specific initialization at image activation (not thread startup) */
9745 /* Older VAXC header files lack these constants */
9746 #ifndef JPI$_RIGHTS_SIZE
9747 #  define JPI$_RIGHTS_SIZE 817
9748 #endif
9749 #ifndef KGB$M_SUBSYSTEM
9750 #  define KGB$M_SUBSYSTEM 0x8
9751 #endif
9752
9753 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9754
9755 /*{{{void vms_image_init(int *, char ***)*/
9756 void
9757 vms_image_init(int *argcp, char ***argvp)
9758 {
9759   int status;
9760   char eqv[LNM$C_NAMLENGTH+1] = "";
9761   unsigned int len, tabct = 8, tabidx = 0;
9762   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9763   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9764   unsigned short int dummy, rlen;
9765   struct dsc$descriptor_s **tabvec;
9766 #if defined(PERL_IMPLICIT_CONTEXT)
9767   pTHX = NULL;
9768 #endif
9769   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9770                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9771                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9772                                  {          0,                0,    0,      0} };
9773
9774 #ifdef KILL_BY_SIGPRC
9775     Perl_csighandler_init();
9776 #endif
9777
9778     /* This was moved from the pre-image init handler because on threaded */
9779     /* Perl it was always returning 0 for the default value. */
9780     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9781     if (status > 0) {
9782         int s;
9783         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9784         if (s > 0) {
9785             int initial;
9786             initial = decc$feature_get_value(s, 4);
9787             if (initial > 0) {
9788                 /* initial is: 0 if nothing has set the feature */
9789                 /*            -1 if initialized to default */
9790                 /*             1 if set by logical name */
9791                 /*             2 if set by decc$feature_set_value */
9792                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9793
9794                 /* If the value is not valid, force the feature off */
9795                 if (decc_disable_posix_root < 0) {
9796                     decc$feature_set_value(s, 1, 1);
9797                     decc_disable_posix_root = 1;
9798                 }
9799             }
9800             else {
9801                 /* Nothing has asked for it explicitly, so use our own default. */
9802                 decc_disable_posix_root = 1;
9803                 decc$feature_set_value(s, 1, 1);
9804             }
9805         }
9806     }
9807
9808
9809   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9810   _ckvmssts_noperl(iosb[0]);
9811   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9812     if (iprv[i]) {           /* Running image installed with privs? */
9813       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9814       will_taint = TRUE;
9815       break;
9816     }
9817   }
9818   /* Rights identifiers might trigger tainting as well. */
9819   if (!will_taint && (rlen || rsz)) {
9820     while (rlen < rsz) {
9821       /* We didn't get all the identifiers on the first pass.  Allocate a
9822        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9823        * were needed to hold all identifiers at time of last call; we'll
9824        * allocate that many unsigned long ints), and go back and get 'em.
9825        * If it gave us less than it wanted to despite ample buffer space,
9826        * something's broken.  Is your system missing a system identifier?
9827        */
9828       if (rsz <= jpilist[1].buflen) {
9829          /* Perl_croak accvios when used this early in startup. */
9830          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9831                          rsz, (unsigned long) jpilist[1].buflen,
9832                          "Check your rights database for corruption.\n");
9833          exit(SS$_ABORT);
9834       }
9835       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9836       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9837       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9838       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9839       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9840       _ckvmssts_noperl(iosb[0]);
9841     }
9842     mask = jpilist[1].bufadr;
9843     /* Check attribute flags for each identifier (2nd longword); protected
9844      * subsystem identifiers trigger tainting.
9845      */
9846     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9847       if (mask[i] & KGB$M_SUBSYSTEM) {
9848         will_taint = TRUE;
9849         break;
9850       }
9851     }
9852     if (mask != rlst) PerlMem_free(mask);
9853   }
9854
9855   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9856    * logical, some versions of the CRTL will add a phanthom /000000/
9857    * directory.  This needs to be removed.
9858    */
9859   if (decc_filename_unix_report) {
9860   char * zeros;
9861   int ulen;
9862     ulen = strlen(argvp[0][0]);
9863     if (ulen > 7) {
9864       zeros = strstr(argvp[0][0], "/000000/");
9865       if (zeros != NULL) {
9866         int mlen;
9867         mlen = ulen - (zeros - argvp[0][0]) - 7;
9868         memmove(zeros, &zeros[7], mlen);
9869         ulen = ulen - 7;
9870         argvp[0][0][ulen] = '\0';
9871       }
9872     }
9873     /* It also may have a trailing dot that needs to be removed otherwise
9874      * it will be converted to VMS mode incorrectly.
9875      */
9876     ulen--;
9877     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9878       argvp[0][0][ulen] = '\0';
9879   }
9880
9881   /* We need to use this hack to tell Perl it should run with tainting,
9882    * since its tainting flag may be part of the PL_curinterp struct, which
9883    * hasn't been allocated when vms_image_init() is called.
9884    */
9885   if (will_taint) {
9886     char **newargv, **oldargv;
9887     oldargv = *argvp;
9888     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9889     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9890     newargv[0] = oldargv[0];
9891     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9892     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9893     strcpy(newargv[1], "-T");
9894     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9895     (*argcp)++;
9896     newargv[*argcp] = NULL;
9897     /* We orphan the old argv, since we don't know where it's come from,
9898      * so we don't know how to free it.
9899      */
9900     *argvp = newargv;
9901   }
9902   else {  /* Did user explicitly request tainting? */
9903     int i;
9904     char *cp, **av = *argvp;
9905     for (i = 1; i < *argcp; i++) {
9906       if (*av[i] != '-') break;
9907       for (cp = av[i]+1; *cp; cp++) {
9908         if (*cp == 'T') { will_taint = 1; break; }
9909         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9910                   strchr("DFIiMmx",*cp)) break;
9911       }
9912       if (will_taint) break;
9913     }
9914   }
9915
9916   for (tabidx = 0;
9917        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9918        tabidx++) {
9919     if (!tabidx) {
9920       tabvec = (struct dsc$descriptor_s **)
9921             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9922       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9923     }
9924     else if (tabidx >= tabct) {
9925       tabct += 8;
9926       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9927       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9928     }
9929     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9930     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9931     tabvec[tabidx]->dsc$w_length  = 0;
9932     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9933     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9934     tabvec[tabidx]->dsc$a_pointer = NULL;
9935     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9936   }
9937   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9938
9939   getredirection(argcp,argvp);
9940 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9941   {
9942 # include <reentrancy.h>
9943   decc$set_reentrancy(C$C_MULTITHREAD);
9944   }
9945 #endif
9946   return;
9947 }
9948 /*}}}*/
9949
9950
9951 /* trim_unixpath()
9952  * Trim Unix-style prefix off filespec, so it looks like what a shell
9953  * glob expansion would return (i.e. from specified prefix on, not
9954  * full path).  Note that returned filespec is Unix-style, regardless
9955  * of whether input filespec was VMS-style or Unix-style.
9956  *
9957  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9958  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9959  * vector of options; at present, only bit 0 is used, and if set tells
9960  * trim unixpath to try the current default directory as a prefix when
9961  * presented with a possibly ambiguous ... wildcard.
9962  *
9963  * Returns !=0 on success, with trimmed filespec replacing contents of
9964  * fspec, and 0 on failure, with contents of fpsec unchanged.
9965  */
9966 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9967 int
9968 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9969 {
9970   char *unixified, *unixwild,
9971        *template, *base, *end, *cp1, *cp2;
9972   register int tmplen, reslen = 0, dirs = 0;
9973
9974   if (!wildspec || !fspec) return 0;
9975
9976   unixwild = PerlMem_malloc(VMS_MAXRSS);
9977   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9978   template = unixwild;
9979   if (strpbrk(wildspec,"]>:") != NULL) {
9980     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9981         PerlMem_free(unixwild);
9982         return 0;
9983     }
9984   }
9985   else {
9986     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9987     unixwild[VMS_MAXRSS-1] = 0;
9988   }
9989   unixified = PerlMem_malloc(VMS_MAXRSS);
9990   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9991   if (strpbrk(fspec,"]>:") != NULL) {
9992     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9993         PerlMem_free(unixwild);
9994         PerlMem_free(unixified);
9995         return 0;
9996     }
9997     else base = unixified;
9998     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9999      * check to see that final result fits into (isn't longer than) fspec */
10000     reslen = strlen(fspec);
10001   }
10002   else base = fspec;
10003
10004   /* No prefix or absolute path on wildcard, so nothing to remove */
10005   if (!*template || *template == '/') {
10006     PerlMem_free(unixwild);
10007     if (base == fspec) {
10008         PerlMem_free(unixified);
10009         return 1;
10010     }
10011     tmplen = strlen(unixified);
10012     if (tmplen > reslen) {
10013         PerlMem_free(unixified);
10014         return 0;  /* not enough space */
10015     }
10016     /* Copy unixified resultant, including trailing NUL */
10017     memmove(fspec,unixified,tmplen+1);
10018     PerlMem_free(unixified);
10019     return 1;
10020   }
10021
10022   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
10023   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
10024     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
10025     for (cp1 = end ;cp1 >= base; cp1--)
10026       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
10027         { cp1++; break; }
10028     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
10029     PerlMem_free(unixified);
10030     PerlMem_free(unixwild);
10031     return 1;
10032   }
10033   else {
10034     char *tpl, *lcres;
10035     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
10036     int ells = 1, totells, segdirs, match;
10037     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
10038                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10039
10040     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
10041     totells = ells;
10042     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
10043     tpl = PerlMem_malloc(VMS_MAXRSS);
10044     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10045     if (ellipsis == template && opts & 1) {
10046       /* Template begins with an ellipsis.  Since we can't tell how many
10047        * directory names at the front of the resultant to keep for an
10048        * arbitrary starting point, we arbitrarily choose the current
10049        * default directory as a starting point.  If it's there as a prefix,
10050        * clip it off.  If not, fall through and act as if the leading
10051        * ellipsis weren't there (i.e. return shortest possible path that
10052        * could match template).
10053        */
10054       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
10055           PerlMem_free(tpl);
10056           PerlMem_free(unixified);
10057           PerlMem_free(unixwild);
10058           return 0;
10059       }
10060       if (!decc_efs_case_preserve) {
10061         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10062           if (_tolower(*cp1) != _tolower(*cp2)) break;
10063       }
10064       segdirs = dirs - totells;  /* Min # of dirs we must have left */
10065       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
10066       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
10067         memmove(fspec,cp2+1,end - cp2);
10068         PerlMem_free(tpl);
10069         PerlMem_free(unixified);
10070         PerlMem_free(unixwild);
10071         return 1;
10072       }
10073     }
10074     /* First off, back up over constant elements at end of path */
10075     if (dirs) {
10076       for (front = end ; front >= base; front--)
10077          if (*front == '/' && !dirs--) { front++; break; }
10078     }
10079     lcres = PerlMem_malloc(VMS_MAXRSS);
10080     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10081     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
10082          cp1++,cp2++) {
10083             if (!decc_efs_case_preserve) {
10084                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
10085             }
10086             else {
10087                 *cp2 = *cp1;
10088             }
10089     }
10090     if (cp1 != '\0') {
10091         PerlMem_free(tpl);
10092         PerlMem_free(unixified);
10093         PerlMem_free(unixwild);
10094         PerlMem_free(lcres);
10095         return 0;  /* Path too long. */
10096     }
10097     lcend = cp2;
10098     *cp2 = '\0';  /* Pick up with memcpy later */
10099     lcfront = lcres + (front - base);
10100     /* Now skip over each ellipsis and try to match the path in front of it. */
10101     while (ells--) {
10102       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
10103         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
10104             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
10105       if (cp1 < template) break; /* template started with an ellipsis */
10106       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
10107         ellipsis = cp1; continue;
10108       }
10109       wilddsc.dsc$a_pointer = tpl;
10110       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
10111       nextell = cp1;
10112       for (segdirs = 0, cp2 = tpl;
10113            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
10114            cp1++, cp2++) {
10115          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
10116          else {
10117             if (!decc_efs_case_preserve) {
10118               *cp2 = _tolower(*cp1);  /* else lowercase for match */
10119             }
10120             else {
10121               *cp2 = *cp1;  /* else preserve case for match */
10122             }
10123          }
10124          if (*cp2 == '/') segdirs++;
10125       }
10126       if (cp1 != ellipsis - 1) {
10127           PerlMem_free(tpl);
10128           PerlMem_free(unixified);
10129           PerlMem_free(unixwild);
10130           PerlMem_free(lcres);
10131           return 0; /* Path too long */
10132       }
10133       /* Back up at least as many dirs as in template before matching */
10134       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
10135         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
10136       for (match = 0; cp1 > lcres;) {
10137         resdsc.dsc$a_pointer = cp1;
10138         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
10139           match++;
10140           if (match == 1) lcfront = cp1;
10141         }
10142         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
10143       }
10144       if (!match) {
10145         PerlMem_free(tpl);
10146         PerlMem_free(unixified);
10147         PerlMem_free(unixwild);
10148         PerlMem_free(lcres);
10149         return 0;  /* Can't find prefix ??? */
10150       }
10151       if (match > 1 && opts & 1) {
10152         /* This ... wildcard could cover more than one set of dirs (i.e.
10153          * a set of similar dir names is repeated).  If the template
10154          * contains more than 1 ..., upstream elements could resolve the
10155          * ambiguity, but it's not worth a full backtracking setup here.
10156          * As a quick heuristic, clip off the current default directory
10157          * if it's present to find the trimmed spec, else use the
10158          * shortest string that this ... could cover.
10159          */
10160         char def[NAM$C_MAXRSS+1], *st;
10161
10162         if (getcwd(def, sizeof def,0) == NULL) {
10163             PerlMem_free(unixified);
10164             PerlMem_free(unixwild);
10165             PerlMem_free(lcres);
10166             PerlMem_free(tpl);
10167             return 0;
10168         }
10169         if (!decc_efs_case_preserve) {
10170           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10171             if (_tolower(*cp1) != _tolower(*cp2)) break;
10172         }
10173         segdirs = dirs - totells;  /* Min # of dirs we must have left */
10174         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10175         if (*cp1 == '\0' && *cp2 == '/') {
10176           memmove(fspec,cp2+1,end - cp2);
10177           PerlMem_free(tpl);
10178           PerlMem_free(unixified);
10179           PerlMem_free(unixwild);
10180           PerlMem_free(lcres);
10181           return 1;
10182         }
10183         /* Nope -- stick with lcfront from above and keep going. */
10184       }
10185     }
10186     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10187     PerlMem_free(tpl);
10188     PerlMem_free(unixified);
10189     PerlMem_free(unixwild);
10190     PerlMem_free(lcres);
10191     return 1;
10192     ellipsis = nextell;
10193   }
10194
10195 }  /* end of trim_unixpath() */
10196 /*}}}*/
10197
10198
10199 /*
10200  *  VMS readdir() routines.
10201  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10202  *
10203  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
10204  *  Minor modifications to original routines.
10205  */
10206
10207 /* readdir may have been redefined by reentr.h, so make sure we get
10208  * the local version for what we do here.
10209  */
10210 #ifdef readdir
10211 # undef readdir
10212 #endif
10213 #if !defined(PERL_IMPLICIT_CONTEXT)
10214 # define readdir Perl_readdir
10215 #else
10216 # define readdir(a) Perl_readdir(aTHX_ a)
10217 #endif
10218
10219     /* Number of elements in vms_versions array */
10220 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
10221
10222 /*
10223  *  Open a directory, return a handle for later use.
10224  */
10225 /*{{{ DIR *opendir(char*name) */
10226 DIR *
10227 Perl_opendir(pTHX_ const char *name)
10228 {
10229     DIR *dd;
10230     char *dir;
10231     Stat_t sb;
10232
10233     Newx(dir, VMS_MAXRSS, char);
10234     if (int_tovmspath(name, dir, NULL) == NULL) {
10235       Safefree(dir);
10236       return NULL;
10237     }
10238     /* Check access before stat; otherwise stat does not
10239      * accurately report whether it's a directory.
10240      */
10241     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10242       /* cando_by_name has already set errno */
10243       Safefree(dir);
10244       return NULL;
10245     }
10246     if (flex_stat(dir,&sb) == -1) return NULL;
10247     if (!S_ISDIR(sb.st_mode)) {
10248       Safefree(dir);
10249       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
10250       return NULL;
10251     }
10252     /* Get memory for the handle, and the pattern. */
10253     Newx(dd,1,DIR);
10254     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10255
10256     /* Fill in the fields; mainly playing with the descriptor. */
10257     sprintf(dd->pattern, "%s*.*",dir);
10258     Safefree(dir);
10259     dd->context = 0;
10260     dd->count = 0;
10261     dd->flags = 0;
10262     /* By saying we always want the result of readdir() in unix format, we
10263      * are really saying we want all the escapes removed.  Otherwise the caller,
10264      * having no way to know whether it's already in VMS format, might send it
10265      * through tovmsspec again, thus double escaping.
10266      */
10267     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
10268     dd->pat.dsc$a_pointer = dd->pattern;
10269     dd->pat.dsc$w_length = strlen(dd->pattern);
10270     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10271     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10272 #if defined(USE_ITHREADS)
10273     Newx(dd->mutex,1,perl_mutex);
10274     MUTEX_INIT( (perl_mutex *) dd->mutex );
10275 #else
10276     dd->mutex = NULL;
10277 #endif
10278
10279     return dd;
10280 }  /* end of opendir() */
10281 /*}}}*/
10282
10283 /*
10284  *  Set the flag to indicate we want versions or not.
10285  */
10286 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10287 void
10288 vmsreaddirversions(DIR *dd, int flag)
10289 {
10290     if (flag)
10291         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10292     else
10293         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10294 }
10295 /*}}}*/
10296
10297 /*
10298  *  Free up an opened directory.
10299  */
10300 /*{{{ void closedir(DIR *dd)*/
10301 void
10302 Perl_closedir(DIR *dd)
10303 {
10304     int sts;
10305
10306     sts = lib$find_file_end(&dd->context);
10307     Safefree(dd->pattern);
10308 #if defined(USE_ITHREADS)
10309     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10310     Safefree(dd->mutex);
10311 #endif
10312     Safefree(dd);
10313 }
10314 /*}}}*/
10315
10316 /*
10317  *  Collect all the version numbers for the current file.
10318  */
10319 static void
10320 collectversions(pTHX_ DIR *dd)
10321 {
10322     struct dsc$descriptor_s     pat;
10323     struct dsc$descriptor_s     res;
10324     struct dirent *e;
10325     char *p, *text, *buff;
10326     int i;
10327     unsigned long context, tmpsts;
10328
10329     /* Convenient shorthand. */
10330     e = &dd->entry;
10331
10332     /* Add the version wildcard, ignoring the "*.*" put on before */
10333     i = strlen(dd->pattern);
10334     Newx(text,i + e->d_namlen + 3,char);
10335     strcpy(text, dd->pattern);
10336     sprintf(&text[i - 3], "%s;*", e->d_name);
10337
10338     /* Set up the pattern descriptor. */
10339     pat.dsc$a_pointer = text;
10340     pat.dsc$w_length = i + e->d_namlen - 1;
10341     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10342     pat.dsc$b_class = DSC$K_CLASS_S;
10343
10344     /* Set up result descriptor. */
10345     Newx(buff, VMS_MAXRSS, char);
10346     res.dsc$a_pointer = buff;
10347     res.dsc$w_length = VMS_MAXRSS - 1;
10348     res.dsc$b_dtype = DSC$K_DTYPE_T;
10349     res.dsc$b_class = DSC$K_CLASS_S;
10350
10351     /* Read files, collecting versions. */
10352     for (context = 0, e->vms_verscount = 0;
10353          e->vms_verscount < VERSIZE(e);
10354          e->vms_verscount++) {
10355         unsigned long rsts;
10356         unsigned long flags = 0;
10357
10358 #ifdef VMS_LONGNAME_SUPPORT
10359         flags = LIB$M_FIL_LONG_NAMES;
10360 #endif
10361         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10362         if (tmpsts == RMS$_NMF || context == 0) break;
10363         _ckvmssts(tmpsts);
10364         buff[VMS_MAXRSS - 1] = '\0';
10365         if ((p = strchr(buff, ';')))
10366             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10367         else
10368             e->vms_versions[e->vms_verscount] = -1;
10369     }
10370
10371     _ckvmssts(lib$find_file_end(&context));
10372     Safefree(text);
10373     Safefree(buff);
10374
10375 }  /* end of collectversions() */
10376
10377 /*
10378  *  Read the next entry from the directory.
10379  */
10380 /*{{{ struct dirent *readdir(DIR *dd)*/
10381 struct dirent *
10382 Perl_readdir(pTHX_ DIR *dd)
10383 {
10384     struct dsc$descriptor_s     res;
10385     char *p, *buff;
10386     unsigned long int tmpsts;
10387     unsigned long rsts;
10388     unsigned long flags = 0;
10389     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10390     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10391
10392     /* Set up result descriptor, and get next file. */
10393     Newx(buff, VMS_MAXRSS, char);
10394     res.dsc$a_pointer = buff;
10395     res.dsc$w_length = VMS_MAXRSS - 1;
10396     res.dsc$b_dtype = DSC$K_DTYPE_T;
10397     res.dsc$b_class = DSC$K_CLASS_S;
10398
10399 #ifdef VMS_LONGNAME_SUPPORT
10400     flags = LIB$M_FIL_LONG_NAMES;
10401 #endif
10402
10403     tmpsts = lib$find_file
10404         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10405     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
10406     if (!(tmpsts & 1)) {
10407       set_vaxc_errno(tmpsts);
10408       switch (tmpsts) {
10409         case RMS$_PRV:
10410           set_errno(EACCES); break;
10411         case RMS$_DEV:
10412           set_errno(ENODEV); break;
10413         case RMS$_DIR:
10414           set_errno(ENOTDIR); break;
10415         case RMS$_FNF: case RMS$_DNF:
10416           set_errno(ENOENT); break;
10417         default:
10418           set_errno(EVMSERR);
10419       }
10420       Safefree(buff);
10421       return NULL;
10422     }
10423     dd->count++;
10424     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10425     buff[res.dsc$w_length] = '\0';
10426     p = buff + res.dsc$w_length;
10427     while (--p >= buff) if (!isspace(*p)) break;
10428     *p = '\0';
10429     if (!decc_efs_case_preserve) {
10430       for (p = buff; *p; p++) *p = _tolower(*p);
10431     }
10432
10433     /* Skip any directory component and just copy the name. */
10434     sts = vms_split_path
10435        (buff,
10436         &v_spec,
10437         &v_len,
10438         &r_spec,
10439         &r_len,
10440         &d_spec,
10441         &d_len,
10442         &n_spec,
10443         &n_len,
10444         &e_spec,
10445         &e_len,
10446         &vs_spec,
10447         &vs_len);
10448
10449     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10450
10451         /* In Unix report mode, remove the ".dir;1" from the name */
10452         /* if it is a real directory. */
10453         if (decc_filename_unix_report || decc_efs_charset) {
10454             if ((e_len == 4) && (vs_len == 2) && (vs_spec[1] == '1')) {
10455                 if ((toupper(e_spec[1]) == 'D') &&
10456                     (toupper(e_spec[2]) == 'I') &&
10457                     (toupper(e_spec[3]) == 'R')) {
10458                     Stat_t statbuf;
10459                     int ret_sts;
10460
10461                     ret_sts = stat(buff, &statbuf.crtl_stat);
10462                     if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10463                         e_len = 0;
10464                         e_spec[0] = 0;
10465                     }
10466                 }
10467             }
10468         }
10469
10470         /* Drop NULL extensions on UNIX file specification */
10471         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10472             e_len = 0;
10473             e_spec[0] = '\0';
10474         }
10475     }
10476
10477     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
10478     dd->entry.d_name[n_len + e_len] = '\0';
10479     dd->entry.d_namlen = strlen(dd->entry.d_name);
10480
10481     /* Convert the filename to UNIX format if needed */
10482     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10483
10484         /* Translate the encoded characters. */
10485         /* Fixme: Unicode handling could result in embedded 0 characters */
10486         if (strchr(dd->entry.d_name, '^') != NULL) {
10487             char new_name[256];
10488             char * q;
10489             p = dd->entry.d_name;
10490             q = new_name;
10491             while (*p != 0) {
10492                 int inchars_read, outchars_added;
10493                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10494                 p += inchars_read;
10495                 q += outchars_added;
10496                 /* fix-me */
10497                 /* if outchars_added > 1, then this is a wide file specification */
10498                 /* Wide file specifications need to be passed in Perl */
10499                 /* counted strings apparently with a Unicode flag */
10500             }
10501             *q = 0;
10502             strcpy(dd->entry.d_name, new_name);
10503             dd->entry.d_namlen = strlen(dd->entry.d_name);
10504         }
10505     }
10506
10507     dd->entry.vms_verscount = 0;
10508     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10509     Safefree(buff);
10510     return &dd->entry;
10511
10512 }  /* end of readdir() */
10513 /*}}}*/
10514
10515 /*
10516  *  Read the next entry from the directory -- thread-safe version.
10517  */
10518 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10519 int
10520 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10521 {
10522     int retval;
10523
10524     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10525
10526     entry = readdir(dd);
10527     *result = entry;
10528     retval = ( *result == NULL ? errno : 0 );
10529
10530     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10531
10532     return retval;
10533
10534 }  /* end of readdir_r() */
10535 /*}}}*/
10536
10537 /*
10538  *  Return something that can be used in a seekdir later.
10539  */
10540 /*{{{ long telldir(DIR *dd)*/
10541 long
10542 Perl_telldir(DIR *dd)
10543 {
10544     return dd->count;
10545 }
10546 /*}}}*/
10547
10548 /*
10549  *  Return to a spot where we used to be.  Brute force.
10550  */
10551 /*{{{ void seekdir(DIR *dd,long count)*/
10552 void
10553 Perl_seekdir(pTHX_ DIR *dd, long count)
10554 {
10555     int old_flags;
10556
10557     /* If we haven't done anything yet... */
10558     if (dd->count == 0)
10559         return;
10560
10561     /* Remember some state, and clear it. */
10562     old_flags = dd->flags;
10563     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10564     _ckvmssts(lib$find_file_end(&dd->context));
10565     dd->context = 0;
10566
10567     /* The increment is in readdir(). */
10568     for (dd->count = 0; dd->count < count; )
10569         readdir(dd);
10570
10571     dd->flags = old_flags;
10572
10573 }  /* end of seekdir() */
10574 /*}}}*/
10575
10576 /* VMS subprocess management
10577  *
10578  * my_vfork() - just a vfork(), after setting a flag to record that
10579  * the current script is trying a Unix-style fork/exec.
10580  *
10581  * vms_do_aexec() and vms_do_exec() are called in response to the
10582  * perl 'exec' function.  If this follows a vfork call, then they
10583  * call out the regular perl routines in doio.c which do an
10584  * execvp (for those who really want to try this under VMS).
10585  * Otherwise, they do exactly what the perl docs say exec should
10586  * do - terminate the current script and invoke a new command
10587  * (See below for notes on command syntax.)
10588  *
10589  * do_aspawn() and do_spawn() implement the VMS side of the perl
10590  * 'system' function.
10591  *
10592  * Note on command arguments to perl 'exec' and 'system': When handled
10593  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10594  * are concatenated to form a DCL command string.  If the first non-numeric
10595  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10596  * the command string is handed off to DCL directly.  Otherwise,
10597  * the first token of the command is taken as the filespec of an image
10598  * to run.  The filespec is expanded using a default type of '.EXE' and
10599  * the process defaults for device, directory, etc., and if found, the resultant
10600  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10601  * the command string as parameters.  This is perhaps a bit complicated,
10602  * but I hope it will form a happy medium between what VMS folks expect
10603  * from lib$spawn and what Unix folks expect from exec.
10604  */
10605
10606 static int vfork_called;
10607
10608 /*{{{int my_vfork()*/
10609 int
10610 my_vfork()
10611 {
10612   vfork_called++;
10613   return vfork();
10614 }
10615 /*}}}*/
10616
10617
10618 static void
10619 vms_execfree(struct dsc$descriptor_s *vmscmd)
10620 {
10621   if (vmscmd) {
10622       if (vmscmd->dsc$a_pointer) {
10623           PerlMem_free(vmscmd->dsc$a_pointer);
10624       }
10625       PerlMem_free(vmscmd);
10626   }
10627 }
10628
10629 static char *
10630 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10631 {
10632   char *junk, *tmps = NULL;
10633   register size_t cmdlen = 0;
10634   size_t rlen;
10635   register SV **idx;
10636   STRLEN n_a;
10637
10638   idx = mark;
10639   if (really) {
10640     tmps = SvPV(really,rlen);
10641     if (*tmps) {
10642       cmdlen += rlen + 1;
10643       idx++;
10644     }
10645   }
10646
10647   for (idx++; idx <= sp; idx++) {
10648     if (*idx) {
10649       junk = SvPVx(*idx,rlen);
10650       cmdlen += rlen ? rlen + 1 : 0;
10651     }
10652   }
10653   Newx(PL_Cmd, cmdlen+1, char);
10654
10655   if (tmps && *tmps) {
10656     strcpy(PL_Cmd,tmps);
10657     mark++;
10658   }
10659   else *PL_Cmd = '\0';
10660   while (++mark <= sp) {
10661     if (*mark) {
10662       char *s = SvPVx(*mark,n_a);
10663       if (!*s) continue;
10664       if (*PL_Cmd) strcat(PL_Cmd," ");
10665       strcat(PL_Cmd,s);
10666     }
10667   }
10668   return PL_Cmd;
10669
10670 }  /* end of setup_argstr() */
10671
10672
10673 static unsigned long int
10674 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10675                    struct dsc$descriptor_s **pvmscmd)
10676 {
10677   char * vmsspec;
10678   char * resspec;
10679   char image_name[NAM$C_MAXRSS+1];
10680   char image_argv[NAM$C_MAXRSS+1];
10681   $DESCRIPTOR(defdsc,".EXE");
10682   $DESCRIPTOR(defdsc2,".");
10683   struct dsc$descriptor_s resdsc;
10684   struct dsc$descriptor_s *vmscmd;
10685   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10686   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10687   register char *s, *rest, *cp, *wordbreak;
10688   char * cmd;
10689   int cmdlen;
10690   register int isdcl;
10691
10692   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10693   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10694
10695   /* vmsspec is a DCL command buffer, not just a filename */
10696   vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10697   if (vmsspec == NULL)
10698       _ckvmssts_noperl(SS$_INSFMEM);
10699
10700   resspec = PerlMem_malloc(VMS_MAXRSS);
10701   if (resspec == NULL)
10702       _ckvmssts_noperl(SS$_INSFMEM);
10703
10704   /* Make a copy for modification */
10705   cmdlen = strlen(incmd);
10706   cmd = PerlMem_malloc(cmdlen+1);
10707   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10708   strncpy(cmd, incmd, cmdlen);
10709   cmd[cmdlen] = 0;
10710   image_name[0] = 0;
10711   image_argv[0] = 0;
10712
10713   resdsc.dsc$a_pointer = resspec;
10714   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10715   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10716   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10717
10718   vmscmd->dsc$a_pointer = NULL;
10719   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10720   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10721   vmscmd->dsc$w_length = 0;
10722   if (pvmscmd) *pvmscmd = vmscmd;
10723
10724   if (suggest_quote) *suggest_quote = 0;
10725
10726   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10727     PerlMem_free(cmd);
10728     PerlMem_free(vmsspec);
10729     PerlMem_free(resspec);
10730     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10731   }
10732
10733   s = cmd;
10734
10735   while (*s && isspace(*s)) s++;
10736
10737   if (*s == '@' || *s == '$') {
10738     vmsspec[0] = *s;  rest = s + 1;
10739     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10740   }
10741   else { cp = vmsspec; rest = s; }
10742   if (*rest == '.' || *rest == '/') {
10743     char *cp2;
10744     for (cp2 = resspec;
10745          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10746          rest++, cp2++) *cp2 = *rest;
10747     *cp2 = '\0';
10748     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10749       s = vmsspec;
10750
10751       /* When a UNIX spec with no file type is translated to VMS, */
10752       /* A trailing '.' is appended under ODS-5 rules.            */
10753       /* Here we do not want that trailing "." as it prevents     */
10754       /* Looking for a implied ".exe" type. */
10755       if (decc_efs_charset) {
10756           int i;
10757           i = strlen(vmsspec);
10758           if (vmsspec[i-1] == '.') {
10759               vmsspec[i-1] = '\0';
10760           }
10761       }
10762
10763       if (*rest) {
10764         for (cp2 = vmsspec + strlen(vmsspec);
10765              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10766              rest++, cp2++) *cp2 = *rest;
10767         *cp2 = '\0';
10768       }
10769     }
10770   }
10771   /* Intuit whether verb (first word of cmd) is a DCL command:
10772    *   - if first nonspace char is '@', it's a DCL indirection
10773    * otherwise
10774    *   - if verb contains a filespec separator, it's not a DCL command
10775    *   - if it doesn't, caller tells us whether to default to a DCL
10776    *     command, or to a local image unless told it's DCL (by leading '$')
10777    */
10778   if (*s == '@') {
10779       isdcl = 1;
10780       if (suggest_quote) *suggest_quote = 1;
10781   } else {
10782     register char *filespec = strpbrk(s,":<[.;");
10783     rest = wordbreak = strpbrk(s," \"\t/");
10784     if (!wordbreak) wordbreak = s + strlen(s);
10785     if (*s == '$') check_img = 0;
10786     if (filespec && (filespec < wordbreak)) isdcl = 0;
10787     else isdcl = !check_img;
10788   }
10789
10790   if (!isdcl) {
10791     int rsts;
10792     imgdsc.dsc$a_pointer = s;
10793     imgdsc.dsc$w_length = wordbreak - s;
10794     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10795     if (!(retsts&1)) {
10796         _ckvmssts_noperl(lib$find_file_end(&cxt));
10797         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10798       if (!(retsts & 1) && *s == '$') {
10799         _ckvmssts_noperl(lib$find_file_end(&cxt));
10800         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10801         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10802         if (!(retsts&1)) {
10803           _ckvmssts_noperl(lib$find_file_end(&cxt));
10804           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10805         }
10806       }
10807     }
10808     _ckvmssts_noperl(lib$find_file_end(&cxt));
10809
10810     if (retsts & 1) {
10811       FILE *fp;
10812       s = resspec;
10813       while (*s && !isspace(*s)) s++;
10814       *s = '\0';
10815
10816       /* check that it's really not DCL with no file extension */
10817       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10818       if (fp) {
10819         char b[256] = {0,0,0,0};
10820         read(fileno(fp), b, 256);
10821         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10822         if (isdcl) {
10823           int shebang_len;
10824
10825           /* Check for script */
10826           shebang_len = 0;
10827           if ((b[0] == '#') && (b[1] == '!'))
10828              shebang_len = 2;
10829 #ifdef ALTERNATE_SHEBANG
10830           else {
10831             shebang_len = strlen(ALTERNATE_SHEBANG);
10832             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10833               char * perlstr;
10834                 perlstr = strstr("perl",b);
10835                 if (perlstr == NULL)
10836                   shebang_len = 0;
10837             }
10838             else
10839               shebang_len = 0;
10840           }
10841 #endif
10842
10843           if (shebang_len > 0) {
10844           int i;
10845           int j;
10846           char tmpspec[NAM$C_MAXRSS + 1];
10847
10848             i = shebang_len;
10849              /* Image is following after white space */
10850             /*--------------------------------------*/
10851             while (isprint(b[i]) && isspace(b[i]))
10852                 i++;
10853
10854             j = 0;
10855             while (isprint(b[i]) && !isspace(b[i])) {
10856                 tmpspec[j++] = b[i++];
10857                 if (j >= NAM$C_MAXRSS)
10858                    break;
10859             }
10860             tmpspec[j] = '\0';
10861
10862              /* There may be some default parameters to the image */
10863             /*---------------------------------------------------*/
10864             j = 0;
10865             while (isprint(b[i])) {
10866                 image_argv[j++] = b[i++];
10867                 if (j >= NAM$C_MAXRSS)
10868                    break;
10869             }
10870             while ((j > 0) && !isprint(image_argv[j-1]))
10871                 j--;
10872             image_argv[j] = 0;
10873
10874             /* It will need to be converted to VMS format and validated */
10875             if (tmpspec[0] != '\0') {
10876               char * iname;
10877
10878                /* Try to find the exact program requested to be run */
10879               /*---------------------------------------------------*/
10880               iname = int_rmsexpand
10881                  (tmpspec, image_name, ".exe",
10882                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10883               if (iname != NULL) {
10884                 if (cando_by_name_int
10885                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10886                   /* MCR prefix needed */
10887                   isdcl = 0;
10888                 }
10889                 else {
10890                    /* Try again with a null type */
10891                   /*----------------------------*/
10892                   iname = int_rmsexpand
10893                     (tmpspec, image_name, ".",
10894                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10895                   if (iname != NULL) {
10896                     if (cando_by_name_int
10897                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10898                       /* MCR prefix needed */
10899                       isdcl = 0;
10900                     }
10901                   }
10902                 }
10903
10904                  /* Did we find the image to run the script? */
10905                 /*------------------------------------------*/
10906                 if (isdcl) {
10907                   char *tchr;
10908
10909                    /* Assume DCL or foreign command exists */
10910                   /*--------------------------------------*/
10911                   tchr = strrchr(tmpspec, '/');
10912                   if (tchr != NULL) {
10913                     tchr++;
10914                   }
10915                   else {
10916                     tchr = tmpspec;
10917                   }
10918                   strcpy(image_name, tchr);
10919                 }
10920               }
10921             }
10922           }
10923         }
10924         fclose(fp);
10925       }
10926       if (check_img && isdcl) {
10927           PerlMem_free(cmd);
10928           PerlMem_free(resspec);
10929           PerlMem_free(vmsspec);
10930           return RMS$_FNF;
10931       }
10932
10933       if (cando_by_name(S_IXUSR,0,resspec)) {
10934         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10935         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10936         if (!isdcl) {
10937             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10938             if (image_name[0] != 0) {
10939                 strcat(vmscmd->dsc$a_pointer, image_name);
10940                 strcat(vmscmd->dsc$a_pointer, " ");
10941             }
10942         } else if (image_name[0] != 0) {
10943             strcpy(vmscmd->dsc$a_pointer, image_name);
10944             strcat(vmscmd->dsc$a_pointer, " ");
10945         } else {
10946             strcpy(vmscmd->dsc$a_pointer,"@");
10947         }
10948         if (suggest_quote) *suggest_quote = 1;
10949
10950         /* If there is an image name, use original command */
10951         if (image_name[0] == 0)
10952             strcat(vmscmd->dsc$a_pointer,resspec);
10953         else {
10954             rest = cmd;
10955             while (*rest && isspace(*rest)) rest++;
10956         }
10957
10958         if (image_argv[0] != 0) {
10959           strcat(vmscmd->dsc$a_pointer,image_argv);
10960           strcat(vmscmd->dsc$a_pointer, " ");
10961         }
10962         if (rest) {
10963            int rest_len;
10964            int vmscmd_len;
10965
10966            rest_len = strlen(rest);
10967            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10968            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10969               strcat(vmscmd->dsc$a_pointer,rest);
10970            else
10971              retsts = CLI$_BUFOVF;
10972         }
10973         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10974         PerlMem_free(cmd);
10975         PerlMem_free(vmsspec);
10976         PerlMem_free(resspec);
10977         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10978       }
10979       else
10980         retsts = RMS$_PRV;
10981     }
10982   }
10983   /* It's either a DCL command or we couldn't find a suitable image */
10984   vmscmd->dsc$w_length = strlen(cmd);
10985
10986   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10987   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10988   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10989
10990   PerlMem_free(cmd);
10991   PerlMem_free(resspec);
10992   PerlMem_free(vmsspec);
10993
10994   /* check if it's a symbol (for quoting purposes) */
10995   if (suggest_quote && !*suggest_quote) {
10996     int iss;
10997     char equiv[LNM$C_NAMLENGTH];
10998     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10999     eqvdsc.dsc$a_pointer = equiv;
11000
11001     iss = lib$get_symbol(vmscmd,&eqvdsc);
11002     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
11003   }
11004   if (!(retsts & 1)) {
11005     /* just hand off status values likely to be due to user error */
11006     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
11007         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
11008        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
11009     else { _ckvmssts_noperl(retsts); }
11010   }
11011
11012   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
11013
11014 }  /* end of setup_cmddsc() */
11015
11016
11017 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
11018 bool
11019 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
11020 {
11021 bool exec_sts;
11022 char * cmd;
11023
11024   if (sp > mark) {
11025     if (vfork_called) {           /* this follows a vfork - act Unixish */
11026       vfork_called--;
11027       if (vfork_called < 0) {
11028         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11029         vfork_called = 0;
11030       }
11031       else return do_aexec(really,mark,sp);
11032     }
11033                                            /* no vfork - act VMSish */
11034     cmd = setup_argstr(aTHX_ really,mark,sp);
11035     exec_sts = vms_do_exec(cmd);
11036     Safefree(cmd);  /* Clean up from setup_argstr() */
11037     return exec_sts;
11038   }
11039
11040   return FALSE;
11041 }  /* end of vms_do_aexec() */
11042 /*}}}*/
11043
11044 /* {{{bool vms_do_exec(char *cmd) */
11045 bool
11046 Perl_vms_do_exec(pTHX_ const char *cmd)
11047 {
11048   struct dsc$descriptor_s *vmscmd;
11049
11050   if (vfork_called) {             /* this follows a vfork - act Unixish */
11051     vfork_called--;
11052     if (vfork_called < 0) {
11053       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11054       vfork_called = 0;
11055     }
11056     else return do_exec(cmd);
11057   }
11058
11059   {                               /* no vfork - act VMSish */
11060     unsigned long int retsts;
11061
11062     TAINT_ENV();
11063     TAINT_PROPER("exec");
11064     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
11065       retsts = lib$do_command(vmscmd);
11066
11067     switch (retsts) {
11068       case RMS$_FNF: case RMS$_DNF:
11069         set_errno(ENOENT); break;
11070       case RMS$_DIR:
11071         set_errno(ENOTDIR); break;
11072       case RMS$_DEV:
11073         set_errno(ENODEV); break;
11074       case RMS$_PRV:
11075         set_errno(EACCES); break;
11076       case RMS$_SYN:
11077         set_errno(EINVAL); break;
11078       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11079         set_errno(E2BIG); break;
11080       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11081         _ckvmssts_noperl(retsts); /* fall through */
11082       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11083         set_errno(EVMSERR);
11084     }
11085     set_vaxc_errno(retsts);
11086     if (ckWARN(WARN_EXEC)) {
11087       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
11088              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
11089     }
11090     vms_execfree(vmscmd);
11091   }
11092
11093   return FALSE;
11094
11095 }  /* end of vms_do_exec() */
11096 /*}}}*/
11097
11098 int do_spawn2(pTHX_ const char *, int);
11099
11100 int
11101 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
11102 {
11103 unsigned long int sts;
11104 char * cmd;
11105 int flags = 0;
11106
11107   if (sp > mark) {
11108
11109     /* We'll copy the (undocumented?) Win32 behavior and allow a
11110      * numeric first argument.  But the only value we'll support
11111      * through do_aspawn is a value of 1, which means spawn without
11112      * waiting for completion -- other values are ignored.
11113      */
11114     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
11115         ++mark;
11116         flags = SvIVx(*mark);
11117     }
11118
11119     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
11120         flags = CLI$M_NOWAIT;
11121     else
11122         flags = 0;
11123
11124     cmd = setup_argstr(aTHX_ really, mark, sp);
11125     sts = do_spawn2(aTHX_ cmd, flags);
11126     /* pp_sys will clean up cmd */
11127     return sts;
11128   }
11129   return SS$_ABORT;
11130 }  /* end of do_aspawn() */
11131 /*}}}*/
11132
11133
11134 /* {{{int do_spawn(char* cmd) */
11135 int
11136 Perl_do_spawn(pTHX_ char* cmd)
11137 {
11138     PERL_ARGS_ASSERT_DO_SPAWN;
11139
11140     return do_spawn2(aTHX_ cmd, 0);
11141 }
11142 /*}}}*/
11143
11144 /* {{{int do_spawn_nowait(char* cmd) */
11145 int
11146 Perl_do_spawn_nowait(pTHX_ char* cmd)
11147 {
11148     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11149
11150     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11151 }
11152 /*}}}*/
11153
11154 /* {{{int do_spawn2(char *cmd) */
11155 int
11156 do_spawn2(pTHX_ const char *cmd, int flags)
11157 {
11158   unsigned long int sts, substs;
11159
11160   /* The caller of this routine expects to Safefree(PL_Cmd) */
11161   Newx(PL_Cmd,10,char);
11162
11163   TAINT_ENV();
11164   TAINT_PROPER("spawn");
11165   if (!cmd || !*cmd) {
11166     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11167     if (!(sts & 1)) {
11168       switch (sts) {
11169         case RMS$_FNF:  case RMS$_DNF:
11170           set_errno(ENOENT); break;
11171         case RMS$_DIR:
11172           set_errno(ENOTDIR); break;
11173         case RMS$_DEV:
11174           set_errno(ENODEV); break;
11175         case RMS$_PRV:
11176           set_errno(EACCES); break;
11177         case RMS$_SYN:
11178           set_errno(EINVAL); break;
11179         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11180           set_errno(E2BIG); break;
11181         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11182           _ckvmssts_noperl(sts); /* fall through */
11183         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11184           set_errno(EVMSERR);
11185       }
11186       set_vaxc_errno(sts);
11187       if (ckWARN(WARN_EXEC)) {
11188         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11189                     Strerror(errno));
11190       }
11191     }
11192     sts = substs;
11193   }
11194   else {
11195     char mode[3];
11196     PerlIO * fp;
11197     if (flags & CLI$M_NOWAIT)
11198         strcpy(mode, "n");
11199     else
11200         strcpy(mode, "nW");
11201
11202     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11203     if (fp != NULL)
11204       my_pclose(fp);
11205     /* sts will be the pid in the nowait case */
11206   }
11207   return sts;
11208 }  /* end of do_spawn2() */
11209 /*}}}*/
11210
11211
11212 static unsigned int *sockflags, sockflagsize;
11213
11214 /*
11215  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11216  * routines found in some versions of the CRTL can't deal with sockets.
11217  * We don't shim the other file open routines since a socket isn't
11218  * likely to be opened by a name.
11219  */
11220 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11221 FILE *my_fdopen(int fd, const char *mode)
11222 {
11223   FILE *fp = fdopen(fd, mode);
11224
11225   if (fp) {
11226     unsigned int fdoff = fd / sizeof(unsigned int);
11227     Stat_t sbuf; /* native stat; we don't need flex_stat */
11228     if (!sockflagsize || fdoff > sockflagsize) {
11229       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11230       else           Newx  (sockflags,fdoff+2,unsigned int);
11231       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11232       sockflagsize = fdoff + 2;
11233     }
11234     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11235       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11236   }
11237   return fp;
11238
11239 }
11240 /*}}}*/
11241
11242
11243 /*
11244  * Clear the corresponding bit when the (possibly) socket stream is closed.
11245  * There still a small hole: we miss an implicit close which might occur
11246  * via freopen().  >> Todo
11247  */
11248 /*{{{ int my_fclose(FILE *fp)*/
11249 int my_fclose(FILE *fp) {
11250   if (fp) {
11251     unsigned int fd = fileno(fp);
11252     unsigned int fdoff = fd / sizeof(unsigned int);
11253
11254     if (sockflagsize && fdoff < sockflagsize)
11255       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11256   }
11257   return fclose(fp);
11258 }
11259 /*}}}*/
11260
11261
11262 /*
11263  * A simple fwrite replacement which outputs itmsz*nitm chars without
11264  * introducing record boundaries every itmsz chars.
11265  * We are using fputs, which depends on a terminating null.  We may
11266  * well be writing binary data, so we need to accommodate not only
11267  * data with nulls sprinkled in the middle but also data with no null
11268  * byte at the end.
11269  */
11270 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11271 int
11272 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11273 {
11274   register char *cp, *end, *cpd, *data;
11275   register unsigned int fd = fileno(dest);
11276   register unsigned int fdoff = fd / sizeof(unsigned int);
11277   int retval;
11278   int bufsize = itmsz * nitm + 1;
11279
11280   if (fdoff < sockflagsize &&
11281       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11282     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11283     return nitm;
11284   }
11285
11286   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11287   memcpy( data, src, itmsz*nitm );
11288   data[itmsz*nitm] = '\0';
11289
11290   end = data + itmsz * nitm;
11291   retval = (int) nitm; /* on success return # items written */
11292
11293   cpd = data;
11294   while (cpd <= end) {
11295     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11296     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11297     if (cp < end)
11298       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11299     cpd = cp + 1;
11300   }
11301
11302   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11303   return retval;
11304
11305 }  /* end of my_fwrite() */
11306 /*}}}*/
11307
11308 /*{{{ int my_flush(FILE *fp)*/
11309 int
11310 Perl_my_flush(pTHX_ FILE *fp)
11311 {
11312     int res;
11313     if ((res = fflush(fp)) == 0 && fp) {
11314 #ifdef VMS_DO_SOCKETS
11315         Stat_t s;
11316         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11317 #endif
11318             res = fsync(fileno(fp));
11319     }
11320 /*
11321  * If the flush succeeded but set end-of-file, we need to clear
11322  * the error because our caller may check ferror().  BTW, this
11323  * probably means we just flushed an empty file.
11324  */
11325     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11326
11327     return res;
11328 }
11329 /*}}}*/
11330
11331 /* fgetname() is not returning the correct file specifications when
11332  * decc_filename_unix_report mode is active.  So we have to have it
11333  * aways return filenames in VMS mode and convert it ourselves.
11334  */
11335
11336 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11337 char *
11338 Perl_my_fgetname(FILE *fp, char * buf) {
11339     char * retname;
11340     char * vms_name;
11341
11342     retname = fgetname(fp, buf, 1);
11343
11344     /* If we are in VMS mode, then we are done */
11345     if (!decc_filename_unix_report || (retname == NULL)) {
11346        return retname;
11347     }
11348
11349     /* Convert this to Unix format */
11350     vms_name = PerlMem_malloc(VMS_MAXRSS + 1);
11351     strcpy(vms_name, retname);
11352     retname = int_tounixspec(vms_name, buf, NULL);
11353     PerlMem_free(vms_name);
11354
11355     return retname;
11356 }
11357 /*}}}*/
11358
11359 /*
11360  * Here are replacements for the following Unix routines in the VMS environment:
11361  *      getpwuid    Get information for a particular UIC or UID
11362  *      getpwnam    Get information for a named user
11363  *      getpwent    Get information for each user in the rights database
11364  *      setpwent    Reset search to the start of the rights database
11365  *      endpwent    Finish searching for users in the rights database
11366  *
11367  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11368  * (defined in pwd.h), which contains the following fields:-
11369  *      struct passwd {
11370  *              char        *pw_name;    Username (in lower case)
11371  *              char        *pw_passwd;  Hashed password
11372  *              unsigned int pw_uid;     UIC
11373  *              unsigned int pw_gid;     UIC group  number
11374  *              char        *pw_unixdir; Default device/directory (VMS-style)
11375  *              char        *pw_gecos;   Owner name
11376  *              char        *pw_dir;     Default device/directory (Unix-style)
11377  *              char        *pw_shell;   Default CLI name (eg. DCL)
11378  *      };
11379  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11380  *
11381  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11382  * not the UIC member number (eg. what's returned by getuid()),
11383  * getpwuid() can accept either as input (if uid is specified, the caller's
11384  * UIC group is used), though it won't recognise gid=0.
11385  *
11386  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11387  * information about other users in your group or in other groups, respectively.
11388  * If the required privilege is not available, then these routines fill only
11389  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11390  * string).
11391  *
11392  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11393  */
11394
11395 /* sizes of various UAF record fields */
11396 #define UAI$S_USERNAME 12
11397 #define UAI$S_IDENT    31
11398 #define UAI$S_OWNER    31
11399 #define UAI$S_DEFDEV   31
11400 #define UAI$S_DEFDIR   63
11401 #define UAI$S_DEFCLI   31
11402 #define UAI$S_PWD       8
11403
11404 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11405                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11406                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11407
11408 static char __empty[]= "";
11409 static struct passwd __passwd_empty=
11410     {(char *) __empty, (char *) __empty, 0, 0,
11411      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11412 static int contxt= 0;
11413 static struct passwd __pwdcache;
11414 static char __pw_namecache[UAI$S_IDENT+1];
11415
11416 /*
11417  * This routine does most of the work extracting the user information.
11418  */
11419 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11420 {
11421     static struct {
11422         unsigned char length;
11423         char pw_gecos[UAI$S_OWNER+1];
11424     } owner;
11425     static union uicdef uic;
11426     static struct {
11427         unsigned char length;
11428         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11429     } defdev;
11430     static struct {
11431         unsigned char length;
11432         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11433     } defdir;
11434     static struct {
11435         unsigned char length;
11436         char pw_shell[UAI$S_DEFCLI+1];
11437     } defcli;
11438     static char pw_passwd[UAI$S_PWD+1];
11439
11440     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11441     struct dsc$descriptor_s name_desc;
11442     unsigned long int sts;
11443
11444     static struct itmlst_3 itmlst[]= {
11445         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11446         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11447         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11448         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11449         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11450         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11451         {0,                0,           NULL,    NULL}};
11452
11453     name_desc.dsc$w_length=  strlen(name);
11454     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11455     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11456     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11457
11458 /*  Note that sys$getuai returns many fields as counted strings. */
11459     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11460     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11461       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11462     }
11463     else { _ckvmssts(sts); }
11464     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11465
11466     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11467     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11468     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11469     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11470     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11471     owner.pw_gecos[lowner]=            '\0';
11472     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11473     defcli.pw_shell[ldefcli]=          '\0';
11474     if (valid_uic(uic)) {
11475         pwd->pw_uid= uic.uic$l_uic;
11476         pwd->pw_gid= uic.uic$v_group;
11477     }
11478     else
11479       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11480     pwd->pw_passwd=  pw_passwd;
11481     pwd->pw_gecos=   owner.pw_gecos;
11482     pwd->pw_dir=     defdev.pw_dir;
11483     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11484     pwd->pw_shell=   defcli.pw_shell;
11485     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11486         int ldir;
11487         ldir= strlen(pwd->pw_unixdir) - 1;
11488         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11489     }
11490     else
11491         strcpy(pwd->pw_unixdir, pwd->pw_dir);
11492     if (!decc_efs_case_preserve)
11493         __mystrtolower(pwd->pw_unixdir);
11494     return 1;
11495 }
11496
11497 /*
11498  * Get information for a named user.
11499 */
11500 /*{{{struct passwd *getpwnam(char *name)*/
11501 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11502 {
11503     struct dsc$descriptor_s name_desc;
11504     union uicdef uic;
11505     unsigned long int status, sts;
11506
11507     __pwdcache = __passwd_empty;
11508     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11509       /* We still may be able to determine pw_uid and pw_gid */
11510       name_desc.dsc$w_length=  strlen(name);
11511       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11512       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11513       name_desc.dsc$a_pointer= (char *) name;
11514       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11515         __pwdcache.pw_uid= uic.uic$l_uic;
11516         __pwdcache.pw_gid= uic.uic$v_group;
11517       }
11518       else {
11519         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11520           set_vaxc_errno(sts);
11521           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11522           return NULL;
11523         }
11524         else { _ckvmssts(sts); }
11525       }
11526     }
11527     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
11528     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
11529     __pwdcache.pw_name= __pw_namecache;
11530     return &__pwdcache;
11531 }  /* end of my_getpwnam() */
11532 /*}}}*/
11533
11534 /*
11535  * Get information for a particular UIC or UID.
11536  * Called by my_getpwent with uid=-1 to list all users.
11537 */
11538 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11539 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11540 {
11541     const $DESCRIPTOR(name_desc,__pw_namecache);
11542     unsigned short lname;
11543     union uicdef uic;
11544     unsigned long int status;
11545
11546     if (uid == (unsigned int) -1) {
11547       do {
11548         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11549         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11550           set_vaxc_errno(status);
11551           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11552           my_endpwent();
11553           return NULL;
11554         }
11555         else { _ckvmssts(status); }
11556       } while (!valid_uic (uic));
11557     }
11558     else {
11559       uic.uic$l_uic= uid;
11560       if (!uic.uic$v_group)
11561         uic.uic$v_group= PerlProc_getgid();
11562       if (valid_uic(uic))
11563         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11564       else status = SS$_IVIDENT;
11565       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11566           status == RMS$_PRV) {
11567         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11568         return NULL;
11569       }
11570       else { _ckvmssts(status); }
11571     }
11572     __pw_namecache[lname]= '\0';
11573     __mystrtolower(__pw_namecache);
11574
11575     __pwdcache = __passwd_empty;
11576     __pwdcache.pw_name = __pw_namecache;
11577
11578 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11579     The identifier's value is usually the UIC, but it doesn't have to be,
11580     so if we can, we let fillpasswd update this. */
11581     __pwdcache.pw_uid =  uic.uic$l_uic;
11582     __pwdcache.pw_gid =  uic.uic$v_group;
11583
11584     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11585     return &__pwdcache;
11586
11587 }  /* end of my_getpwuid() */
11588 /*}}}*/
11589
11590 /*
11591  * Get information for next user.
11592 */
11593 /*{{{struct passwd *my_getpwent()*/
11594 struct passwd *Perl_my_getpwent(pTHX)
11595 {
11596     return (my_getpwuid((unsigned int) -1));
11597 }
11598 /*}}}*/
11599
11600 /*
11601  * Finish searching rights database for users.
11602 */
11603 /*{{{void my_endpwent()*/
11604 void Perl_my_endpwent(pTHX)
11605 {
11606     if (contxt) {
11607       _ckvmssts(sys$finish_rdb(&contxt));
11608       contxt= 0;
11609     }
11610 }
11611 /*}}}*/
11612
11613 #ifdef HOMEGROWN_POSIX_SIGNALS
11614   /* Signal handling routines, pulled into the core from POSIX.xs.
11615    *
11616    * We need these for threads, so they've been rolled into the core,
11617    * rather than left in POSIX.xs.
11618    *
11619    * (DRS, Oct 23, 1997)
11620    */
11621
11622   /* sigset_t is atomic under VMS, so these routines are easy */
11623 /*{{{int my_sigemptyset(sigset_t *) */
11624 int my_sigemptyset(sigset_t *set) {
11625     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11626     *set = 0; return 0;
11627 }
11628 /*}}}*/
11629
11630
11631 /*{{{int my_sigfillset(sigset_t *)*/
11632 int my_sigfillset(sigset_t *set) {
11633     int i;
11634     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11635     for (i = 0; i < NSIG; i++) *set |= (1 << i);
11636     return 0;
11637 }
11638 /*}}}*/
11639
11640
11641 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
11642 int my_sigaddset(sigset_t *set, int sig) {
11643     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11644     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11645     *set |= (1 << (sig - 1));
11646     return 0;
11647 }
11648 /*}}}*/
11649
11650
11651 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
11652 int my_sigdelset(sigset_t *set, int sig) {
11653     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11654     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11655     *set &= ~(1 << (sig - 1));
11656     return 0;
11657 }
11658 /*}}}*/
11659
11660
11661 /*{{{int my_sigismember(sigset_t *set, int sig)*/
11662 int my_sigismember(sigset_t *set, int sig) {
11663     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11664     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11665     return *set & (1 << (sig - 1));
11666 }
11667 /*}}}*/
11668
11669
11670 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
11671 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
11672     sigset_t tempmask;
11673
11674     /* If set and oset are both null, then things are badly wrong. Bail out. */
11675     if ((oset == NULL) && (set == NULL)) {
11676       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
11677       return -1;
11678     }
11679
11680     /* If set's null, then we're just handling a fetch. */
11681     if (set == NULL) {
11682         tempmask = sigblock(0);
11683     }
11684     else {
11685       switch (how) {
11686       case SIG_SETMASK:
11687         tempmask = sigsetmask(*set);
11688         break;
11689       case SIG_BLOCK:
11690         tempmask = sigblock(*set);
11691         break;
11692       case SIG_UNBLOCK:
11693         tempmask = sigblock(0);
11694         sigsetmask(*oset & ~tempmask);
11695         break;
11696       default:
11697         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11698         return -1;
11699       }
11700     }
11701
11702     /* Did they pass us an oset? If so, stick our holding mask into it */
11703     if (oset)
11704       *oset = tempmask;
11705
11706     return 0;
11707 }
11708 /*}}}*/
11709 #endif  /* HOMEGROWN_POSIX_SIGNALS */
11710
11711
11712 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11713  * my_utime(), and flex_stat(), all of which operate on UTC unless
11714  * VMSISH_TIMES is true.
11715  */
11716 /* method used to handle UTC conversions:
11717  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11718  */
11719 static int gmtime_emulation_type;
11720 /* number of secs to add to UTC POSIX-style time to get local time */
11721 static long int utc_offset_secs;
11722
11723 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11724  * in vmsish.h.  #undef them here so we can call the CRTL routines
11725  * directly.
11726  */
11727 #undef gmtime
11728 #undef localtime
11729 #undef time
11730
11731
11732 /*
11733  * DEC C previous to 6.0 corrupts the behavior of the /prefix
11734  * qualifier with the extern prefix pragma.  This provisional
11735  * hack circumvents this prefix pragma problem in previous
11736  * precompilers.
11737  */
11738 #if defined(__VMS_VER) && __VMS_VER >= 70000000
11739 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11740 #    pragma __extern_prefix save
11741 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
11742 #    define gmtime decc$__utctz_gmtime
11743 #    define localtime decc$__utctz_localtime
11744 #    define time decc$__utc_time
11745 #    pragma __extern_prefix restore
11746
11747      struct tm *gmtime(), *localtime();
11748
11749 #  endif
11750 #endif
11751
11752
11753 static time_t toutc_dst(time_t loc) {
11754   struct tm *rsltmp;
11755
11756   if ((rsltmp = localtime(&loc)) == NULL) return -1;
11757   loc -= utc_offset_secs;
11758   if (rsltmp->tm_isdst) loc -= 3600;
11759   return loc;
11760 }
11761 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11762        ((gmtime_emulation_type || my_time(NULL)), \
11763        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11764        ((secs) - utc_offset_secs))))
11765
11766 static time_t toloc_dst(time_t utc) {
11767   struct tm *rsltmp;
11768
11769   utc += utc_offset_secs;
11770   if ((rsltmp = localtime(&utc)) == NULL) return -1;
11771   if (rsltmp->tm_isdst) utc += 3600;
11772   return utc;
11773 }
11774 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11775        ((gmtime_emulation_type || my_time(NULL)), \
11776        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11777        ((secs) + utc_offset_secs))))
11778
11779 #ifndef RTL_USES_UTC
11780 /*
11781
11782     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
11783         DST starts on 1st sun of april      at 02:00  std time
11784             ends on last sun of october     at 02:00  dst time
11785     see the UCX management command reference, SET CONFIG TIMEZONE
11786     for formatting info.
11787
11788     No, it's not as general as it should be, but then again, NOTHING
11789     will handle UK times in a sensible way.
11790 */
11791
11792
11793 /*
11794     parse the DST start/end info:
11795     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11796 */
11797
11798 static char *
11799 tz_parse_startend(char *s, struct tm *w, int *past)
11800 {
11801     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11802     int ly, dozjd, d, m, n, hour, min, sec, j, k;
11803     time_t g;
11804
11805     if (!s)    return 0;
11806     if (!w) return 0;
11807     if (!past) return 0;
11808
11809     ly = 0;
11810     if (w->tm_year % 4        == 0) ly = 1;
11811     if (w->tm_year % 100      == 0) ly = 0;
11812     if (w->tm_year+1900 % 400 == 0) ly = 1;
11813     if (ly) dinm[1]++;
11814
11815     dozjd = isdigit(*s);
11816     if (*s == 'J' || *s == 'j' || dozjd) {
11817         if (!dozjd && !isdigit(*++s)) return 0;
11818         d = *s++ - '0';
11819         if (isdigit(*s)) {
11820             d = d*10 + *s++ - '0';
11821             if (isdigit(*s)) {
11822                 d = d*10 + *s++ - '0';
11823             }
11824         }
11825         if (d == 0) return 0;
11826         if (d > 366) return 0;
11827         d--;
11828         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
11829         g = d * 86400;
11830         dozjd = 1;
11831     } else if (*s == 'M' || *s == 'm') {
11832         if (!isdigit(*++s)) return 0;
11833         m = *s++ - '0';
11834         if (isdigit(*s)) m = 10*m + *s++ - '0';
11835         if (*s != '.') return 0;
11836         if (!isdigit(*++s)) return 0;
11837         n = *s++ - '0';
11838         if (n < 1 || n > 5) return 0;
11839         if (*s != '.') return 0;
11840         if (!isdigit(*++s)) return 0;
11841         d = *s++ - '0';
11842         if (d > 6) return 0;
11843     }
11844
11845     if (*s == '/') {
11846         if (!isdigit(*++s)) return 0;
11847         hour = *s++ - '0';
11848         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11849         if (*s == ':') {
11850             if (!isdigit(*++s)) return 0;
11851             min = *s++ - '0';
11852             if (isdigit(*s)) min = 10*min + *s++ - '0';
11853             if (*s == ':') {
11854                 if (!isdigit(*++s)) return 0;
11855                 sec = *s++ - '0';
11856                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11857             }
11858         }
11859     } else {
11860         hour = 2;
11861         min = 0;
11862         sec = 0;
11863     }
11864
11865     if (dozjd) {
11866         if (w->tm_yday < d) goto before;
11867         if (w->tm_yday > d) goto after;
11868     } else {
11869         if (w->tm_mon+1 < m) goto before;
11870         if (w->tm_mon+1 > m) goto after;
11871
11872         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
11873         k = d - j; /* mday of first d */
11874         if (k <= 0) k += 7;
11875         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
11876         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11877         if (w->tm_mday < k) goto before;
11878         if (w->tm_mday > k) goto after;
11879     }
11880
11881     if (w->tm_hour < hour) goto before;
11882     if (w->tm_hour > hour) goto after;
11883     if (w->tm_min  < min)  goto before;
11884     if (w->tm_min  > min)  goto after;
11885     if (w->tm_sec  < sec)  goto before;
11886     goto after;
11887
11888 before:
11889     *past = 0;
11890     return s;
11891 after:
11892     *past = 1;
11893     return s;
11894 }
11895
11896
11897
11898
11899 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
11900
11901 static char *
11902 tz_parse_offset(char *s, int *offset)
11903 {
11904     int hour = 0, min = 0, sec = 0;
11905     int neg = 0;
11906     if (!s) return 0;
11907     if (!offset) return 0;
11908
11909     if (*s == '-') {neg++; s++;}
11910     if (*s == '+') s++;
11911     if (!isdigit(*s)) return 0;
11912     hour = *s++ - '0';
11913     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11914     if (hour > 24) return 0;
11915     if (*s == ':') {
11916         if (!isdigit(*++s)) return 0;
11917         min = *s++ - '0';
11918         if (isdigit(*s)) min = min*10 + (*s++ - '0');
11919         if (min > 59) return 0;
11920         if (*s == ':') {
11921             if (!isdigit(*++s)) return 0;
11922             sec = *s++ - '0';
11923             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11924             if (sec > 59) return 0;
11925         }
11926     }
11927
11928     *offset = (hour*60+min)*60 + sec;
11929     if (neg) *offset = -*offset;
11930     return s;
11931 }
11932
11933 /*
11934     input time is w, whatever type of time the CRTL localtime() uses.
11935     sets dst, the zone, and the gmtoff (seconds)
11936
11937     caches the value of TZ and UCX$TZ env variables; note that
11938     my_setenv looks for these and sets a flag if they're changed
11939     for efficiency.
11940
11941     We have to watch out for the "australian" case (dst starts in
11942     october, ends in april)...flagged by "reverse" and checked by
11943     scanning through the months of the previous year.
11944
11945 */
11946
11947 static int
11948 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11949 {
11950     time_t when;
11951     struct tm *w2;
11952     char *s,*s2;
11953     char *dstzone, *tz, *s_start, *s_end;
11954     int std_off, dst_off, isdst;
11955     int y, dststart, dstend;
11956     static char envtz[1025];  /* longer than any logical, symbol, ... */
11957     static char ucxtz[1025];
11958     static char reversed = 0;
11959
11960     if (!w) return 0;
11961
11962     if (tz_updated) {
11963         tz_updated = 0;
11964         reversed = -1;  /* flag need to check  */
11965         envtz[0] = ucxtz[0] = '\0';
11966         tz = my_getenv("TZ",0);
11967         if (tz) strcpy(envtz, tz);
11968         tz = my_getenv("UCX$TZ",0);
11969         if (tz) strcpy(ucxtz, tz);
11970         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
11971     }
11972     tz = envtz;
11973     if (!*tz) tz = ucxtz;
11974
11975     s = tz;
11976     while (isalpha(*s)) s++;
11977     s = tz_parse_offset(s, &std_off);
11978     if (!s) return 0;
11979     if (!*s) {                  /* no DST, hurray we're done! */
11980         isdst = 0;
11981         goto done;
11982     }
11983
11984     dstzone = s;
11985     while (isalpha(*s)) s++;
11986     s2 = tz_parse_offset(s, &dst_off);
11987     if (s2) {
11988         s = s2;
11989     } else {
11990         dst_off = std_off - 3600;
11991     }
11992
11993     if (!*s) {      /* default dst start/end?? */
11994         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
11995             s = strchr(ucxtz,',');
11996         }
11997         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
11998     }
11999     if (*s != ',') return 0;
12000
12001     when = *w;
12002     when = _toutc(when);      /* convert to utc */
12003     when = when - std_off;    /* convert to pseudolocal time*/
12004
12005     w2 = localtime(&when);
12006     y = w2->tm_year;
12007     s_start = s+1;
12008     s = tz_parse_startend(s_start,w2,&dststart);
12009     if (!s) return 0;
12010     if (*s != ',') return 0;
12011
12012     when = *w;
12013     when = _toutc(when);      /* convert to utc */
12014     when = when - dst_off;    /* convert to pseudolocal time*/
12015     w2 = localtime(&when);
12016     if (w2->tm_year != y) {   /* spans a year, just check one time */
12017         when += dst_off - std_off;
12018         w2 = localtime(&when);
12019     }
12020     s_end = s+1;
12021     s = tz_parse_startend(s_end,w2,&dstend);
12022     if (!s) return 0;
12023
12024     if (reversed == -1) {  /* need to check if start later than end */
12025         int j, ds, de;
12026
12027         when = *w;
12028         if (when < 2*365*86400) {
12029             when += 2*365*86400;
12030         } else {
12031             when -= 365*86400;
12032         }
12033         w2 =localtime(&when);
12034         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
12035
12036         for (j = 0; j < 12; j++) {
12037             w2 =localtime(&when);
12038             tz_parse_startend(s_start,w2,&ds);
12039             tz_parse_startend(s_end,w2,&de);
12040             if (ds != de) break;
12041             when += 30*86400;
12042         }
12043         reversed = 0;
12044         if (de && !ds) reversed = 1;
12045     }
12046
12047     isdst = dststart && !dstend;
12048     if (reversed) isdst = dststart  || !dstend;
12049
12050 done:
12051     if (dst)    *dst = isdst;
12052     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
12053     if (isdst)  tz = dstzone;
12054     if (zone) {
12055         while(isalpha(*tz))  *zone++ = *tz++;
12056         *zone = '\0';
12057     }
12058     return 1;
12059 }
12060
12061 #endif /* !RTL_USES_UTC */
12062
12063 /* my_time(), my_localtime(), my_gmtime()
12064  * By default traffic in UTC time values, using CRTL gmtime() or
12065  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
12066  * Note: We need to use these functions even when the CRTL has working
12067  * UTC support, since they also handle C<use vmsish qw(times);>
12068  *
12069  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
12070  * Modified by Charles Bailey <bailey@newman.upenn.edu>
12071  */
12072
12073 /*{{{time_t my_time(time_t *timep)*/
12074 time_t Perl_my_time(pTHX_ time_t *timep)
12075 {
12076   time_t when;
12077   struct tm *tm_p;
12078
12079   if (gmtime_emulation_type == 0) {
12080     int dstnow;
12081     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
12082                               /* results of calls to gmtime() and localtime() */
12083                               /* for same &base */
12084
12085     gmtime_emulation_type++;
12086     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
12087       char off[LNM$C_NAMLENGTH+1];;
12088
12089       gmtime_emulation_type++;
12090       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
12091         gmtime_emulation_type++;
12092         utc_offset_secs = 0;
12093         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
12094       }
12095       else { utc_offset_secs = atol(off); }
12096     }
12097     else { /* We've got a working gmtime() */
12098       struct tm gmt, local;
12099
12100       gmt = *tm_p;
12101       tm_p = localtime(&base);
12102       local = *tm_p;
12103       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
12104       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
12105       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
12106       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
12107     }
12108   }
12109
12110   when = time(NULL);
12111 # ifdef VMSISH_TIME
12112 # ifdef RTL_USES_UTC
12113   if (VMSISH_TIME) when = _toloc(when);
12114 # else
12115   if (!VMSISH_TIME) when = _toutc(when);
12116 # endif
12117 # endif
12118   if (timep != NULL) *timep = when;
12119   return when;
12120
12121 }  /* end of my_time() */
12122 /*}}}*/
12123
12124
12125 /*{{{struct tm *my_gmtime(const time_t *timep)*/
12126 struct tm *
12127 Perl_my_gmtime(pTHX_ const time_t *timep)
12128 {
12129   char *p;
12130   time_t when;
12131   struct tm *rsltmp;
12132
12133   if (timep == NULL) {
12134     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12135     return NULL;
12136   }
12137   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
12138
12139   when = *timep;
12140 # ifdef VMSISH_TIME
12141   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
12142 #  endif
12143 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
12144   return gmtime(&when);
12145 # else
12146   /* CRTL localtime() wants local time as input, so does no tz correction */
12147   rsltmp = localtime(&when);
12148   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
12149   return rsltmp;
12150 #endif
12151 }  /* end of my_gmtime() */
12152 /*}}}*/
12153
12154
12155 /*{{{struct tm *my_localtime(const time_t *timep)*/
12156 struct tm *
12157 Perl_my_localtime(pTHX_ const time_t *timep)
12158 {
12159   time_t when, whenutc;
12160   struct tm *rsltmp;
12161   int dst, offset;
12162
12163   if (timep == NULL) {
12164     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12165     return NULL;
12166   }
12167   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
12168   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
12169
12170   when = *timep;
12171 # ifdef RTL_USES_UTC
12172 # ifdef VMSISH_TIME
12173   if (VMSISH_TIME) when = _toutc(when);
12174 # endif
12175   /* CRTL localtime() wants UTC as input, does tz correction itself */
12176   return localtime(&when);
12177
12178 # else /* !RTL_USES_UTC */
12179   whenutc = when;
12180 # ifdef VMSISH_TIME
12181   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
12182   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
12183 # endif
12184   dst = -1;
12185 #ifndef RTL_USES_UTC
12186   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
12187       when = whenutc - offset;                   /* pseudolocal time*/
12188   }
12189 # endif
12190   /* CRTL localtime() wants local time as input, so does no tz correction */
12191   rsltmp = localtime(&when);
12192   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
12193   return rsltmp;
12194 # endif
12195
12196 } /*  end of my_localtime() */
12197 /*}}}*/
12198
12199 /* Reset definitions for later calls */
12200 #define gmtime(t)    my_gmtime(t)
12201 #define localtime(t) my_localtime(t)
12202 #define time(t)      my_time(t)
12203
12204
12205 /* my_utime - update modification/access time of a file
12206  *
12207  * VMS 7.3 and later implementation
12208  * Only the UTC translation is home-grown. The rest is handled by the
12209  * CRTL utime(), which will take into account the relevant feature
12210  * logicals and ODS-5 volume characteristics for true access times.
12211  *
12212  * pre VMS 7.3 implementation:
12213  * The calling sequence is identical to POSIX utime(), but under
12214  * VMS with ODS-2, only the modification time is changed; ODS-2 does
12215  * not maintain access times.  Restrictions differ from the POSIX
12216  * definition in that the time can be changed as long as the
12217  * caller has permission to execute the necessary IO$_MODIFY $QIO;
12218  * no separate checks are made to insure that the caller is the
12219  * owner of the file or has special privs enabled.
12220  * Code here is based on Joe Meadows' FILE utility.
12221  *
12222  */
12223
12224 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
12225  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
12226  * in 100 ns intervals.
12227  */
12228 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
12229
12230 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
12231 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
12232 {
12233 #if __CRTL_VER >= 70300000
12234   struct utimbuf utc_utimes, *utc_utimesp;
12235
12236   if (utimes != NULL) {
12237     utc_utimes.actime = utimes->actime;
12238     utc_utimes.modtime = utimes->modtime;
12239 # ifdef VMSISH_TIME
12240     /* If input was local; convert to UTC for sys svc */
12241     if (VMSISH_TIME) {
12242       utc_utimes.actime = _toutc(utimes->actime);
12243       utc_utimes.modtime = _toutc(utimes->modtime);
12244     }
12245 # endif
12246     utc_utimesp = &utc_utimes;
12247   }
12248   else {
12249     utc_utimesp = NULL;
12250   }
12251
12252   return utime(file, utc_utimesp);
12253
12254 #else /* __CRTL_VER < 70300000 */
12255
12256   register int i;
12257   int sts;
12258   long int bintime[2], len = 2, lowbit, unixtime,
12259            secscale = 10000000; /* seconds --> 100 ns intervals */
12260   unsigned long int chan, iosb[2], retsts;
12261   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
12262   struct FAB myfab = cc$rms_fab;
12263   struct NAM mynam = cc$rms_nam;
12264 #if defined (__DECC) && defined (__VAX)
12265   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
12266    * at least through VMS V6.1, which causes a type-conversion warning.
12267    */
12268 #  pragma message save
12269 #  pragma message disable cvtdiftypes
12270 #endif
12271   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
12272   struct fibdef myfib;
12273 #if defined (__DECC) && defined (__VAX)
12274   /* This should be right after the declaration of myatr, but due
12275    * to a bug in VAX DEC C, this takes effect a statement early.
12276    */
12277 #  pragma message restore
12278 #endif
12279   /* cast ok for read only parameter */
12280   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
12281                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
12282                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
12283
12284   if (file == NULL || *file == '\0') {
12285     SETERRNO(ENOENT, LIB$_INVARG);
12286     return -1;
12287   }
12288
12289   /* Convert to VMS format ensuring that it will fit in 255 characters */
12290   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
12291       SETERRNO(ENOENT, LIB$_INVARG);
12292       return -1;
12293   }
12294   if (utimes != NULL) {
12295     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
12296      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
12297      * Since time_t is unsigned long int, and lib$emul takes a signed long int
12298      * as input, we force the sign bit to be clear by shifting unixtime right
12299      * one bit, then multiplying by an extra factor of 2 in lib$emul().
12300      */
12301     lowbit = (utimes->modtime & 1) ? secscale : 0;
12302     unixtime = (long int) utimes->modtime;
12303 #   ifdef VMSISH_TIME
12304     /* If input was UTC; convert to local for sys svc */
12305     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
12306 #   endif
12307     unixtime >>= 1;  secscale <<= 1;
12308     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
12309     if (!(retsts & 1)) {
12310       SETERRNO(EVMSERR, retsts);
12311       return -1;
12312     }
12313     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
12314     if (!(retsts & 1)) {
12315       SETERRNO(EVMSERR, retsts);
12316       return -1;
12317     }
12318   }
12319   else {
12320     /* Just get the current time in VMS format directly */
12321     retsts = sys$gettim(bintime);
12322     if (!(retsts & 1)) {
12323       SETERRNO(EVMSERR, retsts);
12324       return -1;
12325     }
12326   }
12327
12328   myfab.fab$l_fna = vmsspec;
12329   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
12330   myfab.fab$l_nam = &mynam;
12331   mynam.nam$l_esa = esa;
12332   mynam.nam$b_ess = (unsigned char) sizeof esa;
12333   mynam.nam$l_rsa = rsa;
12334   mynam.nam$b_rss = (unsigned char) sizeof rsa;
12335   if (decc_efs_case_preserve)
12336       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
12337
12338   /* Look for the file to be affected, letting RMS parse the file
12339    * specification for us as well.  I have set errno using only
12340    * values documented in the utime() man page for VMS POSIX.
12341    */
12342   retsts = sys$parse(&myfab,0,0);
12343   if (!(retsts & 1)) {
12344     set_vaxc_errno(retsts);
12345     if      (retsts == RMS$_PRV) set_errno(EACCES);
12346     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
12347     else                         set_errno(EVMSERR);
12348     return -1;
12349   }
12350   retsts = sys$search(&myfab,0,0);
12351   if (!(retsts & 1)) {
12352     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12353     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12354     set_vaxc_errno(retsts);
12355     if      (retsts == RMS$_PRV) set_errno(EACCES);
12356     else if (retsts == RMS$_FNF) set_errno(ENOENT);
12357     else                         set_errno(EVMSERR);
12358     return -1;
12359   }
12360
12361   devdsc.dsc$w_length = mynam.nam$b_dev;
12362   /* cast ok for read only parameter */
12363   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
12364
12365   retsts = sys$assign(&devdsc,&chan,0,0);
12366   if (!(retsts & 1)) {
12367     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12368     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12369     set_vaxc_errno(retsts);
12370     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
12371     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
12372     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
12373     else                               set_errno(EVMSERR);
12374     return -1;
12375   }
12376
12377   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
12378   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
12379
12380   memset((void *) &myfib, 0, sizeof myfib);
12381 #if defined(__DECC) || defined(__DECCXX)
12382   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
12383   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
12384   /* This prevents the revision time of the file being reset to the current
12385    * time as a result of our IO$_MODIFY $QIO. */
12386   myfib.fib$l_acctl = FIB$M_NORECORD;
12387 #else
12388   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
12389   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
12390   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
12391 #endif
12392   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
12393   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12394   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12395   _ckvmssts(sys$dassgn(chan));
12396   if (retsts & 1) retsts = iosb[0];
12397   if (!(retsts & 1)) {
12398     set_vaxc_errno(retsts);
12399     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12400     else                      set_errno(EVMSERR);
12401     return -1;
12402   }
12403
12404   return 0;
12405
12406 #endif /* #if __CRTL_VER >= 70300000 */
12407
12408 }  /* end of my_utime() */
12409 /*}}}*/
12410
12411 /*
12412  * flex_stat, flex_lstat, flex_fstat
12413  * basic stat, but gets it right when asked to stat
12414  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
12415  */
12416
12417 #ifndef _USE_STD_STAT
12418 /* encode_dev packs a VMS device name string into an integer to allow
12419  * simple comparisons. This can be used, for example, to check whether two
12420  * files are located on the same device, by comparing their encoded device
12421  * names. Even a string comparison would not do, because stat() reuses the
12422  * device name buffer for each call; so without encode_dev, it would be
12423  * necessary to save the buffer and use strcmp (this would mean a number of
12424  * changes to the standard Perl code, to say nothing of what a Perl script
12425  * would have to do.
12426  *
12427  * The device lock id, if it exists, should be unique (unless perhaps compared
12428  * with lock ids transferred from other nodes). We have a lock id if the disk is
12429  * mounted cluster-wide, which is when we tend to get long (host-qualified)
12430  * device names. Thus we use the lock id in preference, and only if that isn't
12431  * available, do we try to pack the device name into an integer (flagged by
12432  * the sign bit (LOCKID_MASK) being set).
12433  *
12434  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
12435  * name and its encoded form, but it seems very unlikely that we will find
12436  * two files on different disks that share the same encoded device names,
12437  * and even more remote that they will share the same file id (if the test
12438  * is to check for the same file).
12439  *
12440  * A better method might be to use sys$device_scan on the first call, and to
12441  * search for the device, returning an index into the cached array.
12442  * The number returned would be more intelligible.
12443  * This is probably not worth it, and anyway would take quite a bit longer
12444  * on the first call.
12445  */
12446 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
12447 static mydev_t encode_dev (pTHX_ const char *dev)
12448 {
12449   int i;
12450   unsigned long int f;
12451   mydev_t enc;
12452   char c;
12453   const char *q;
12454
12455   if (!dev || !dev[0]) return 0;
12456
12457 #if LOCKID_MASK
12458   {
12459     struct dsc$descriptor_s dev_desc;
12460     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
12461
12462     /* For cluster-mounted disks, the disk lock identifier is unique, so we
12463        can try that first. */
12464     dev_desc.dsc$w_length =  strlen (dev);
12465     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
12466     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
12467     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
12468     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
12469     if (!$VMS_STATUS_SUCCESS(status)) {
12470       switch (status) {
12471         case SS$_NOSUCHDEV:
12472           SETERRNO(ENODEV, status);
12473           return 0;
12474         default:
12475           _ckvmssts(status);
12476       }
12477     }
12478     if (lockid) return (lockid & ~LOCKID_MASK);
12479   }
12480 #endif
12481
12482   /* Otherwise we try to encode the device name */
12483   enc = 0;
12484   f = 1;
12485   i = 0;
12486   for (q = dev + strlen(dev); q--; q >= dev) {
12487     if (*q == ':')
12488         break;
12489     if (isdigit (*q))
12490       c= (*q) - '0';
12491     else if (isalpha (toupper (*q)))
12492       c= toupper (*q) - 'A' + (char)10;
12493     else
12494       continue; /* Skip '$'s */
12495     i++;
12496     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
12497     if (i>1) f *= 36;
12498     enc += f * (unsigned long int) c;
12499   }
12500   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
12501
12502 }  /* end of encode_dev() */
12503 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12504         device_no = encode_dev(aTHX_ devname)
12505 #else
12506 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12507         device_no = new_dev_no
12508 #endif
12509
12510 static int
12511 is_null_device(name)
12512     const char *name;
12513 {
12514   if (decc_bug_devnull != 0) {
12515     if (strncmp("/dev/null", name, 9) == 0)
12516       return 1;
12517   }
12518     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
12519        The underscore prefix, controller letter, and unit number are
12520        independently optional; for our purposes, the colon punctuation
12521        is not.  The colon can be trailed by optional directory and/or
12522        filename, but two consecutive colons indicates a nodename rather
12523        than a device.  [pr]  */
12524   if (*name == '_') ++name;
12525   if (tolower(*name++) != 'n') return 0;
12526   if (tolower(*name++) != 'l') return 0;
12527   if (tolower(*name) == 'a') ++name;
12528   if (*name == '0') ++name;
12529   return (*name++ == ':') && (*name != ':');
12530 }
12531
12532 static int
12533 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
12534
12535 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
12536
12537 static I32
12538 Perl_cando_by_name_int
12539    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
12540 {
12541   char usrname[L_cuserid];
12542   struct dsc$descriptor_s usrdsc =
12543          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
12544   char *vmsname = NULL, *fileified = NULL;
12545   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
12546   unsigned short int retlen, trnlnm_iter_count;
12547   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12548   union prvdef curprv;
12549   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
12550          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
12551          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
12552   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
12553          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
12554          {0,0,0,0}};
12555   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
12556          {0,0,0,0}};
12557   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12558   Stat_t st;
12559   static int profile_context = -1;
12560
12561   if (!fname || !*fname) return FALSE;
12562
12563   /* Make sure we expand logical names, since sys$check_access doesn't */
12564   fileified = PerlMem_malloc(VMS_MAXRSS);
12565   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12566   if (!strpbrk(fname,"/]>:")) {
12567       strcpy(fileified,fname);
12568       trnlnm_iter_count = 0;
12569       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
12570         trnlnm_iter_count++;
12571         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
12572       }
12573       fname = fileified;
12574   }
12575
12576   vmsname = PerlMem_malloc(VMS_MAXRSS);
12577   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12578   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
12579     /* Don't know if already in VMS format, so make sure */
12580     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
12581       PerlMem_free(fileified);
12582       PerlMem_free(vmsname);
12583       return FALSE;
12584     }
12585   }
12586   else {
12587     strcpy(vmsname,fname);
12588   }
12589
12590   /* sys$check_access needs a file spec, not a directory spec.
12591    * flex_stat now will handle a null thread context during startup.
12592    */
12593
12594   retlen = namdsc.dsc$w_length = strlen(vmsname);
12595   if (vmsname[retlen-1] == ']'
12596       || vmsname[retlen-1] == '>'
12597       || vmsname[retlen-1] == ':'
12598       || (!flex_stat_int(vmsname, &st, 1) &&
12599           S_ISDIR(st.st_mode))) {
12600
12601       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
12602         PerlMem_free(fileified);
12603         PerlMem_free(vmsname);
12604         return FALSE;
12605       }
12606       fname = fileified;
12607   }
12608   else {
12609       fname = vmsname;
12610   }
12611
12612   retlen = namdsc.dsc$w_length = strlen(fname);
12613   namdsc.dsc$a_pointer = (char *)fname;
12614
12615   switch (bit) {
12616     case S_IXUSR: case S_IXGRP: case S_IXOTH:
12617       access = ARM$M_EXECUTE;
12618       flags = CHP$M_READ;
12619       break;
12620     case S_IRUSR: case S_IRGRP: case S_IROTH:
12621       access = ARM$M_READ;
12622       flags = CHP$M_READ | CHP$M_USEREADALL;
12623       break;
12624     case S_IWUSR: case S_IWGRP: case S_IWOTH:
12625       access = ARM$M_WRITE;
12626       flags = CHP$M_READ | CHP$M_WRITE;
12627       break;
12628     case S_IDUSR: case S_IDGRP: case S_IDOTH:
12629       access = ARM$M_DELETE;
12630       flags = CHP$M_READ | CHP$M_WRITE;
12631       break;
12632     default:
12633       if (fileified != NULL)
12634         PerlMem_free(fileified);
12635       if (vmsname != NULL)
12636         PerlMem_free(vmsname);
12637       return FALSE;
12638   }
12639
12640   /* Before we call $check_access, create a user profile with the current
12641    * process privs since otherwise it just uses the default privs from the
12642    * UAF and might give false positives or negatives.  This only works on
12643    * VMS versions v6.0 and later since that's when sys$create_user_profile
12644    * became available.
12645    */
12646
12647   /* get current process privs and username */
12648   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12649   _ckvmssts_noperl(iosb[0]);
12650
12651 #if defined(__VMS_VER) && __VMS_VER >= 60000000
12652
12653   /* find out the space required for the profile */
12654   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12655                                     &usrprodsc.dsc$w_length,&profile_context));
12656
12657   /* allocate space for the profile and get it filled in */
12658   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
12659   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12660   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12661                                     &usrprodsc.dsc$w_length,&profile_context));
12662
12663   /* use the profile to check access to the file; free profile & analyze results */
12664   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12665   PerlMem_free(usrprodsc.dsc$a_pointer);
12666   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12667
12668 #else
12669
12670   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
12671
12672 #endif
12673
12674   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12675       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12676       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12677     set_vaxc_errno(retsts);
12678     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12679     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12680     else set_errno(ENOENT);
12681     if (fileified != NULL)
12682       PerlMem_free(fileified);
12683     if (vmsname != NULL)
12684       PerlMem_free(vmsname);
12685     return FALSE;
12686   }
12687   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12688     if (fileified != NULL)
12689       PerlMem_free(fileified);
12690     if (vmsname != NULL)
12691       PerlMem_free(vmsname);
12692     return TRUE;
12693   }
12694   _ckvmssts_noperl(retsts);
12695
12696   if (fileified != NULL)
12697     PerlMem_free(fileified);
12698   if (vmsname != NULL)
12699     PerlMem_free(vmsname);
12700   return FALSE;  /* Should never get here */
12701
12702 }
12703
12704 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12705 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12706  * subset of the applicable information.
12707  */
12708 bool
12709 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12710 {
12711   return cando_by_name_int
12712         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12713 }  /* end of cando() */
12714 /*}}}*/
12715
12716
12717 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12718 I32
12719 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12720 {
12721    return cando_by_name_int(bit, effective, fname, 0);
12722
12723 }  /* end of cando_by_name() */
12724 /*}}}*/
12725
12726
12727 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12728 int
12729 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12730 {
12731   if (!fstat(fd, &statbufp->crtl_stat)) {
12732     char *cptr;
12733     char *vms_filename;
12734     vms_filename = PerlMem_malloc(VMS_MAXRSS);
12735     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12736
12737     /* Save name for cando by name in VMS format */
12738     cptr = getname(fd, vms_filename, 1);
12739
12740     /* This should not happen, but just in case */
12741     if (cptr == NULL) {
12742         statbufp->st_devnam[0] = 0;
12743     }
12744     else {
12745         /* Make sure that the saved name fits in 255 characters */
12746         cptr = int_rmsexpand_vms
12747                        (vms_filename,
12748                         statbufp->st_devnam,
12749                         0);
12750         if (cptr == NULL)
12751             statbufp->st_devnam[0] = 0;
12752     }
12753     PerlMem_free(vms_filename);
12754
12755     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12756     VMS_DEVICE_ENCODE
12757         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12758
12759 #   ifdef RTL_USES_UTC
12760 #   ifdef VMSISH_TIME
12761     if (VMSISH_TIME) {
12762       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12763       statbufp->st_atime = _toloc(statbufp->st_atime);
12764       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12765     }
12766 #   endif
12767 #   else
12768 #   ifdef VMSISH_TIME
12769     if (!VMSISH_TIME) { /* Return UTC instead of local time */
12770 #   else
12771     if (1) {
12772 #   endif
12773       statbufp->st_mtime = _toutc(statbufp->st_mtime);
12774       statbufp->st_atime = _toutc(statbufp->st_atime);
12775       statbufp->st_ctime = _toutc(statbufp->st_ctime);
12776     }
12777 #endif
12778     return 0;
12779   }
12780   return -1;
12781
12782 }  /* end of flex_fstat() */
12783 /*}}}*/
12784
12785 #if !defined(__VAX) && __CRTL_VER >= 80200000
12786 #ifdef lstat
12787 #undef lstat
12788 #endif
12789 #else
12790 #ifdef lstat
12791 #undef lstat
12792 #endif
12793 #define lstat(_x, _y) stat(_x, _y)
12794 #endif
12795
12796 static int
12797 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12798 {
12799     char *fileified;
12800     char *temp_fspec;
12801     const char *save_spec;
12802     char *ret_spec;
12803     int retval = -1;
12804     int efs_hack = 0;
12805     dSAVEDERRNO;
12806
12807     if (!fspec) {
12808         errno = EINVAL;
12809         return retval;
12810     }
12811
12812     if (decc_bug_devnull != 0) {
12813       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12814         memset(statbufp,0,sizeof *statbufp);
12815         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12816         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12817         statbufp->st_uid = 0x00010001;
12818         statbufp->st_gid = 0x0001;
12819         time((time_t *)&statbufp->st_mtime);
12820         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12821         return 0;
12822       }
12823     }
12824
12825     /* Try for a directory name first.  If fspec contains a filename without
12826      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12827      * and sea:[wine.dark]water. exist, we prefer the directory here.
12828      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12829      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12830      * the file with null type, specify this by calling flex_stat() with
12831      * a '.' at the end of fspec.
12832      *
12833      * If we are in Posix filespec mode, accept the filename as is.
12834      */
12835
12836
12837     fileified = PerlMem_malloc(VMS_MAXRSS);
12838     if (fileified == NULL)
12839         _ckvmssts_noperl(SS$_INSFMEM);
12840
12841     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
12842     if (temp_fspec == NULL)
12843         _ckvmssts_noperl(SS$_INSFMEM);
12844
12845     strcpy(temp_fspec, fspec);
12846
12847     SAVE_ERRNO;
12848
12849 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12850   if (decc_posix_compliant_pathnames == 0) {
12851 #endif
12852
12853     /* We may be able to optimize this, but in order for fileify_dirspec to
12854      * always return a usuable answer, we have to call vmspath first to
12855      * make sure that it is in VMS directory format, as stat/lstat on 8.3
12856      * can not handle directories in unix format that it does not have read
12857      * access to.  Vmspath handles the case where a bare name which could be
12858      * a logical name gets passed.
12859      */
12860     ret_spec = int_tovmspath(fspec, temp_fspec, NULL);
12861     if (ret_spec != NULL) {
12862         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
12863         if (ret_spec != NULL) {
12864             if (lstat_flag == 0)
12865                 retval = stat(fileified, &statbufp->crtl_stat);
12866             else
12867                 retval = lstat(fileified, &statbufp->crtl_stat);
12868             save_spec = fileified;
12869         }
12870     }
12871
12872     if (retval && vms_bug_stat_filename) {
12873
12874         /* We should try again as a vmsified file specification */
12875         /* However Perl traditionally has not done this, which  */
12876         /* causes problems with existing tests */
12877
12878         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12879         if (ret_spec != NULL) {
12880             if (lstat_flag == 0)
12881                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12882             else
12883                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12884             save_spec = temp_fspec;
12885         }
12886     }
12887
12888     if (retval) {
12889         /* Last chance - allow multiple dots with out EFS CHARSET */
12890         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12891          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12892          * enable it if it isn't already.
12893          */
12894 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12895         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12896             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12897 #endif
12898         if (lstat_flag == 0)
12899             retval = stat(fspec, &statbufp->crtl_stat);
12900         else
12901             retval = lstat(fspec, &statbufp->crtl_stat);
12902         save_spec = fspec;
12903 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12904         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12905             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12906             efs_hack = 1;
12907         }
12908 #endif
12909     }
12910
12911 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12912   } else {
12913     if (lstat_flag == 0)
12914       retval = stat(temp_fspec, &statbufp->crtl_stat);
12915     else
12916       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12917       save_spec = temp_fspec;
12918   }
12919 #endif
12920
12921 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12922   /* As you were... */
12923   if (!decc_efs_charset)
12924     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12925 #endif
12926
12927     if (!retval) {
12928     char * cptr;
12929     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12930
12931       /* If this is an lstat, do not follow the link */
12932       if (lstat_flag)
12933         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12934
12935 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12936       /* If we used the efs_hack above, we must also use it here for */
12937       /* perl_cando to work */
12938       if (efs_hack && (decc_efs_charset_index > 0)) {
12939           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12940       }
12941 #endif
12942       cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags);
12943 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12944       if (efs_hack && (decc_efs_charset_index > 0)) {
12945           decc$feature_set_value(decc_efs_charset, 1, 0);
12946       }
12947 #endif
12948
12949       /* Fix me: If this is NULL then stat found a file, and we could */
12950       /* not convert the specification to VMS - Should never happen */
12951       if (cptr == NULL)
12952         statbufp->st_devnam[0] = 0;
12953
12954       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12955       VMS_DEVICE_ENCODE
12956         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12957 #     ifdef RTL_USES_UTC
12958 #     ifdef VMSISH_TIME
12959       if (VMSISH_TIME) {
12960         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12961         statbufp->st_atime = _toloc(statbufp->st_atime);
12962         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12963       }
12964 #     endif
12965 #     else
12966 #     ifdef VMSISH_TIME
12967       if (!VMSISH_TIME) { /* Return UTC instead of local time */
12968 #     else
12969       if (1) {
12970 #     endif
12971         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12972         statbufp->st_atime = _toutc(statbufp->st_atime);
12973         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12974       }
12975 #     endif
12976     }
12977     /* If we were successful, leave errno where we found it */
12978     if (retval == 0) RESTORE_ERRNO;
12979     return retval;
12980
12981 }  /* end of flex_stat_int() */
12982
12983
12984 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12985 int
12986 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12987 {
12988    return flex_stat_int(fspec, statbufp, 0);
12989 }
12990 /*}}}*/
12991
12992 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12993 int
12994 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12995 {
12996    return flex_stat_int(fspec, statbufp, 1);
12997 }
12998 /*}}}*/
12999
13000
13001 /*{{{char *my_getlogin()*/
13002 /* VMS cuserid == Unix getlogin, except calling sequence */
13003 char *
13004 my_getlogin(void)
13005 {
13006     static char user[L_cuserid];
13007     return cuserid(user);
13008 }
13009 /*}}}*/
13010
13011
13012 /*  rmscopy - copy a file using VMS RMS routines
13013  *
13014  *  Copies contents and attributes of spec_in to spec_out, except owner
13015  *  and protection information.  Name and type of spec_in are used as
13016  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
13017  *  should try to propagate timestamps from the input file to the output file.
13018  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
13019  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
13020  *  propagated to the output file at creation iff the output file specification
13021  *  did not contain an explicit name or type, and the revision date is always
13022  *  updated at the end of the copy operation.  If it is greater than 0, then
13023  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
13024  *  other than the revision date should be propagated, and bit 1 indicates
13025  *  that the revision date should be propagated.
13026  *
13027  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
13028  *
13029  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
13030  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
13031  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
13032  * as part of the Perl standard distribution under the terms of the
13033  * GNU General Public License or the Perl Artistic License.  Copies
13034  * of each may be found in the Perl standard distribution.
13035  */ /* FIXME */
13036 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
13037 int
13038 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
13039 {
13040     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
13041          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
13042     unsigned long int i, sts, sts2;
13043     int dna_len;
13044     struct FAB fab_in, fab_out;
13045     struct RAB rab_in, rab_out;
13046     rms_setup_nam(nam);
13047     rms_setup_nam(nam_out);
13048     struct XABDAT xabdat;
13049     struct XABFHC xabfhc;
13050     struct XABRDT xabrdt;
13051     struct XABSUM xabsum;
13052
13053     vmsin = PerlMem_malloc(VMS_MAXRSS);
13054     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13055     vmsout = PerlMem_malloc(VMS_MAXRSS);
13056     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13057     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
13058         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
13059       PerlMem_free(vmsin);
13060       PerlMem_free(vmsout);
13061       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13062       return 0;
13063     }
13064
13065     esa = PerlMem_malloc(VMS_MAXRSS);
13066     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13067     esal = NULL;
13068 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13069     esal = PerlMem_malloc(VMS_MAXRSS);
13070     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13071 #endif
13072     fab_in = cc$rms_fab;
13073     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
13074     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
13075     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
13076     fab_in.fab$l_fop = FAB$M_SQO;
13077     rms_bind_fab_nam(fab_in, nam);
13078     fab_in.fab$l_xab = (void *) &xabdat;
13079
13080     rsa = PerlMem_malloc(VMS_MAXRSS);
13081     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13082     rsal = NULL;
13083 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13084     rsal = PerlMem_malloc(VMS_MAXRSS);
13085     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13086 #endif
13087     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
13088     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
13089     rms_nam_esl(nam) = 0;
13090     rms_nam_rsl(nam) = 0;
13091     rms_nam_esll(nam) = 0;
13092     rms_nam_rsll(nam) = 0;
13093 #ifdef NAM$M_NO_SHORT_UPCASE
13094     if (decc_efs_case_preserve)
13095         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
13096 #endif
13097
13098     xabdat = cc$rms_xabdat;        /* To get creation date */
13099     xabdat.xab$l_nxt = (void *) &xabfhc;
13100
13101     xabfhc = cc$rms_xabfhc;        /* To get record length */
13102     xabfhc.xab$l_nxt = (void *) &xabsum;
13103
13104     xabsum = cc$rms_xabsum;        /* To get key and area information */
13105
13106     if (!((sts = sys$open(&fab_in)) & 1)) {
13107       PerlMem_free(vmsin);
13108       PerlMem_free(vmsout);
13109       PerlMem_free(esa);
13110       if (esal != NULL)
13111         PerlMem_free(esal);
13112       PerlMem_free(rsa);
13113       if (rsal != NULL)
13114         PerlMem_free(rsal);
13115       set_vaxc_errno(sts);
13116       switch (sts) {
13117         case RMS$_FNF: case RMS$_DNF:
13118           set_errno(ENOENT); break;
13119         case RMS$_DIR:
13120           set_errno(ENOTDIR); break;
13121         case RMS$_DEV:
13122           set_errno(ENODEV); break;
13123         case RMS$_SYN:
13124           set_errno(EINVAL); break;
13125         case RMS$_PRV:
13126           set_errno(EACCES); break;
13127         default:
13128           set_errno(EVMSERR);
13129       }
13130       return 0;
13131     }
13132
13133     nam_out = nam;
13134     fab_out = fab_in;
13135     fab_out.fab$w_ifi = 0;
13136     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
13137     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
13138     fab_out.fab$l_fop = FAB$M_SQO;
13139     rms_bind_fab_nam(fab_out, nam_out);
13140     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
13141     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
13142     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
13143     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13144     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13145     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13146     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13147     esal_out = NULL;
13148     rsal_out = NULL;
13149 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13150     esal_out = PerlMem_malloc(VMS_MAXRSS);
13151     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13152     rsal_out = PerlMem_malloc(VMS_MAXRSS);
13153     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13154 #endif
13155     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
13156     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
13157
13158     if (preserve_dates == 0) {  /* Act like DCL COPY */
13159       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
13160       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
13161       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
13162         PerlMem_free(vmsin);
13163         PerlMem_free(vmsout);
13164         PerlMem_free(esa);
13165         if (esal != NULL)
13166             PerlMem_free(esal);
13167         PerlMem_free(rsa);
13168         if (rsal != NULL)
13169             PerlMem_free(rsal);
13170         PerlMem_free(esa_out);
13171         if (esal_out != NULL)
13172             PerlMem_free(esal_out);
13173         PerlMem_free(rsa_out);
13174         if (rsal_out != NULL)
13175             PerlMem_free(rsal_out);
13176         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
13177         set_vaxc_errno(sts);
13178         return 0;
13179       }
13180       fab_out.fab$l_xab = (void *) &xabdat;
13181       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
13182         preserve_dates = 1;
13183     }
13184     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
13185       preserve_dates =0;      /* bitmask from this point forward   */
13186
13187     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
13188     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
13189       PerlMem_free(vmsin);
13190       PerlMem_free(vmsout);
13191       PerlMem_free(esa);
13192       if (esal != NULL)
13193           PerlMem_free(esal);
13194       PerlMem_free(rsa);
13195       if (rsal != NULL)
13196           PerlMem_free(rsal);
13197       PerlMem_free(esa_out);
13198       if (esal_out != NULL)
13199           PerlMem_free(esal_out);
13200       PerlMem_free(rsa_out);
13201       if (rsal_out != NULL)
13202           PerlMem_free(rsal_out);
13203       set_vaxc_errno(sts);
13204       switch (sts) {
13205         case RMS$_DNF:
13206           set_errno(ENOENT); break;
13207         case RMS$_DIR:
13208           set_errno(ENOTDIR); break;
13209         case RMS$_DEV:
13210           set_errno(ENODEV); break;
13211         case RMS$_SYN:
13212           set_errno(EINVAL); break;
13213         case RMS$_PRV:
13214           set_errno(EACCES); break;
13215         default:
13216           set_errno(EVMSERR);
13217       }
13218       return 0;
13219     }
13220     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
13221     if (preserve_dates & 2) {
13222       /* sys$close() will process xabrdt, not xabdat */
13223       xabrdt = cc$rms_xabrdt;
13224 #ifndef __GNUC__
13225       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
13226 #else
13227       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
13228        * is unsigned long[2], while DECC & VAXC use a struct */
13229       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
13230 #endif
13231       fab_out.fab$l_xab = (void *) &xabrdt;
13232     }
13233
13234     ubf = PerlMem_malloc(32256);
13235     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13236     rab_in = cc$rms_rab;
13237     rab_in.rab$l_fab = &fab_in;
13238     rab_in.rab$l_rop = RAB$M_BIO;
13239     rab_in.rab$l_ubf = ubf;
13240     rab_in.rab$w_usz = 32256;
13241     if (!((sts = sys$connect(&rab_in)) & 1)) {
13242       sys$close(&fab_in); sys$close(&fab_out);
13243       PerlMem_free(vmsin);
13244       PerlMem_free(vmsout);
13245       PerlMem_free(ubf);
13246       PerlMem_free(esa);
13247       if (esal != NULL)
13248           PerlMem_free(esal);
13249       PerlMem_free(rsa);
13250       if (rsal != NULL)
13251           PerlMem_free(rsal);
13252       PerlMem_free(esa_out);
13253       if (esal_out != NULL)
13254           PerlMem_free(esal_out);
13255       PerlMem_free(rsa_out);
13256       if (rsal_out != NULL)
13257           PerlMem_free(rsal_out);
13258       set_errno(EVMSERR); set_vaxc_errno(sts);
13259       return 0;
13260     }
13261
13262     rab_out = cc$rms_rab;
13263     rab_out.rab$l_fab = &fab_out;
13264     rab_out.rab$l_rbf = ubf;
13265     if (!((sts = sys$connect(&rab_out)) & 1)) {
13266       sys$close(&fab_in); sys$close(&fab_out);
13267       PerlMem_free(vmsin);
13268       PerlMem_free(vmsout);
13269       PerlMem_free(ubf);
13270       PerlMem_free(esa);
13271       if (esal != NULL)
13272           PerlMem_free(esal);
13273       PerlMem_free(rsa);
13274       if (rsal != NULL)
13275           PerlMem_free(rsal);
13276       PerlMem_free(esa_out);
13277       if (esal_out != NULL)
13278           PerlMem_free(esal_out);
13279       PerlMem_free(rsa_out);
13280       if (rsal_out != NULL)
13281           PerlMem_free(rsal_out);
13282       set_errno(EVMSERR); set_vaxc_errno(sts);
13283       return 0;
13284     }
13285
13286     while ((sts = sys$read(&rab_in))) {  /* always true  */
13287       if (sts == RMS$_EOF) break;
13288       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
13289       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
13290         sys$close(&fab_in); sys$close(&fab_out);
13291         PerlMem_free(vmsin);
13292         PerlMem_free(vmsout);
13293         PerlMem_free(ubf);
13294         PerlMem_free(esa);
13295         if (esal != NULL)
13296             PerlMem_free(esal);
13297         PerlMem_free(rsa);
13298         if (rsal != NULL)
13299             PerlMem_free(rsal);
13300         PerlMem_free(esa_out);
13301         if (esal_out != NULL)
13302             PerlMem_free(esal_out);
13303         PerlMem_free(rsa_out);
13304         if (rsal_out != NULL)
13305             PerlMem_free(rsal_out);
13306         set_errno(EVMSERR); set_vaxc_errno(sts);
13307         return 0;
13308       }
13309     }
13310
13311
13312     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
13313     sys$close(&fab_in);  sys$close(&fab_out);
13314     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
13315
13316     PerlMem_free(vmsin);
13317     PerlMem_free(vmsout);
13318     PerlMem_free(ubf);
13319     PerlMem_free(esa);
13320     if (esal != NULL)
13321         PerlMem_free(esal);
13322     PerlMem_free(rsa);
13323     if (rsal != NULL)
13324         PerlMem_free(rsal);
13325     PerlMem_free(esa_out);
13326     if (esal_out != NULL)
13327         PerlMem_free(esal_out);
13328     PerlMem_free(rsa_out);
13329     if (rsal_out != NULL)
13330         PerlMem_free(rsal_out);
13331
13332     if (!(sts & 1)) {
13333       set_errno(EVMSERR); set_vaxc_errno(sts);
13334       return 0;
13335     }
13336
13337     return 1;
13338
13339 }  /* end of rmscopy() */
13340 /*}}}*/
13341
13342
13343 /***  The following glue provides 'hooks' to make some of the routines
13344  * from this file available from Perl.  These routines are sufficiently
13345  * basic, and are required sufficiently early in the build process,
13346  * that's it's nice to have them available to miniperl as well as the
13347  * full Perl, so they're set up here instead of in an extension.  The
13348  * Perl code which handles importation of these names into a given
13349  * package lives in [.VMS]Filespec.pm in @INC.
13350  */
13351
13352 void
13353 rmsexpand_fromperl(pTHX_ CV *cv)
13354 {
13355   dXSARGS;
13356   char *fspec, *defspec = NULL, *rslt;
13357   STRLEN n_a;
13358   int fs_utf8, dfs_utf8;
13359
13360   fs_utf8 = 0;
13361   dfs_utf8 = 0;
13362   if (!items || items > 2)
13363     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
13364   fspec = SvPV(ST(0),n_a);
13365   fs_utf8 = SvUTF8(ST(0));
13366   if (!fspec || !*fspec) XSRETURN_UNDEF;
13367   if (items == 2) {
13368     defspec = SvPV(ST(1),n_a);
13369     dfs_utf8 = SvUTF8(ST(1));
13370   }
13371   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
13372   ST(0) = sv_newmortal();
13373   if (rslt != NULL) {
13374     sv_usepvn(ST(0),rslt,strlen(rslt));
13375     if (fs_utf8) {
13376         SvUTF8_on(ST(0));
13377     }
13378   }
13379   XSRETURN(1);
13380 }
13381
13382 void
13383 vmsify_fromperl(pTHX_ CV *cv)
13384 {
13385   dXSARGS;
13386   char *vmsified;
13387   STRLEN n_a;
13388   int utf8_fl;
13389
13390   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
13391   utf8_fl = SvUTF8(ST(0));
13392   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13393   ST(0) = sv_newmortal();
13394   if (vmsified != NULL) {
13395     sv_usepvn(ST(0),vmsified,strlen(vmsified));
13396     if (utf8_fl) {
13397         SvUTF8_on(ST(0));
13398     }
13399   }
13400   XSRETURN(1);
13401 }
13402
13403 void
13404 unixify_fromperl(pTHX_ CV *cv)
13405 {
13406   dXSARGS;
13407   char *unixified;
13408   STRLEN n_a;
13409   int utf8_fl;
13410
13411   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
13412   utf8_fl = SvUTF8(ST(0));
13413   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13414   ST(0) = sv_newmortal();
13415   if (unixified != NULL) {
13416     sv_usepvn(ST(0),unixified,strlen(unixified));
13417     if (utf8_fl) {
13418         SvUTF8_on(ST(0));
13419     }
13420   }
13421   XSRETURN(1);
13422 }
13423
13424 void
13425 fileify_fromperl(pTHX_ CV *cv)
13426 {
13427   dXSARGS;
13428   char *fileified;
13429   STRLEN n_a;
13430   int utf8_fl;
13431
13432   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
13433   utf8_fl = SvUTF8(ST(0));
13434   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13435   ST(0) = sv_newmortal();
13436   if (fileified != NULL) {
13437     sv_usepvn(ST(0),fileified,strlen(fileified));
13438     if (utf8_fl) {
13439         SvUTF8_on(ST(0));
13440     }
13441   }
13442   XSRETURN(1);
13443 }
13444
13445 void
13446 pathify_fromperl(pTHX_ CV *cv)
13447 {
13448   dXSARGS;
13449   char *pathified;
13450   STRLEN n_a;
13451   int utf8_fl;
13452
13453   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
13454   utf8_fl = SvUTF8(ST(0));
13455   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13456   ST(0) = sv_newmortal();
13457   if (pathified != NULL) {
13458     sv_usepvn(ST(0),pathified,strlen(pathified));
13459     if (utf8_fl) {
13460         SvUTF8_on(ST(0));
13461     }
13462   }
13463   XSRETURN(1);
13464 }
13465
13466 void
13467 vmspath_fromperl(pTHX_ CV *cv)
13468 {
13469   dXSARGS;
13470   char *vmspath;
13471   STRLEN n_a;
13472   int utf8_fl;
13473
13474   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
13475   utf8_fl = SvUTF8(ST(0));
13476   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13477   ST(0) = sv_newmortal();
13478   if (vmspath != NULL) {
13479     sv_usepvn(ST(0),vmspath,strlen(vmspath));
13480     if (utf8_fl) {
13481         SvUTF8_on(ST(0));
13482     }
13483   }
13484   XSRETURN(1);
13485 }
13486
13487 void
13488 unixpath_fromperl(pTHX_ CV *cv)
13489 {
13490   dXSARGS;
13491   char *unixpath;
13492   STRLEN n_a;
13493   int utf8_fl;
13494
13495   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
13496   utf8_fl = SvUTF8(ST(0));
13497   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13498   ST(0) = sv_newmortal();
13499   if (unixpath != NULL) {
13500     sv_usepvn(ST(0),unixpath,strlen(unixpath));
13501     if (utf8_fl) {
13502         SvUTF8_on(ST(0));
13503     }
13504   }
13505   XSRETURN(1);
13506 }
13507
13508 void
13509 candelete_fromperl(pTHX_ CV *cv)
13510 {
13511   dXSARGS;
13512   char *fspec, *fsp;
13513   SV *mysv;
13514   IO *io;
13515   STRLEN n_a;
13516
13517   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
13518
13519   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13520   Newx(fspec, VMS_MAXRSS, char);
13521   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
13522   if (SvTYPE(mysv) == SVt_PVGV) {
13523     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
13524       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13525       ST(0) = &PL_sv_no;
13526       Safefree(fspec);
13527       XSRETURN(1);
13528     }
13529     fsp = fspec;
13530   }
13531   else {
13532     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
13533       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13534       ST(0) = &PL_sv_no;
13535       Safefree(fspec);
13536       XSRETURN(1);
13537     }
13538   }
13539
13540   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
13541   Safefree(fspec);
13542   XSRETURN(1);
13543 }
13544
13545 void
13546 rmscopy_fromperl(pTHX_ CV *cv)
13547 {
13548   dXSARGS;
13549   char *inspec, *outspec, *inp, *outp;
13550   int date_flag;
13551   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
13552                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13553   unsigned long int sts;
13554   SV *mysv;
13555   IO *io;
13556   STRLEN n_a;
13557
13558   if (items < 2 || items > 3)
13559     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
13560
13561   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13562   Newx(inspec, VMS_MAXRSS, char);
13563   if (SvTYPE(mysv) == SVt_PVGV) {
13564     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
13565       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13566       ST(0) = &PL_sv_no;
13567       Safefree(inspec);
13568       XSRETURN(1);
13569     }
13570     inp = inspec;
13571   }
13572   else {
13573     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
13574       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13575       ST(0) = &PL_sv_no;
13576       Safefree(inspec);
13577       XSRETURN(1);
13578     }
13579   }
13580   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
13581   Newx(outspec, VMS_MAXRSS, char);
13582   if (SvTYPE(mysv) == SVt_PVGV) {
13583     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
13584       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13585       ST(0) = &PL_sv_no;
13586       Safefree(inspec);
13587       Safefree(outspec);
13588       XSRETURN(1);
13589     }
13590     outp = outspec;
13591   }
13592   else {
13593     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
13594       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13595       ST(0) = &PL_sv_no;
13596       Safefree(inspec);
13597       Safefree(outspec);
13598       XSRETURN(1);
13599     }
13600   }
13601   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
13602
13603   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
13604   Safefree(inspec);
13605   Safefree(outspec);
13606   XSRETURN(1);
13607 }
13608
13609 /* The mod2fname is limited to shorter filenames by design, so it should
13610  * not be modified to support longer EFS pathnames
13611  */
13612 void
13613 mod2fname(pTHX_ CV *cv)
13614 {
13615   dXSARGS;
13616   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13617        workbuff[NAM$C_MAXRSS*1 + 1];
13618   int total_namelen = 3, counter, num_entries;
13619   /* ODS-5 ups this, but we want to be consistent, so... */
13620   int max_name_len = 39;
13621   AV *in_array = (AV *)SvRV(ST(0));
13622
13623   num_entries = av_len(in_array);
13624
13625   /* All the names start with PL_. */
13626   strcpy(ultimate_name, "PL_");
13627
13628   /* Clean up our working buffer */
13629   Zero(work_name, sizeof(work_name), char);
13630
13631   /* Run through the entries and build up a working name */
13632   for(counter = 0; counter <= num_entries; counter++) {
13633     /* If it's not the first name then tack on a __ */
13634     if (counter) {
13635       strcat(work_name, "__");
13636     }
13637     strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
13638   }
13639
13640   /* Check to see if we actually have to bother...*/
13641   if (strlen(work_name) + 3 <= max_name_len) {
13642     strcat(ultimate_name, work_name);
13643   } else {
13644     /* It's too darned big, so we need to go strip. We use the same */
13645     /* algorithm as xsubpp does. First, strip out doubled __ */
13646     char *source, *dest, last;
13647     dest = workbuff;
13648     last = 0;
13649     for (source = work_name; *source; source++) {
13650       if (last == *source && last == '_') {
13651         continue;
13652       }
13653       *dest++ = *source;
13654       last = *source;
13655     }
13656     /* Go put it back */
13657     strcpy(work_name, workbuff);
13658     /* Is it still too big? */
13659     if (strlen(work_name) + 3 > max_name_len) {
13660       /* Strip duplicate letters */
13661       last = 0;
13662       dest = workbuff;
13663       for (source = work_name; *source; source++) {
13664         if (last == toupper(*source)) {
13665         continue;
13666         }
13667         *dest++ = *source;
13668         last = toupper(*source);
13669       }
13670       strcpy(work_name, workbuff);
13671     }
13672
13673     /* Is it *still* too big? */
13674     if (strlen(work_name) + 3 > max_name_len) {
13675       /* Too bad, we truncate */
13676       work_name[max_name_len - 2] = 0;
13677     }
13678     strcat(ultimate_name, work_name);
13679   }
13680
13681   /* Okay, return it */
13682   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13683   XSRETURN(1);
13684 }
13685
13686 void
13687 hushexit_fromperl(pTHX_ CV *cv)
13688 {
13689     dXSARGS;
13690
13691     if (items > 0) {
13692         VMSISH_HUSHED = SvTRUE(ST(0));
13693     }
13694     ST(0) = boolSV(VMSISH_HUSHED);
13695     XSRETURN(1);
13696 }
13697
13698
13699 PerlIO *
13700 Perl_vms_start_glob
13701    (pTHX_ SV *tmpglob,
13702     IO *io)
13703 {
13704     PerlIO *fp;
13705     struct vs_str_st *rslt;
13706     char *vmsspec;
13707     char *rstr;
13708     char *begin, *cp;
13709     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13710     PerlIO *tmpfp;
13711     STRLEN i;
13712     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13713     struct dsc$descriptor_vs rsdsc;
13714     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13715     unsigned long hasver = 0, isunix = 0;
13716     unsigned long int lff_flags = 0;
13717     int rms_sts;
13718     int vms_old_glob = 1;
13719
13720     if (!SvOK(tmpglob)) {
13721         SETERRNO(ENOENT,RMS$_FNF);
13722         return NULL;
13723     }
13724
13725     vms_old_glob = !decc_filename_unix_report;
13726
13727 #ifdef VMS_LONGNAME_SUPPORT
13728     lff_flags = LIB$M_FIL_LONG_NAMES;
13729 #endif
13730     /* The Newx macro will not allow me to assign a smaller array
13731      * to the rslt pointer, so we will assign it to the begin char pointer
13732      * and then copy the value into the rslt pointer.
13733      */
13734     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13735     rslt = (struct vs_str_st *)begin;
13736     rslt->length = 0;
13737     rstr = &rslt->str[0];
13738     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13739     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13740     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13741     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13742
13743     Newx(vmsspec, VMS_MAXRSS, char);
13744
13745         /* We could find out if there's an explicit dev/dir or version
13746            by peeking into lib$find_file's internal context at
13747            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13748            but that's unsupported, so I don't want to do it now and
13749            have it bite someone in the future. */
13750         /* Fix-me: vms_split_path() is the only way to do this, the
13751            existing method will fail with many legal EFS or UNIX specifications
13752          */
13753
13754     cp = SvPV(tmpglob,i);
13755
13756     for (; i; i--) {
13757         if (cp[i] == ';') hasver = 1;
13758         if (cp[i] == '.') {
13759             if (sts) hasver = 1;
13760             else sts = 1;
13761         }
13762         if (cp[i] == '/') {
13763             hasdir = isunix = 1;
13764             break;
13765         }
13766         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13767             hasdir = 1;
13768             break;
13769         }
13770     }
13771
13772     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13773     if ((hasdir == 0) && decc_filename_unix_report) {
13774         isunix = 1;
13775     }
13776
13777     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13778         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13779         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13780         int wildstar = 0;
13781         int wildquery = 0;
13782         int found = 0;
13783         Stat_t st;
13784         int stat_sts;
13785         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13786         if (!stat_sts && S_ISDIR(st.st_mode)) {
13787             char * vms_dir;
13788             const char * fname;
13789             STRLEN fname_len;
13790
13791             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13792             /* path delimiter of ':>]', if so, then the old behavior has */
13793             /* obviously been specificially requested */
13794
13795             fname = SvPVX_const(tmpglob);
13796             fname_len = strlen(fname);
13797             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13798             if (vms_old_glob || (vms_dir != NULL)) {
13799                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13800                                             SvPVX(tmpglob),vmsspec,NULL);
13801                 ok = (wilddsc.dsc$a_pointer != NULL);
13802                 /* maybe passed 'foo' rather than '[.foo]', thus not
13803                    detected above */
13804                 hasdir = 1;
13805             } else {
13806                 /* Operate just on the directory, the special stat/fstat for */
13807                 /* leaves the fileified  specification in the st_devnam */
13808                 /* member. */
13809                 wilddsc.dsc$a_pointer = st.st_devnam;
13810                 ok = 1;
13811             }
13812         }
13813         else {
13814             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13815             ok = (wilddsc.dsc$a_pointer != NULL);
13816         }
13817         if (ok)
13818             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13819
13820         /* If not extended character set, replace ? with % */
13821         /* With extended character set, ? is a wildcard single character */
13822         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13823             if (*cp == '?') {
13824                 wildquery = 1;
13825                 if (!decc_efs_case_preserve)
13826                     *cp = '%';
13827             } else if (*cp == '%') {
13828                 wildquery = 1;
13829             } else if (*cp == '*') {
13830                 wildstar = 1;
13831             }
13832         }
13833
13834         if (ok) {
13835             wv_sts = vms_split_path(
13836                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13837                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13838                 &wvs_spec, &wvs_len);
13839         } else {
13840             wn_spec = NULL;
13841             wn_len = 0;
13842             we_spec = NULL;
13843             we_len = 0;
13844         }
13845
13846         sts = SS$_NORMAL;
13847         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13848          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13849          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13850          int valid_find;
13851
13852             valid_find = 0;
13853             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13854                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13855             if (!$VMS_STATUS_SUCCESS(sts))
13856                 break;
13857
13858             /* with varying string, 1st word of buffer contains result length */
13859             rstr[rslt->length] = '\0';
13860
13861              /* Find where all the components are */
13862              v_sts = vms_split_path
13863                        (rstr,
13864                         &v_spec,
13865                         &v_len,
13866                         &r_spec,
13867                         &r_len,
13868                         &d_spec,
13869                         &d_len,
13870                         &n_spec,
13871                         &n_len,
13872                         &e_spec,
13873                         &e_len,
13874                         &vs_spec,
13875                         &vs_len);
13876
13877             /* If no version on input, truncate the version on output */
13878             if (!hasver && (vs_len > 0)) {
13879                 *vs_spec = '\0';
13880                 vs_len = 0;
13881             }
13882
13883             if (isunix) {
13884
13885                 /* In Unix report mode, remove the ".dir;1" from the name */
13886                 /* if it is a real directory */
13887                 if (decc_filename_unix_report || decc_efs_charset) {
13888                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13889                         Stat_t statbuf;
13890                         int ret_sts;
13891
13892                         ret_sts = flex_lstat(rstr, &statbuf);
13893                         if ((ret_sts == 0) &&
13894                             S_ISDIR(statbuf.st_mode)) {
13895                             e_len = 0;
13896                             e_spec[0] = 0;
13897                         }
13898                     }
13899                 }
13900
13901                 /* No version & a null extension on UNIX handling */
13902                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13903                     e_len = 0;
13904                     *e_spec = '\0';
13905                 }
13906             }
13907
13908             if (!decc_efs_case_preserve) {
13909                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13910             }
13911
13912             /* Find File treats a Null extension as return all extensions */
13913             /* This is contrary to Perl expectations */
13914
13915             if (wildstar || wildquery || vms_old_glob) {
13916                 /* really need to see if the returned file name matched */
13917                 /* but for now will assume that it matches */
13918                 valid_find = 1;
13919             } else {
13920                 /* Exact Match requested */
13921                 /* How are directories handled? - like a file */
13922                 if ((e_len == we_len) && (n_len == wn_len)) {
13923                     int t1;
13924                     t1 = e_len;
13925                     if (t1 > 0)
13926                         t1 = strncmp(e_spec, we_spec, e_len);
13927                     if (t1 == 0) {
13928                        t1 = n_len;
13929                        if (t1 > 0)
13930                            t1 = strncmp(n_spec, we_spec, n_len);
13931                        if (t1 == 0)
13932                            valid_find = 1;
13933                     }
13934                 }
13935             }
13936
13937             if (valid_find) {
13938                 found++;
13939
13940                 if (hasdir) {
13941                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13942                     begin = rstr;
13943                 }
13944                 else {
13945                     /* Start with the name */
13946                     begin = n_spec;
13947                 }
13948                 strcat(begin,"\n");
13949                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13950             }
13951         }
13952         if (cxt) (void)lib$find_file_end(&cxt);
13953
13954         if (!found) {
13955             /* Be POSIXish: return the input pattern when no matches */
13956             strcpy(rstr,SvPVX(tmpglob));
13957             strcat(rstr,"\n");
13958             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13959         }
13960
13961         if (ok && sts != RMS$_NMF &&
13962             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13963         if (!ok) {
13964             if (!(sts & 1)) {
13965                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13966             }
13967             PerlIO_close(tmpfp);
13968             fp = NULL;
13969         }
13970         else {
13971             PerlIO_rewind(tmpfp);
13972             IoTYPE(io) = IoTYPE_RDONLY;
13973             IoIFP(io) = fp = tmpfp;
13974             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13975         }
13976     }
13977     Safefree(vmsspec);
13978     Safefree(rslt);
13979     return fp;
13980 }
13981
13982
13983 static char *
13984 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13985                    int *utf8_fl);
13986
13987 void
13988 unixrealpath_fromperl(pTHX_ CV *cv)
13989 {
13990     dXSARGS;
13991     char *fspec, *rslt_spec, *rslt;
13992     STRLEN n_a;
13993
13994     if (!items || items != 1)
13995         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13996
13997     fspec = SvPV(ST(0),n_a);
13998     if (!fspec || !*fspec) XSRETURN_UNDEF;
13999
14000     Newx(rslt_spec, VMS_MAXRSS + 1, char);
14001     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
14002
14003     ST(0) = sv_newmortal();
14004     if (rslt != NULL)
14005         sv_usepvn(ST(0),rslt,strlen(rslt));
14006     else
14007         Safefree(rslt_spec);
14008         XSRETURN(1);
14009 }
14010
14011 static char *
14012 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
14013                    int *utf8_fl);
14014
14015 void
14016 vmsrealpath_fromperl(pTHX_ CV *cv)
14017 {
14018     dXSARGS;
14019     char *fspec, *rslt_spec, *rslt;
14020     STRLEN n_a;
14021
14022     if (!items || items != 1)
14023         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
14024
14025     fspec = SvPV(ST(0),n_a);
14026     if (!fspec || !*fspec) XSRETURN_UNDEF;
14027
14028     Newx(rslt_spec, VMS_MAXRSS + 1, char);
14029     rslt = do_vms_realname(fspec, rslt_spec, NULL);
14030
14031     ST(0) = sv_newmortal();
14032     if (rslt != NULL)
14033         sv_usepvn(ST(0),rslt,strlen(rslt));
14034     else
14035         Safefree(rslt_spec);
14036         XSRETURN(1);
14037 }
14038
14039 #ifdef HAS_SYMLINK
14040 /*
14041  * A thin wrapper around decc$symlink to make sure we follow the
14042  * standard and do not create a symlink with a zero-length name.
14043  *
14044  * Also in ODS-2 mode, existing tests assume that the link target
14045  * will be converted to UNIX format.
14046  */
14047 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
14048 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
14049   if (!link_name || !*link_name) {
14050     SETERRNO(ENOENT, SS$_NOSUCHFILE);
14051     return -1;
14052   }
14053
14054   if (decc_efs_charset) {
14055       return symlink(contents, link_name);
14056   } else {
14057       int sts;
14058       char * utarget;
14059
14060       /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
14061       /* because in order to work, the symlink target must be in UNIX format */
14062
14063       /* As symbolic links can hold things other than files, we will only do */
14064       /* the conversion in in ODS-2 mode */
14065
14066       utarget = PerlMem_malloc(VMS_MAXRSS + 1);
14067       if (int_tounixspec(contents, utarget, NULL) == NULL) {
14068
14069           /* This should not fail, as an untranslatable filename */
14070           /* should be passed through */
14071           utarget = (char *)contents;
14072       }
14073       sts = symlink(utarget, link_name);
14074       PerlMem_free(utarget);
14075       return sts;
14076   }
14077
14078 }
14079 /*}}}*/
14080
14081 #endif /* HAS_SYMLINK */
14082
14083 int do_vms_case_tolerant(void);
14084
14085 void
14086 case_tolerant_process_fromperl(pTHX_ CV *cv)
14087 {
14088   dXSARGS;
14089   ST(0) = boolSV(do_vms_case_tolerant());
14090   XSRETURN(1);
14091 }
14092
14093 #ifdef USE_ITHREADS
14094
14095 void
14096 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
14097                           struct interp_intern *dst)
14098 {
14099     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
14100
14101     memcpy(dst,src,sizeof(struct interp_intern));
14102 }
14103
14104 #endif
14105
14106 void
14107 Perl_sys_intern_clear(pTHX)
14108 {
14109 }
14110
14111 void
14112 Perl_sys_intern_init(pTHX)
14113 {
14114     unsigned int ix = RAND_MAX;
14115     double x;
14116
14117     VMSISH_HUSHED = 0;
14118
14119     MY_POSIX_EXIT = vms_posix_exit;
14120
14121     x = (float)ix;
14122     MY_INV_RAND_MAX = 1./x;
14123 }
14124
14125 void
14126 init_os_extras(void)
14127 {
14128   dTHX;
14129   char* file = __FILE__;
14130   if (decc_disable_to_vms_logname_translation) {
14131     no_translate_barewords = TRUE;
14132   } else {
14133     no_translate_barewords = FALSE;
14134   }
14135
14136   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
14137   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
14138   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
14139   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
14140   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
14141   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
14142   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
14143   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
14144   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
14145   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
14146   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
14147   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
14148   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
14149   newXSproto("VMS::Filespec::case_tolerant_process",
14150       case_tolerant_process_fromperl,file,"");
14151
14152   store_pipelocs(aTHX);         /* will redo any earlier attempts */
14153
14154   return;
14155 }
14156
14157 #if __CRTL_VER == 80200000
14158 /* This missed getting in to the DECC SDK for 8.2 */
14159 char *realpath(const char *file_name, char * resolved_name, ...);
14160 #endif
14161
14162 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
14163 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
14164  * The perl fallback routine to provide realpath() is not as efficient
14165  * on OpenVMS.
14166  */
14167
14168 /* Hack, use old stat() as fastest way of getting ino_t and device */
14169 int decc$stat(const char *name, void * statbuf);
14170 #if !defined(__VAX) && __CRTL_VER >= 80200000
14171 int decc$lstat(const char *name, void * statbuf);
14172 #else
14173 #define decc$lstat decc$stat
14174 #endif
14175
14176
14177 /* Realpath is fragile.  In 8.3 it does not work if the feature
14178  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
14179  * links are implemented in RMS, not the CRTL. It also can fail if the
14180  * user does not have read/execute access to some of the directories.
14181  * So in order for Do What I Mean mode to work, if realpath() fails,
14182  * fall back to looking up the filename by the device name and FID.
14183  */
14184
14185 int vms_fid_to_name(char * outname, int outlen,
14186                     const char * name, int lstat_flag, mode_t * mode)
14187 {
14188 #pragma message save
14189 #pragma message disable MISALGNDSTRCT
14190 #pragma message disable MISALGNDMEM
14191 #pragma member_alignment save
14192 #pragma nomember_alignment
14193 struct statbuf_t {
14194     char           * st_dev;
14195     unsigned short st_ino[3];
14196     unsigned short old_st_mode;
14197     unsigned long  padl[30];  /* plenty of room */
14198 } statbuf;
14199 #pragma message restore
14200 #pragma member_alignment restore
14201
14202     int sts;
14203     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14204     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14205     char *fileified;
14206     char *temp_fspec;
14207     char *ret_spec;
14208
14209     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
14210      * unexpected answers
14211      */
14212
14213     fileified = PerlMem_malloc(VMS_MAXRSS);
14214     if (fileified == NULL)
14215         _ckvmssts_noperl(SS$_INSFMEM);
14216
14217     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
14218     if (temp_fspec == NULL)
14219         _ckvmssts_noperl(SS$_INSFMEM);
14220
14221     sts = -1;
14222     /* First need to try as a directory */
14223     ret_spec = int_tovmspath(name, temp_fspec, NULL);
14224     if (ret_spec != NULL) {
14225         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
14226         if (ret_spec != NULL) {
14227             if (lstat_flag == 0)
14228                 sts = decc$stat(fileified, &statbuf);
14229             else
14230                 sts = decc$lstat(fileified, &statbuf);
14231         }
14232     }
14233
14234     /* Then as a VMS file spec */
14235     if (sts != 0) {
14236         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
14237         if (ret_spec != NULL) {
14238             if (lstat_flag == 0) {
14239                 sts = decc$stat(temp_fspec, &statbuf);
14240             } else {
14241                 sts = decc$lstat(temp_fspec, &statbuf);
14242             }
14243         }
14244     }
14245
14246     if (sts) {
14247         /* Next try - allow multiple dots with out EFS CHARSET */
14248         /* The CRTL stat() falls down hard on multi-dot filenames in unix
14249          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
14250          * enable it if it isn't already.
14251          */
14252 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14253         if (!decc_efs_charset && (decc_efs_charset_index > 0))
14254             decc$feature_set_value(decc_efs_charset_index, 1, 1);
14255 #endif
14256         ret_spec = int_tovmspath(name, temp_fspec, NULL);
14257         if (lstat_flag == 0) {
14258             sts = decc$stat(name, &statbuf);
14259         } else {
14260             sts = decc$lstat(name, &statbuf);
14261         }
14262 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14263         if (!decc_efs_charset && (decc_efs_charset_index > 0))
14264             decc$feature_set_value(decc_efs_charset_index, 1, 0);
14265 #endif
14266     }
14267
14268
14269     /* and then because the Perl Unix to VMS conversion is not perfect */
14270     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
14271     /* characters from filenames so we need to try it as-is */
14272     if (sts) {
14273         if (lstat_flag == 0) {
14274             sts = decc$stat(name, &statbuf);
14275         } else {
14276             sts = decc$lstat(name, &statbuf);
14277         }
14278     }
14279
14280     if (sts == 0) {
14281         int vms_sts;
14282
14283         dvidsc.dsc$a_pointer=statbuf.st_dev;
14284         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
14285
14286         specdsc.dsc$a_pointer = outname;
14287         specdsc.dsc$w_length = outlen-1;
14288
14289         vms_sts = lib$fid_to_name
14290             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
14291         if ($VMS_STATUS_SUCCESS(vms_sts)) {
14292             outname[specdsc.dsc$w_length] = 0;
14293
14294             /* Return the mode */
14295             if (mode) {
14296                 *mode = statbuf.old_st_mode;
14297             }
14298             return 0;
14299         }
14300     }
14301     return sts;
14302 }
14303
14304
14305
14306 static char *
14307 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
14308                    int *utf8_fl)
14309 {
14310     char * rslt = NULL;
14311
14312 #ifdef HAS_SYMLINK
14313     if (decc_posix_compliant_pathnames > 0 ) {
14314         /* realpath currently only works if posix compliant pathnames are
14315          * enabled.  It may start working when they are not, but in that
14316          * case we still want the fallback behavior for backwards compatibility
14317          */
14318         rslt = realpath(filespec, outbuf);
14319     }
14320 #endif
14321
14322     if (rslt == NULL) {
14323         char * vms_spec;
14324         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14325         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14326         int file_len;
14327         mode_t my_mode;
14328
14329         /* Fall back to fid_to_name */
14330
14331         Newx(vms_spec, VMS_MAXRSS + 1, char);
14332
14333         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
14334         if (sts == 0) {
14335
14336
14337             /* Now need to trim the version off */
14338             sts = vms_split_path
14339                   (vms_spec,
14340                    &v_spec,
14341                    &v_len,
14342                    &r_spec,
14343                    &r_len,
14344                    &d_spec,
14345                    &d_len,
14346                    &n_spec,
14347                    &n_len,
14348                    &e_spec,
14349                    &e_len,
14350                    &vs_spec,
14351                    &vs_len);
14352
14353
14354                 if (sts == 0) {
14355                     int haslower = 0;
14356                     const char *cp;
14357
14358                     /* Trim off the version */
14359                     int file_len = v_len + r_len + d_len + n_len + e_len;
14360                     vms_spec[file_len] = 0;
14361
14362                     /* The result is expected to be in UNIX format */
14363                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
14364
14365                     /* Downcase if input had any lower case letters and
14366                      * case preservation is not in effect.
14367                      */
14368                     if (!decc_efs_case_preserve) {
14369                         for (cp = filespec; *cp; cp++)
14370                             if (islower(*cp)) { haslower = 1; break; }
14371
14372                         if (haslower) __mystrtolower(rslt);
14373                     }
14374                 }
14375         } else {
14376
14377             /* Now for some hacks to deal with backwards and forward */
14378             /* compatibilty */
14379             if (!decc_efs_charset) {
14380
14381                 /* 1. ODS-2 mode wants to do a syntax only translation */
14382                 rslt = int_rmsexpand(filespec, outbuf,
14383                                     NULL, 0, NULL, utf8_fl);
14384
14385             } else {
14386                 if (decc_filename_unix_report) {
14387                     char * dir_name;
14388                     char * vms_dir_name;
14389                     char * file_name;
14390
14391                     /* 2. ODS-5 / UNIX report mode should return a failure */
14392                     /*    if the parent directory also does not exist */
14393                     /*    Otherwise, get the real path for the parent */
14394                     /*    and add the child to it.
14395
14396                     /* basename / dirname only available for VMS 7.0+ */
14397                     /* So we may need to implement them as common routines */
14398
14399                     Newx(dir_name, VMS_MAXRSS + 1, char);
14400                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
14401                     dir_name[0] = '\0';
14402                     file_name = NULL;
14403
14404                     /* First try a VMS parse */
14405                     sts = vms_split_path
14406                           (filespec,
14407                            &v_spec,
14408                            &v_len,
14409                            &r_spec,
14410                            &r_len,
14411                            &d_spec,
14412                            &d_len,
14413                            &n_spec,
14414                            &n_len,
14415                            &e_spec,
14416                            &e_len,
14417                            &vs_spec,
14418                            &vs_len);
14419
14420                     if (sts == 0) {
14421                         /* This is VMS */
14422
14423                         int dir_len = v_len + r_len + d_len + n_len;
14424                         if (dir_len > 0) {
14425                            strncpy(dir_name, filespec, dir_len);
14426                            dir_name[dir_len] = '\0';
14427                            file_name = (char *)&filespec[dir_len + 1];
14428                         }
14429                     } else {
14430                         /* This must be UNIX */
14431                         char * tchar;
14432
14433                         tchar = strrchr(filespec, '/');
14434
14435                         if (tchar != NULL) {
14436                             int dir_len = tchar - filespec;
14437                             strncpy(dir_name, filespec, dir_len);
14438                             dir_name[dir_len] = '\0';
14439                             file_name = (char *) &filespec[dir_len + 1];
14440                         }
14441                     }
14442
14443                     /* Dir name is defaulted */
14444                     if (dir_name[0] == 0) {
14445                         dir_name[0] = '.';
14446                         dir_name[1] = '\0';
14447                     }
14448
14449                     /* Need realpath for the directory */
14450                     sts = vms_fid_to_name(vms_dir_name,
14451                                           VMS_MAXRSS + 1,
14452                                           dir_name, 0, NULL);
14453
14454                     if (sts == 0) {
14455                         /* Now need to pathify it.
14456                         char *tdir = int_pathify_dirspec(vms_dir_name,
14457                                                          outbuf);
14458
14459                         /* And now add the original filespec to it */
14460                         if (file_name != NULL) {
14461                             strcat(outbuf, file_name);
14462                         }
14463                         return outbuf;
14464                     }
14465                     Safefree(vms_dir_name);
14466                     Safefree(dir_name);
14467                 }
14468             }
14469         }
14470         Safefree(vms_spec);
14471     }
14472     return rslt;
14473 }
14474
14475 static char *
14476 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
14477                    int *utf8_fl)
14478 {
14479     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14480     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14481     int file_len;
14482
14483     /* Fall back to fid_to_name */
14484
14485     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
14486     if (sts != 0) {
14487         return NULL;
14488     }
14489     else {
14490
14491
14492         /* Now need to trim the version off */
14493         sts = vms_split_path
14494                   (outbuf,
14495                    &v_spec,
14496                    &v_len,
14497                    &r_spec,
14498                    &r_len,
14499                    &d_spec,
14500                    &d_len,
14501                    &n_spec,
14502                    &n_len,
14503                    &e_spec,
14504                    &e_len,
14505                    &vs_spec,
14506                    &vs_len);
14507
14508
14509         if (sts == 0) {
14510             int haslower = 0;
14511             const char *cp;
14512
14513             /* Trim off the version */
14514             int file_len = v_len + r_len + d_len + n_len + e_len;
14515             outbuf[file_len] = 0;
14516
14517             /* Downcase if input had any lower case letters and
14518              * case preservation is not in effect.
14519              */
14520             if (!decc_efs_case_preserve) {
14521                 for (cp = filespec; *cp; cp++)
14522                     if (islower(*cp)) { haslower = 1; break; }
14523
14524                 if (haslower) __mystrtolower(outbuf);
14525             }
14526         }
14527     }
14528     return outbuf;
14529 }
14530
14531
14532 /*}}}*/
14533 /* External entry points */
14534 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14535 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
14536
14537 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14538 { return do_vms_realname(filespec, outbuf, utf8_fl); }
14539
14540 /* case_tolerant */
14541
14542 /*{{{int do_vms_case_tolerant(void)*/
14543 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
14544  * controlled by a process setting.
14545  */
14546 int do_vms_case_tolerant(void)
14547 {
14548     return vms_process_case_tolerant;
14549 }
14550 /*}}}*/
14551 /* External entry points */
14552 #if __CRTL_VER >= 70301000 && !defined(__VAX)
14553 int Perl_vms_case_tolerant(void)
14554 { return do_vms_case_tolerant(); }
14555 #else
14556 int Perl_vms_case_tolerant(void)
14557 { return vms_process_case_tolerant; }
14558 #endif
14559
14560
14561  /* Start of DECC RTL Feature handling */
14562
14563 static int sys_trnlnm
14564    (const char * logname,
14565     char * value,
14566     int value_len)
14567 {
14568     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
14569     const unsigned long attr = LNM$M_CASE_BLIND;
14570     struct dsc$descriptor_s name_dsc;
14571     int status;
14572     unsigned short result;
14573     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
14574                                 {0, 0, 0, 0}};
14575
14576     name_dsc.dsc$w_length = strlen(logname);
14577     name_dsc.dsc$a_pointer = (char *)logname;
14578     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14579     name_dsc.dsc$b_class = DSC$K_CLASS_S;
14580
14581     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
14582
14583     if ($VMS_STATUS_SUCCESS(status)) {
14584
14585          /* Null terminate and return the string */
14586         /*--------------------------------------*/
14587         value[result] = 0;
14588     }
14589
14590     return status;
14591 }
14592
14593 static int sys_crelnm
14594    (const char * logname,
14595     const char * value)
14596 {
14597     int ret_val;
14598     const char * proc_table = "LNM$PROCESS_TABLE";
14599     struct dsc$descriptor_s proc_table_dsc;
14600     struct dsc$descriptor_s logname_dsc;
14601     struct itmlst_3 item_list[2];
14602
14603     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
14604     proc_table_dsc.dsc$w_length = strlen(proc_table);
14605     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14606     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
14607
14608     logname_dsc.dsc$a_pointer = (char *) logname;
14609     logname_dsc.dsc$w_length = strlen(logname);
14610     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14611     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
14612
14613     item_list[0].buflen = strlen(value);
14614     item_list[0].itmcode = LNM$_STRING;
14615     item_list[0].bufadr = (char *)value;
14616     item_list[0].retlen = NULL;
14617
14618     item_list[1].buflen = 0;
14619     item_list[1].itmcode = 0;
14620
14621     ret_val = sys$crelnm
14622                        (NULL,
14623                         (const struct dsc$descriptor_s *)&proc_table_dsc,
14624                         (const struct dsc$descriptor_s *)&logname_dsc,
14625                         NULL,
14626                         (const struct item_list_3 *) item_list);
14627
14628     return ret_val;
14629 }
14630
14631 /* C RTL Feature settings */
14632
14633 static int set_features
14634    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
14635     int (* cli_routine)(void),  /* Not documented */
14636     void *image_info)           /* Not documented */
14637 {
14638     int status;
14639     int s;
14640     char* str;
14641     char val_str[10];
14642 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
14643     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
14644     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
14645     unsigned long case_perm;
14646     unsigned long case_image;
14647 #endif
14648
14649     /* Allow an exception to bring Perl into the VMS debugger */
14650     vms_debug_on_exception = 0;
14651     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
14652     if ($VMS_STATUS_SUCCESS(status)) {
14653        val_str[0] = _toupper(val_str[0]);
14654        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14655          vms_debug_on_exception = 1;
14656        else
14657          vms_debug_on_exception = 0;
14658     }
14659
14660     /* Debug unix/vms file translation routines */
14661     vms_debug_fileify = 0;
14662     status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14663     if ($VMS_STATUS_SUCCESS(status)) {
14664         val_str[0] = _toupper(val_str[0]);
14665         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14666             vms_debug_fileify = 1;
14667         else
14668             vms_debug_fileify = 0;
14669     }
14670
14671
14672     /* Historically PERL has been doing vmsify / stat differently than */
14673     /* the CRTL.  In particular, under some conditions the CRTL will   */
14674     /* remove some illegal characters like spaces from filenames       */
14675     /* resulting in some differences.  The stat()/lstat() wrapper has  */
14676     /* been reporting such file names as invalid and fails to stat them */
14677     /* fixing this bug so that stat()/lstat() accept these like the     */
14678     /* CRTL does will result in several tests failing.                  */
14679     /* This should really be fixed, but for now, set up a feature to    */
14680     /* enable it so that the impact can be studied.                     */
14681     vms_bug_stat_filename = 0;
14682     status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14683     if ($VMS_STATUS_SUCCESS(status)) {
14684         val_str[0] = _toupper(val_str[0]);
14685         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14686             vms_bug_stat_filename = 1;
14687         else
14688             vms_bug_stat_filename = 0;
14689     }
14690
14691
14692     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14693     vms_vtf7_filenames = 0;
14694     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14695     if ($VMS_STATUS_SUCCESS(status)) {
14696        val_str[0] = _toupper(val_str[0]);
14697        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14698          vms_vtf7_filenames = 1;
14699        else
14700          vms_vtf7_filenames = 0;
14701     }
14702
14703     /* unlink all versions on unlink() or rename() */
14704     vms_unlink_all_versions = 0;
14705     status = sys_trnlnm
14706         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14707     if ($VMS_STATUS_SUCCESS(status)) {
14708        val_str[0] = _toupper(val_str[0]);
14709        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14710          vms_unlink_all_versions = 1;
14711        else
14712          vms_unlink_all_versions = 0;
14713     }
14714
14715     /* Dectect running under GNV Bash or other UNIX like shell */
14716 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14717     gnv_unix_shell = 0;
14718     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14719     if ($VMS_STATUS_SUCCESS(status)) {
14720          gnv_unix_shell = 1;
14721          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14722          set_feature_default("DECC$EFS_CHARSET", 1);
14723          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14724          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14725          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14726          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14727          vms_unlink_all_versions = 1;
14728          vms_posix_exit = 1;
14729     }
14730 #endif
14731
14732     /* hacks to see if known bugs are still present for testing */
14733
14734     /* PCP mode requires creating /dev/null special device file */
14735     decc_bug_devnull = 0;
14736     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14737     if ($VMS_STATUS_SUCCESS(status)) {
14738        val_str[0] = _toupper(val_str[0]);
14739        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14740           decc_bug_devnull = 1;
14741        else
14742           decc_bug_devnull = 0;
14743     }
14744
14745     /* UNIX directory names with no paths are broken in a lot of places */
14746     decc_dir_barename = 1;
14747     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14748     if ($VMS_STATUS_SUCCESS(status)) {
14749       val_str[0] = _toupper(val_str[0]);
14750       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14751         decc_dir_barename = 1;
14752       else
14753         decc_dir_barename = 0;
14754     }
14755
14756 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14757     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14758     if (s >= 0) {
14759         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14760         if (decc_disable_to_vms_logname_translation < 0)
14761             decc_disable_to_vms_logname_translation = 0;
14762     }
14763
14764     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14765     if (s >= 0) {
14766         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14767         if (decc_efs_case_preserve < 0)
14768             decc_efs_case_preserve = 0;
14769     }
14770
14771     s = decc$feature_get_index("DECC$EFS_CHARSET");
14772     decc_efs_charset_index = s;
14773     if (s >= 0) {
14774         decc_efs_charset = decc$feature_get_value(s, 1);
14775         if (decc_efs_charset < 0)
14776             decc_efs_charset = 0;
14777     }
14778
14779     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14780     if (s >= 0) {
14781         decc_filename_unix_report = decc$feature_get_value(s, 1);
14782         if (decc_filename_unix_report > 0) {
14783             decc_filename_unix_report = 1;
14784             vms_posix_exit = 1;
14785         }
14786         else
14787             decc_filename_unix_report = 0;
14788     }
14789
14790     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14791     if (s >= 0) {
14792         decc_filename_unix_only = decc$feature_get_value(s, 1);
14793         if (decc_filename_unix_only > 0) {
14794             decc_filename_unix_only = 1;
14795         }
14796         else {
14797             decc_filename_unix_only = 0;
14798         }
14799     }
14800
14801     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14802     if (s >= 0) {
14803         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14804         if (decc_filename_unix_no_version < 0)
14805             decc_filename_unix_no_version = 0;
14806     }
14807
14808     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14809     if (s >= 0) {
14810         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14811         if (decc_readdir_dropdotnotype < 0)
14812             decc_readdir_dropdotnotype = 0;
14813     }
14814
14815 #if __CRTL_VER >= 80200000
14816     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14817     if (s >= 0) {
14818         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14819         if (decc_posix_compliant_pathnames < 0)
14820             decc_posix_compliant_pathnames = 0;
14821         if (decc_posix_compliant_pathnames > 4)
14822             decc_posix_compliant_pathnames = 0;
14823     }
14824
14825 #endif
14826 #else
14827     status = sys_trnlnm
14828         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14829     if ($VMS_STATUS_SUCCESS(status)) {
14830         val_str[0] = _toupper(val_str[0]);
14831         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14832            decc_disable_to_vms_logname_translation = 1;
14833         }
14834     }
14835
14836 #ifndef __VAX
14837     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14838     if ($VMS_STATUS_SUCCESS(status)) {
14839         val_str[0] = _toupper(val_str[0]);
14840         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14841            decc_efs_case_preserve = 1;
14842         }
14843     }
14844 #endif
14845
14846     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14847     if ($VMS_STATUS_SUCCESS(status)) {
14848         val_str[0] = _toupper(val_str[0]);
14849         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14850            decc_filename_unix_report = 1;
14851         }
14852     }
14853     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14854     if ($VMS_STATUS_SUCCESS(status)) {
14855         val_str[0] = _toupper(val_str[0]);
14856         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14857            decc_filename_unix_only = 1;
14858            decc_filename_unix_report = 1;
14859         }
14860     }
14861     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14862     if ($VMS_STATUS_SUCCESS(status)) {
14863         val_str[0] = _toupper(val_str[0]);
14864         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14865            decc_filename_unix_no_version = 1;
14866         }
14867     }
14868     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14869     if ($VMS_STATUS_SUCCESS(status)) {
14870         val_str[0] = _toupper(val_str[0]);
14871         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14872            decc_readdir_dropdotnotype = 1;
14873         }
14874     }
14875 #endif
14876
14877 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14878
14879      /* Report true case tolerance */
14880     /*----------------------------*/
14881     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14882     if (!$VMS_STATUS_SUCCESS(status))
14883         case_perm = PPROP$K_CASE_BLIND;
14884     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14885     if (!$VMS_STATUS_SUCCESS(status))
14886         case_image = PPROP$K_CASE_BLIND;
14887     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14888         (case_image == PPROP$K_CASE_SENSITIVE))
14889         vms_process_case_tolerant = 0;
14890
14891 #endif
14892
14893     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14894     /* for strict backward compatibilty */
14895     status = sys_trnlnm
14896         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14897     if ($VMS_STATUS_SUCCESS(status)) {
14898        val_str[0] = _toupper(val_str[0]);
14899        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14900          vms_posix_exit = 1;
14901        else
14902          vms_posix_exit = 0;
14903     }
14904
14905
14906     /* CRTL can be initialized past this point, but not before. */
14907 /*    DECC$CRTL_INIT(); */
14908
14909     return SS$_NORMAL;
14910 }
14911
14912 #ifdef __DECC
14913 #pragma nostandard
14914 #pragma extern_model save
14915 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14916         const __align (LONGWORD) int spare[8] = {0};
14917
14918 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14919 #if __DECC_VER >= 60560002
14920 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14921 #else
14922 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14923 #endif
14924 #endif /* __DECC */
14925
14926 const long vms_cc_features = (const long)set_features;
14927
14928 /*
14929 ** Force a reference to LIB$INITIALIZE to ensure it
14930 ** exists in the image.
14931 */
14932 int lib$initialize(void);
14933 #ifdef __DECC
14934 #pragma extern_model strict_refdef
14935 #endif
14936     int lib_init_ref = (int) lib$initialize;
14937
14938 #ifdef __DECC
14939 #pragma extern_model restore
14940 #pragma standard
14941 #endif
14942
14943 /*  End of vms.c */