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 void
1823 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1824 {
1825     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1826     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1827     unsigned long int iss, attr = LNM$M_CONFINE;
1828     unsigned char acmode = PSL$C_USER;
1829     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1830                                  {0, 0, 0, 0}};
1831     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1832     d_name.dsc$w_length = strlen(name);
1833
1834     lnmlst[0].buflen = strlen(eqv);
1835     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1836
1837     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1838     if (!(iss&1)) lib$signal(iss);
1839 }
1840 /*}}}*/
1841
1842
1843 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1844 /* my_crypt - VMS password hashing
1845  * my_crypt() provides an interface compatible with the Unix crypt()
1846  * C library function, and uses sys$hash_password() to perform VMS
1847  * password hashing.  The quadword hashed password value is returned
1848  * as a NUL-terminated 8 character string.  my_crypt() does not change
1849  * the case of its string arguments; in order to match the behavior
1850  * of LOGINOUT et al., alphabetic characters in both arguments must
1851  *  be upcased by the caller.
1852  *
1853  * - fix me to call ACM services when available
1854  */
1855 char *
1856 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1857 {
1858 #   ifndef UAI$C_PREFERRED_ALGORITHM
1859 #     define UAI$C_PREFERRED_ALGORITHM 127
1860 #   endif
1861     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1862     unsigned short int salt = 0;
1863     unsigned long int sts;
1864     struct const_dsc {
1865         unsigned short int dsc$w_length;
1866         unsigned char      dsc$b_type;
1867         unsigned char      dsc$b_class;
1868         const char *       dsc$a_pointer;
1869     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1870        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1871     struct itmlst_3 uailst[3] = {
1872         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1873         { sizeof salt, UAI$_SALT,    &salt, 0},
1874         { 0,           0,            NULL,  NULL}};
1875     static char hash[9];
1876
1877     usrdsc.dsc$w_length = strlen(usrname);
1878     usrdsc.dsc$a_pointer = usrname;
1879     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1880       switch (sts) {
1881         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1882           set_errno(EACCES);
1883           break;
1884         case RMS$_RNF:
1885           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1886           break;
1887         default:
1888           set_errno(EVMSERR);
1889       }
1890       set_vaxc_errno(sts);
1891       if (sts != RMS$_RNF) return NULL;
1892     }
1893
1894     txtdsc.dsc$w_length = strlen(textpasswd);
1895     txtdsc.dsc$a_pointer = textpasswd;
1896     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1897       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1898     }
1899
1900     return (char *) hash;
1901
1902 }  /* end of my_crypt() */
1903 /*}}}*/
1904
1905
1906 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1907 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1908 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1909
1910 /* fixup barenames that are directories for internal use.
1911  * There have been problems with the consistent handling of UNIX
1912  * style directory names when routines are presented with a name that
1913  * has no directory delimitors at all.  So this routine will eventually
1914  * fix the issue.
1915  */
1916 static char * fixup_bare_dirnames(const char * name)
1917 {
1918   if (decc_disable_to_vms_logname_translation) {
1919 /* fix me */
1920   }
1921   return NULL;
1922 }
1923
1924 /* 8.3, remove() is now broken on symbolic links */
1925 static int rms_erase(const char * vmsname);
1926
1927
1928 /* mp_do_kill_file
1929  * A little hack to get around a bug in some implemenation of remove()
1930  * that do not know how to delete a directory
1931  *
1932  * Delete any file to which user has control access, regardless of whether
1933  * delete access is explicitly allowed.
1934  * Limitations: User must have write access to parent directory.
1935  *              Does not block signals or ASTs; if interrupted in midstream
1936  *              may leave file with an altered ACL.
1937  * HANDLE WITH CARE!
1938  */
1939 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1940 static int
1941 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1942 {
1943     char *vmsname;
1944     char *rslt;
1945     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1946     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1947     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1948     struct myacedef {
1949       unsigned char myace$b_length;
1950       unsigned char myace$b_type;
1951       unsigned short int myace$w_flags;
1952       unsigned long int myace$l_access;
1953       unsigned long int myace$l_ident;
1954     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1955                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1956       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1957      struct itmlst_3
1958        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1959                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1960        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1961        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1962        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1963        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1964
1965     /* Expand the input spec using RMS, since the CRTL remove() and
1966      * system services won't do this by themselves, so we may miss
1967      * a file "hiding" behind a logical name or search list. */
1968     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1969     if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1970
1971     rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1972     if (rslt == NULL) {
1973         PerlMem_free(vmsname);
1974         return -1;
1975       }
1976
1977     /* Erase the file */
1978     rmsts = rms_erase(vmsname);
1979
1980     /* Did it succeed */
1981     if ($VMS_STATUS_SUCCESS(rmsts)) {
1982         PerlMem_free(vmsname);
1983         return 0;
1984       }
1985
1986     /* If not, can changing protections help? */
1987     if (rmsts != RMS$_PRV) {
1988       set_vaxc_errno(rmsts);
1989       PerlMem_free(vmsname);
1990       return -1;
1991     }
1992
1993     /* No, so we get our own UIC to use as a rights identifier,
1994      * and the insert an ACE at the head of the ACL which allows us
1995      * to delete the file.
1996      */
1997     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1998     fildsc.dsc$w_length = strlen(vmsname);
1999     fildsc.dsc$a_pointer = vmsname;
2000     cxt = 0;
2001     newace.myace$l_ident = oldace.myace$l_ident;
2002     rmsts = -1;
2003     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
2004       switch (aclsts) {
2005         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
2006           set_errno(ENOENT); break;
2007         case RMS$_DIR:
2008           set_errno(ENOTDIR); break;
2009         case RMS$_DEV:
2010           set_errno(ENODEV); break;
2011         case RMS$_SYN: case SS$_INVFILFOROP:
2012           set_errno(EINVAL); break;
2013         case RMS$_PRV:
2014           set_errno(EACCES); break;
2015         default:
2016           _ckvmssts_noperl(aclsts);
2017       }
2018       set_vaxc_errno(aclsts);
2019       PerlMem_free(vmsname);
2020       return -1;
2021     }
2022     /* Grab any existing ACEs with this identifier in case we fail */
2023     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2024     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2025                     || fndsts == SS$_NOMOREACE ) {
2026       /* Add the new ACE . . . */
2027       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2028         goto yourroom;
2029
2030       rmsts = rms_erase(vmsname);
2031       if ($VMS_STATUS_SUCCESS(rmsts)) {
2032         rmsts = 0;
2033         }
2034         else {
2035         rmsts = -1;
2036         /* We blew it - dir with files in it, no write priv for
2037          * parent directory, etc.  Put things back the way they were. */
2038         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2039           goto yourroom;
2040         if (fndsts & 1) {
2041           addlst[0].bufadr = &oldace;
2042           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2043             goto yourroom;
2044         }
2045       }
2046     }
2047
2048     yourroom:
2049     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2050     /* We just deleted it, so of course it's not there.  Some versions of
2051      * VMS seem to return success on the unlock operation anyhow (after all
2052      * the unlock is successful), but others don't.
2053      */
2054     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2055     if (aclsts & 1) aclsts = fndsts;
2056     if (!(aclsts & 1)) {
2057       set_errno(EVMSERR);
2058       set_vaxc_errno(aclsts);
2059     }
2060
2061     PerlMem_free(vmsname);
2062     return rmsts;
2063
2064 }  /* end of kill_file() */
2065 /*}}}*/
2066
2067 int vms_fid_to_name(char * outname, int outlen,
2068                     const char * name, int lstat_flag, mode_t * mode);
2069
2070 /*{{{int do_rmdir(char *name)*/
2071 int
2072 Perl_do_rmdir(pTHX_ const char *name)
2073 {
2074     char * dirfile;
2075     int retval;
2076     Stat_t st;
2077
2078     dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
2079     if (dirfile == NULL)
2080         _ckvmssts(SS$_INSFMEM);
2081
2082     /* Force to a directory specification */
2083     if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
2084         PerlMem_free(dirfile);
2085         return -1;
2086     }
2087     if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
2088         errno = ENOTDIR;
2089         retval = -1;
2090     }
2091     else
2092         retval = mp_do_kill_file(aTHX_ dirfile, 1);
2093
2094     PerlMem_free(dirfile);
2095     return retval;
2096
2097 }  /* end of do_rmdir */
2098 /*}}}*/
2099
2100 /* kill_file
2101  * Delete any file to which user has control access, regardless of whether
2102  * delete access is explicitly allowed.
2103  * Limitations: User must have write access to parent directory.
2104  *              Does not block signals or ASTs; if interrupted in midstream
2105  *              may leave file with an altered ACL.
2106  * HANDLE WITH CARE!
2107  */
2108 /*{{{int kill_file(char *name)*/
2109 int
2110 Perl_kill_file(pTHX_ const char *name)
2111 {
2112     char rspec[NAM$C_MAXRSS+1];
2113     char *tspec;
2114     Stat_t st;
2115     int rmsts;
2116
2117    /* Remove() is allowed to delete directories, according to the X/Open
2118     * specifications.
2119     * This may need special handling to work with the ACL hacks.
2120      */
2121    if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
2122         rmsts = Perl_do_rmdir(aTHX_ name);
2123         return rmsts;
2124     }
2125
2126    rmsts = mp_do_kill_file(aTHX_ name, 0);
2127
2128     return rmsts;
2129
2130 }  /* end of kill_file() */
2131 /*}}}*/
2132
2133
2134 /*{{{int my_mkdir(char *,Mode_t)*/
2135 int
2136 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2137 {
2138   STRLEN dirlen = strlen(dir);
2139
2140   /* zero length string sometimes gives ACCVIO */
2141   if (dirlen == 0) return -1;
2142
2143   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2144    * null file name/type.  However, it's commonplace under Unix,
2145    * so we'll allow it for a gain in portability.
2146    */
2147   if (dir[dirlen-1] == '/') {
2148     char *newdir = savepvn(dir,dirlen-1);
2149     int ret = mkdir(newdir,mode);
2150     Safefree(newdir);
2151     return ret;
2152   }
2153   else return mkdir(dir,mode);
2154 }  /* end of my_mkdir */
2155 /*}}}*/
2156
2157 /*{{{int my_chdir(char *)*/
2158 int
2159 Perl_my_chdir(pTHX_ const char *dir)
2160 {
2161   STRLEN dirlen = strlen(dir);
2162
2163   /* zero length string sometimes gives ACCVIO */
2164   if (dirlen == 0) return -1;
2165   const char *dir1;
2166
2167   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2168    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2169    * so that existing scripts do not need to be changed.
2170    */
2171   dir1 = dir;
2172   while ((dirlen > 0) && (*dir1 == ' ')) {
2173     dir1++;
2174     dirlen--;
2175   }
2176
2177   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2178    * that implies
2179    * null file name/type.  However, it's commonplace under Unix,
2180    * so we'll allow it for a gain in portability.
2181    *
2182    * - Preview- '/' will be valid soon on VMS
2183    */
2184   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2185     char *newdir = savepvn(dir1,dirlen-1);
2186     int ret = chdir(newdir);
2187     Safefree(newdir);
2188     return ret;
2189   }
2190   else return chdir(dir1);
2191 }  /* end of my_chdir */
2192 /*}}}*/
2193
2194
2195 /*{{{int my_chmod(char *, mode_t)*/
2196 int
2197 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2198 {
2199   STRLEN speclen = strlen(file_spec);
2200
2201   /* zero length string sometimes gives ACCVIO */
2202   if (speclen == 0) return -1;
2203
2204   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2205    * that implies null file name/type.  However, it's commonplace under Unix,
2206    * so we'll allow it for a gain in portability.
2207    *
2208    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2209    * in VMS file.dir notation.
2210    */
2211   if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2212     char *vms_src, *vms_dir, *rslt;
2213     int ret = -1;
2214     errno = EIO;
2215
2216     /* First convert this to a VMS format specification */
2217     vms_src = PerlMem_malloc(VMS_MAXRSS);
2218     if (vms_src == NULL)
2219         _ckvmssts_noperl(SS$_INSFMEM);
2220
2221     rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2222     if (rslt == NULL) {
2223         /* If we fail, then not a file specification */
2224         PerlMem_free(vms_src);
2225         errno = EIO;
2226         return -1;
2227     }
2228
2229     /* Now make it a directory spec so chmod is happy */
2230     vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2231     if (vms_dir == NULL)
2232         _ckvmssts_noperl(SS$_INSFMEM);
2233     rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2234     PerlMem_free(vms_src);
2235
2236     /* Now do it */
2237     if (rslt != NULL) {
2238         ret = chmod(vms_dir, mode);
2239     } else {
2240         errno = EIO;
2241     }
2242     PerlMem_free(vms_dir);
2243     return ret;
2244   }
2245   else return chmod(file_spec, mode);
2246 }  /* end of my_chmod */
2247 /*}}}*/
2248
2249
2250 /*{{{FILE *my_tmpfile()*/
2251 FILE *
2252 my_tmpfile(void)
2253 {
2254   FILE *fp;
2255   char *cp;
2256
2257   if ((fp = tmpfile())) return fp;
2258
2259   cp = PerlMem_malloc(L_tmpnam+24);
2260   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2261
2262   if (decc_filename_unix_only == 0)
2263     strcpy(cp,"Sys$Scratch:");
2264   else
2265     strcpy(cp,"/tmp/");
2266   tmpnam(cp+strlen(cp));
2267   strcat(cp,".Perltmp");
2268   fp = fopen(cp,"w+","fop=dlt");
2269   PerlMem_free(cp);
2270   return fp;
2271 }
2272 /*}}}*/
2273
2274
2275 #ifndef HOMEGROWN_POSIX_SIGNALS
2276 /*
2277  * The C RTL's sigaction fails to check for invalid signal numbers so we
2278  * help it out a bit.  The docs are correct, but the actual routine doesn't
2279  * do what the docs say it will.
2280  */
2281 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2282 int
2283 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2284                    struct sigaction* oact)
2285 {
2286   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2287         SETERRNO(EINVAL, SS$_INVARG);
2288         return -1;
2289   }
2290   return sigaction(sig, act, oact);
2291 }
2292 /*}}}*/
2293 #endif
2294
2295 #ifdef KILL_BY_SIGPRC
2296 #include <errnodef.h>
2297
2298 /* We implement our own kill() using the undocumented system service
2299    sys$sigprc for one of two reasons:
2300
2301    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2302    target process to do a sys$exit, which usually can't be handled
2303    gracefully...certainly not by Perl and the %SIG{} mechanism.
2304
2305    2.) If the kill() in the CRTL can't be called from a signal
2306    handler without disappearing into the ether, i.e., the signal
2307    it purportedly sends is never trapped. Still true as of VMS 7.3.
2308
2309    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2310    in the target process rather than calling sys$exit.
2311
2312    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2313    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2314    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2315    with condition codes C$_SIG0+nsig*8, catching the exception on the
2316    target process and resignaling with appropriate arguments.
2317
2318    But we don't have that VMS 7.0+ exception handler, so if you
2319    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2320
2321    Also note that SIGTERM is listed in the docs as being "unimplemented",
2322    yet always seems to be signaled with a VMS condition code of 4 (and
2323    correctly handled for that code).  So we hardwire it in.
2324
2325    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2326    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2327    than signalling with an unrecognized (and unhandled by CRTL) code.
2328 */
2329
2330 #define _MY_SIG_MAX 28
2331
2332 static unsigned int
2333 Perl_sig_to_vmscondition_int(int sig)
2334 {
2335     static unsigned int sig_code[_MY_SIG_MAX+1] =
2336     {
2337         0,                  /*  0 ZERO     */
2338         SS$_HANGUP,         /*  1 SIGHUP   */
2339         SS$_CONTROLC,       /*  2 SIGINT   */
2340         SS$_CONTROLY,       /*  3 SIGQUIT  */
2341         SS$_RADRMOD,        /*  4 SIGILL   */
2342         SS$_BREAK,          /*  5 SIGTRAP  */
2343         SS$_OPCCUS,         /*  6 SIGABRT  */
2344         SS$_COMPAT,         /*  7 SIGEMT   */
2345 #ifdef __VAX
2346         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2347 #else
2348         SS$_HPARITH,        /*  8 SIGFPE AXP */
2349 #endif
2350         SS$_ABORT,          /*  9 SIGKILL  */
2351         SS$_ACCVIO,         /* 10 SIGBUS   */
2352         SS$_ACCVIO,         /* 11 SIGSEGV  */
2353         SS$_BADPARAM,       /* 12 SIGSYS   */
2354         SS$_NOMBX,          /* 13 SIGPIPE  */
2355         SS$_ASTFLT,         /* 14 SIGALRM  */
2356         4,                  /* 15 SIGTERM  */
2357         0,                  /* 16 SIGUSR1  */
2358         0,                  /* 17 SIGUSR2  */
2359         0,                  /* 18 */
2360         0,                  /* 19 */
2361         0,                  /* 20 SIGCHLD  */
2362         0,                  /* 21 SIGCONT  */
2363         0,                  /* 22 SIGSTOP  */
2364         0,                  /* 23 SIGTSTP  */
2365         0,                  /* 24 SIGTTIN  */
2366         0,                  /* 25 SIGTTOU  */
2367         0,                  /* 26 */
2368         0,                  /* 27 */
2369         0                   /* 28 SIGWINCH  */
2370     };
2371
2372 #if __VMS_VER >= 60200000
2373     static int initted = 0;
2374     if (!initted) {
2375         initted = 1;
2376         sig_code[16] = C$_SIGUSR1;
2377         sig_code[17] = C$_SIGUSR2;
2378 #if __CRTL_VER >= 70000000
2379         sig_code[20] = C$_SIGCHLD;
2380 #endif
2381 #if __CRTL_VER >= 70300000
2382         sig_code[28] = C$_SIGWINCH;
2383 #endif
2384     }
2385 #endif
2386
2387     if (sig < _SIG_MIN) return 0;
2388     if (sig > _MY_SIG_MAX) return 0;
2389     return sig_code[sig];
2390 }
2391
2392 unsigned int
2393 Perl_sig_to_vmscondition(int sig)
2394 {
2395 #ifdef SS$_DEBUG
2396     if (vms_debug_on_exception != 0)
2397         lib$signal(SS$_DEBUG);
2398 #endif
2399     return Perl_sig_to_vmscondition_int(sig);
2400 }
2401
2402
2403 int
2404 Perl_my_kill(int pid, int sig)
2405 {
2406     dTHX;
2407     int iss;
2408     unsigned int code;
2409     int sys$sigprc(unsigned int *pidadr,
2410                      struct dsc$descriptor_s *prcname,
2411                      unsigned int code);
2412
2413      /* sig 0 means validate the PID */
2414     /*------------------------------*/
2415     if (sig == 0) {
2416         const unsigned long int jpicode = JPI$_PID;
2417         pid_t ret_pid;
2418         int status;
2419         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2420         if ($VMS_STATUS_SUCCESS(status))
2421            return 0;
2422         switch (status) {
2423         case SS$_NOSUCHNODE:
2424         case SS$_UNREACHABLE:
2425         case SS$_NONEXPR:
2426            errno = ESRCH;
2427            break;
2428         case SS$_NOPRIV:
2429            errno = EPERM;
2430            break;
2431         default:
2432            errno = EVMSERR;
2433         }
2434         vaxc$errno=status;
2435         return -1;
2436     }
2437
2438     code = Perl_sig_to_vmscondition_int(sig);
2439
2440     if (!code) {
2441         SETERRNO(EINVAL, SS$_BADPARAM);
2442         return -1;
2443     }
2444
2445     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2446      * signals are to be sent to multiple processes.
2447      *  pid = 0 - all processes in group except ones that the system exempts
2448      *  pid = -1 - all processes except ones that the system exempts
2449      *  pid = -n - all processes in group (abs(n)) except ...
2450      * For now, just report as not supported.
2451      */
2452
2453     if (pid <= 0) {
2454         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2455         return -1;
2456     }
2457
2458     iss = sys$sigprc((unsigned int *)&pid,0,code);
2459     if (iss&1) return 0;
2460
2461     switch (iss) {
2462       case SS$_NOPRIV:
2463         set_errno(EPERM);  break;
2464       case SS$_NONEXPR:
2465       case SS$_NOSUCHNODE:
2466       case SS$_UNREACHABLE:
2467         set_errno(ESRCH);  break;
2468       case SS$_INSFMEM:
2469         set_errno(ENOMEM); break;
2470       default:
2471         _ckvmssts_noperl(iss);
2472         set_errno(EVMSERR);
2473     }
2474     set_vaxc_errno(iss);
2475
2476     return -1;
2477 }
2478 #endif
2479
2480 /* Routine to convert a VMS status code to a UNIX status code.
2481 ** More tricky than it appears because of conflicting conventions with
2482 ** existing code.
2483 **
2484 ** VMS status codes are a bit mask, with the least significant bit set for
2485 ** success.
2486 **
2487 ** Special UNIX status of EVMSERR indicates that no translation is currently
2488 ** available, and programs should check the VMS status code.
2489 **
2490 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2491 ** decoding.
2492 */
2493
2494 #ifndef C_FACILITY_NO
2495 #define C_FACILITY_NO 0x350000
2496 #endif
2497 #ifndef DCL_IVVERB
2498 #define DCL_IVVERB 0x38090
2499 #endif
2500
2501 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2502 {
2503 int facility;
2504 int fac_sp;
2505 int msg_no;
2506 int msg_status;
2507 int unix_status;
2508
2509   /* Assume the best or the worst */
2510   if (vms_status & STS$M_SUCCESS)
2511     unix_status = 0;
2512   else
2513     unix_status = EVMSERR;
2514
2515   msg_status = vms_status & ~STS$M_CONTROL;
2516
2517   facility = vms_status & STS$M_FAC_NO;
2518   fac_sp = vms_status & STS$M_FAC_SP;
2519   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2520
2521   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2522     switch(msg_no) {
2523     case SS$_NORMAL:
2524         unix_status = 0;
2525         break;
2526     case SS$_ACCVIO:
2527         unix_status = EFAULT;
2528         break;
2529     case SS$_DEVOFFLINE:
2530         unix_status = EBUSY;
2531         break;
2532     case SS$_CLEARED:
2533         unix_status = ENOTCONN;
2534         break;
2535     case SS$_IVCHAN:
2536     case SS$_IVLOGNAM:
2537     case SS$_BADPARAM:
2538     case SS$_IVLOGTAB:
2539     case SS$_NOLOGNAM:
2540     case SS$_NOLOGTAB:
2541     case SS$_INVFILFOROP:
2542     case SS$_INVARG:
2543     case SS$_NOSUCHID:
2544     case SS$_IVIDENT:
2545         unix_status = EINVAL;
2546         break;
2547     case SS$_UNSUPPORTED:
2548         unix_status = ENOTSUP;
2549         break;
2550     case SS$_FILACCERR:
2551     case SS$_NOGRPPRV:
2552     case SS$_NOSYSPRV:
2553         unix_status = EACCES;
2554         break;
2555     case SS$_DEVICEFULL:
2556         unix_status = ENOSPC;
2557         break;
2558     case SS$_NOSUCHDEV:
2559         unix_status = ENODEV;
2560         break;
2561     case SS$_NOSUCHFILE:
2562     case SS$_NOSUCHOBJECT:
2563         unix_status = ENOENT;
2564         break;
2565     case SS$_ABORT:                                 /* Fatal case */
2566     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2567     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2568         unix_status = EINTR;
2569         break;
2570     case SS$_BUFFEROVF:
2571         unix_status = E2BIG;
2572         break;
2573     case SS$_INSFMEM:
2574         unix_status = ENOMEM;
2575         break;
2576     case SS$_NOPRIV:
2577         unix_status = EPERM;
2578         break;
2579     case SS$_NOSUCHNODE:
2580     case SS$_UNREACHABLE:
2581         unix_status = ESRCH;
2582         break;
2583     case SS$_NONEXPR:
2584         unix_status = ECHILD;
2585         break;
2586     default:
2587         if ((facility == 0) && (msg_no < 8)) {
2588           /* These are not real VMS status codes so assume that they are
2589           ** already UNIX status codes
2590           */
2591           unix_status = msg_no;
2592           break;
2593         }
2594     }
2595   }
2596   else {
2597     /* Translate a POSIX exit code to a UNIX exit code */
2598     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2599         unix_status = (msg_no & 0x07F8) >> 3;
2600     }
2601     else {
2602
2603          /* Documented traditional behavior for handling VMS child exits */
2604         /*--------------------------------------------------------------*/
2605         if (child_flag != 0) {
2606
2607              /* Success / Informational return 0 */
2608             /*----------------------------------*/
2609             if (msg_no & STS$K_SUCCESS)
2610                 return 0;
2611
2612              /* Warning returns 1 */
2613             /*-------------------*/
2614             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2615                 return 1;
2616
2617              /* Everything else pass through the severity bits */
2618             /*------------------------------------------------*/
2619             return (msg_no & STS$M_SEVERITY);
2620         }
2621
2622          /* Normal VMS status to ERRNO mapping attempt */
2623         /*--------------------------------------------*/
2624         switch(msg_status) {
2625         /* case RMS$_EOF: */ /* End of File */
2626         case RMS$_FNF:  /* File Not Found */
2627         case RMS$_DNF:  /* Dir Not Found */
2628                 unix_status = ENOENT;
2629                 break;
2630         case RMS$_RNF:  /* Record Not Found */
2631                 unix_status = ESRCH;
2632                 break;
2633         case RMS$_DIR:
2634                 unix_status = ENOTDIR;
2635                 break;
2636         case RMS$_DEV:
2637                 unix_status = ENODEV;
2638                 break;
2639         case RMS$_IFI:
2640         case RMS$_FAC:
2641         case RMS$_ISI:
2642                 unix_status = EBADF;
2643                 break;
2644         case RMS$_FEX:
2645                 unix_status = EEXIST;
2646                 break;
2647         case RMS$_SYN:
2648         case RMS$_FNM:
2649         case LIB$_INVSTRDES:
2650         case LIB$_INVARG:
2651         case LIB$_NOSUCHSYM:
2652         case LIB$_INVSYMNAM:
2653         case DCL_IVVERB:
2654                 unix_status = EINVAL;
2655                 break;
2656         case CLI$_BUFOVF:
2657         case RMS$_RTB:
2658         case CLI$_TKNOVF:
2659         case CLI$_RSLOVF:
2660                 unix_status = E2BIG;
2661                 break;
2662         case RMS$_PRV:  /* No privilege */
2663         case RMS$_ACC:  /* ACP file access failed */
2664         case RMS$_WLK:  /* Device write locked */
2665                 unix_status = EACCES;
2666                 break;
2667         case RMS$_MKD:  /* Failed to mark for delete */
2668                 unix_status = EPERM;
2669                 break;
2670         /* case RMS$_NMF: */  /* No more files */
2671         }
2672     }
2673   }
2674
2675   return unix_status;
2676 }
2677
2678 /* Try to guess at what VMS error status should go with a UNIX errno
2679  * value.  This is hard to do as there could be many possible VMS
2680  * error statuses that caused the errno value to be set.
2681  */
2682
2683 int Perl_unix_status_to_vms(int unix_status)
2684 {
2685 int test_unix_status;
2686
2687      /* Trivial cases first */
2688     /*---------------------*/
2689     if (unix_status == EVMSERR)
2690         return vaxc$errno;
2691
2692      /* Is vaxc$errno sane? */
2693     /*---------------------*/
2694     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2695     if (test_unix_status == unix_status)
2696         return vaxc$errno;
2697
2698      /* If way out of range, must be VMS code already */
2699     /*-----------------------------------------------*/
2700     if (unix_status > EVMSERR)
2701         return unix_status;
2702
2703      /* If out of range, punt */
2704     /*-----------------------*/
2705     if (unix_status > __ERRNO_MAX)
2706         return SS$_ABORT;
2707
2708
2709      /* Ok, now we have to do it the hard way. */
2710     /*----------------------------------------*/
2711     switch(unix_status) {
2712     case 0:     return SS$_NORMAL;
2713     case EPERM: return SS$_NOPRIV;
2714     case ENOENT: return SS$_NOSUCHOBJECT;
2715     case ESRCH: return SS$_UNREACHABLE;
2716     case EINTR: return SS$_ABORT;
2717     /* case EIO: */
2718     /* case ENXIO:  */
2719     case E2BIG: return SS$_BUFFEROVF;
2720     /* case ENOEXEC */
2721     case EBADF: return RMS$_IFI;
2722     case ECHILD: return SS$_NONEXPR;
2723     /* case EAGAIN */
2724     case ENOMEM: return SS$_INSFMEM;
2725     case EACCES: return SS$_FILACCERR;
2726     case EFAULT: return SS$_ACCVIO;
2727     /* case ENOTBLK */
2728     case EBUSY: return SS$_DEVOFFLINE;
2729     case EEXIST: return RMS$_FEX;
2730     /* case EXDEV */
2731     case ENODEV: return SS$_NOSUCHDEV;
2732     case ENOTDIR: return RMS$_DIR;
2733     /* case EISDIR */
2734     case EINVAL: return SS$_INVARG;
2735     /* case ENFILE */
2736     /* case EMFILE */
2737     /* case ENOTTY */
2738     /* case ETXTBSY */
2739     /* case EFBIG */
2740     case ENOSPC: return SS$_DEVICEFULL;
2741     case ESPIPE: return LIB$_INVARG;
2742     /* case EROFS: */
2743     /* case EMLINK: */
2744     /* case EPIPE: */
2745     /* case EDOM */
2746     case ERANGE: return LIB$_INVARG;
2747     /* case EWOULDBLOCK */
2748     /* case EINPROGRESS */
2749     /* case EALREADY */
2750     /* case ENOTSOCK */
2751     /* case EDESTADDRREQ */
2752     /* case EMSGSIZE */
2753     /* case EPROTOTYPE */
2754     /* case ENOPROTOOPT */
2755     /* case EPROTONOSUPPORT */
2756     /* case ESOCKTNOSUPPORT */
2757     /* case EOPNOTSUPP */
2758     /* case EPFNOSUPPORT */
2759     /* case EAFNOSUPPORT */
2760     /* case EADDRINUSE */
2761     /* case EADDRNOTAVAIL */
2762     /* case ENETDOWN */
2763     /* case ENETUNREACH */
2764     /* case ENETRESET */
2765     /* case ECONNABORTED */
2766     /* case ECONNRESET */
2767     /* case ENOBUFS */
2768     /* case EISCONN */
2769     case ENOTCONN: return SS$_CLEARED;
2770     /* case ESHUTDOWN */
2771     /* case ETOOMANYREFS */
2772     /* case ETIMEDOUT */
2773     /* case ECONNREFUSED */
2774     /* case ELOOP */
2775     /* case ENAMETOOLONG */
2776     /* case EHOSTDOWN */
2777     /* case EHOSTUNREACH */
2778     /* case ENOTEMPTY */
2779     /* case EPROCLIM */
2780     /* case EUSERS  */
2781     /* case EDQUOT  */
2782     /* case ENOMSG  */
2783     /* case EIDRM */
2784     /* case EALIGN */
2785     /* case ESTALE */
2786     /* case EREMOTE */
2787     /* case ENOLCK */
2788     /* case ENOSYS */
2789     /* case EFTYPE */
2790     /* case ECANCELED */
2791     /* case EFAIL */
2792     /* case EINPROG */
2793     case ENOTSUP:
2794         return SS$_UNSUPPORTED;
2795     /* case EDEADLK */
2796     /* case ENWAIT */
2797     /* case EILSEQ */
2798     /* case EBADCAT */
2799     /* case EBADMSG */
2800     /* case EABANDONED */
2801     default:
2802         return SS$_ABORT; /* punt */
2803     }
2804
2805   return SS$_ABORT; /* Should not get here */
2806 }
2807
2808
2809 /* default piping mailbox size */
2810 #define PERL_BUFSIZ        512
2811
2812
2813 static void
2814 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2815 {
2816   unsigned long int mbxbufsiz;
2817   static unsigned long int syssize = 0;
2818   unsigned long int dviitm = DVI$_DEVNAM;
2819   char csize[LNM$C_NAMLENGTH+1];
2820   int sts;
2821
2822   if (!syssize) {
2823     unsigned long syiitm = SYI$_MAXBUF;
2824     /*
2825      * Get the SYSGEN parameter MAXBUF
2826      *
2827      * If the logical 'PERL_MBX_SIZE' is defined
2828      * use the value of the logical instead of PERL_BUFSIZ, but
2829      * keep the size between 128 and MAXBUF.
2830      *
2831      */
2832     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2833   }
2834
2835   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2836       mbxbufsiz = atoi(csize);
2837   } else {
2838       mbxbufsiz = PERL_BUFSIZ;
2839   }
2840   if (mbxbufsiz < 128) mbxbufsiz = 128;
2841   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2842
2843   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2844
2845   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2846   _ckvmssts_noperl(sts);
2847   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2848
2849 }  /* end of create_mbx() */
2850
2851
2852 /*{{{  my_popen and my_pclose*/
2853
2854 typedef struct _iosb           IOSB;
2855 typedef struct _iosb*         pIOSB;
2856 typedef struct _pipe           Pipe;
2857 typedef struct _pipe*         pPipe;
2858 typedef struct pipe_details    Info;
2859 typedef struct pipe_details*  pInfo;
2860 typedef struct _srqp            RQE;
2861 typedef struct _srqp*          pRQE;
2862 typedef struct _tochildbuf      CBuf;
2863 typedef struct _tochildbuf*    pCBuf;
2864
2865 struct _iosb {
2866     unsigned short status;
2867     unsigned short count;
2868     unsigned long  dvispec;
2869 };
2870
2871 #pragma member_alignment save
2872 #pragma nomember_alignment quadword
2873 struct _srqp {          /* VMS self-relative queue entry */
2874     unsigned long qptr[2];
2875 };
2876 #pragma member_alignment restore
2877 static RQE  RQE_ZERO = {0,0};
2878
2879 struct _tochildbuf {
2880     RQE             q;
2881     int             eof;
2882     unsigned short  size;
2883     char            *buf;
2884 };
2885
2886 struct _pipe {
2887     RQE            free;
2888     RQE            wait;
2889     int            fd_out;
2890     unsigned short chan_in;
2891     unsigned short chan_out;
2892     char          *buf;
2893     unsigned int   bufsize;
2894     IOSB           iosb;
2895     IOSB           iosb2;
2896     int           *pipe_done;
2897     int            retry;
2898     int            type;
2899     int            shut_on_empty;
2900     int            need_wake;
2901     pPipe         *home;
2902     pInfo          info;
2903     pCBuf          curr;
2904     pCBuf          curr2;
2905 #if defined(PERL_IMPLICIT_CONTEXT)
2906     void            *thx;           /* Either a thread or an interpreter */
2907                                     /* pointer, depending on how we're built */
2908 #endif
2909 };
2910
2911
2912 struct pipe_details
2913 {
2914     pInfo           next;
2915     PerlIO *fp;  /* file pointer to pipe mailbox */
2916     int useFILE; /* using stdio, not perlio */
2917     int pid;   /* PID of subprocess */
2918     int mode;  /* == 'r' if pipe open for reading */
2919     int done;  /* subprocess has completed */
2920     int waiting; /* waiting for completion/closure */
2921     int             closing;        /* my_pclose is closing this pipe */
2922     unsigned long   completion;     /* termination status of subprocess */
2923     pPipe           in;             /* pipe in to sub */
2924     pPipe           out;            /* pipe out of sub */
2925     pPipe           err;            /* pipe of sub's sys$error */
2926     int             in_done;        /* true when in pipe finished */
2927     int             out_done;
2928     int             err_done;
2929     unsigned short  xchan;          /* channel to debug xterm */
2930     unsigned short  xchan_valid;    /* channel is assigned */
2931 };
2932
2933 struct exit_control_block
2934 {
2935     struct exit_control_block *flink;
2936     unsigned long int   (*exit_routine)();
2937     unsigned long int arg_count;
2938     unsigned long int *status_address;
2939     unsigned long int exit_status;
2940 };
2941
2942 typedef struct _closed_pipes    Xpipe;
2943 typedef struct _closed_pipes*  pXpipe;
2944
2945 struct _closed_pipes {
2946     int             pid;            /* PID of subprocess */
2947     unsigned long   completion;     /* termination status of subprocess */
2948 };
2949 #define NKEEPCLOSED 50
2950 static Xpipe closed_list[NKEEPCLOSED];
2951 static int   closed_index = 0;
2952 static int   closed_num = 0;
2953
2954 #define RETRY_DELAY     "0 ::0.20"
2955 #define MAX_RETRY              50
2956
2957 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2958 static unsigned long mypid;
2959 static unsigned long delaytime[2];
2960
2961 static pInfo open_pipes = NULL;
2962 static $DESCRIPTOR(nl_desc, "NL:");
2963
2964 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2965
2966
2967
2968 static unsigned long int
2969 pipe_exit_routine()
2970 {
2971     pInfo info;
2972     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2973     int sts, did_stuff, need_eof, j;
2974
2975    /*
2976     * Flush any pending i/o, but since we are in process run-down, be
2977     * careful about referencing PerlIO structures that may already have
2978     * been deallocated.  We may not even have an interpreter anymore.
2979     */
2980     info = open_pipes;
2981     while (info) {
2982         if (info->fp) {
2983 #if defined(PERL_IMPLICIT_CONTEXT)
2984            /* We need to use the Perl context of the thread that created */
2985            /* the pipe. */
2986            pTHX;
2987            if (info->err)
2988                aTHX = info->err->thx;
2989            else if (info->out)
2990                aTHX = info->out->thx;
2991            else if (info->in)
2992                aTHX = info->in->thx;
2993 #endif
2994            if (!info->useFILE
2995 #if defined(USE_ITHREADS)
2996              && my_perl
2997 #endif
2998              && PL_perlio_fd_refcnt)
2999                PerlIO_flush(info->fp);
3000            else
3001                fflush((FILE *)info->fp);
3002         }
3003         info = info->next;
3004     }
3005
3006     /*
3007      next we try sending an EOF...ignore if doesn't work, make sure we
3008      don't hang
3009     */
3010     did_stuff = 0;
3011     info = open_pipes;
3012
3013     while (info) {
3014       int need_eof;
3015       _ckvmssts_noperl(sys$setast(0));
3016       if (info->in && !info->in->shut_on_empty) {
3017         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3018                                  0, 0, 0, 0, 0, 0));
3019         info->waiting = 1;
3020         did_stuff = 1;
3021       }
3022       _ckvmssts_noperl(sys$setast(1));
3023       info = info->next;
3024     }
3025
3026     /* wait for EOF to have effect, up to ~ 30 sec [default] */
3027
3028     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3029         int nwait = 0;
3030
3031         info = open_pipes;
3032         while (info) {
3033           _ckvmssts_noperl(sys$setast(0));
3034           if (info->waiting && info->done)
3035                 info->waiting = 0;
3036           nwait += info->waiting;
3037           _ckvmssts_noperl(sys$setast(1));
3038           info = info->next;
3039         }
3040         if (!nwait) break;
3041         sleep(1);
3042     }
3043
3044     did_stuff = 0;
3045     info = open_pipes;
3046     while (info) {
3047       _ckvmssts_noperl(sys$setast(0));
3048       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3049         sts = sys$forcex(&info->pid,0,&abort);
3050         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3051         did_stuff = 1;
3052       }
3053       _ckvmssts_noperl(sys$setast(1));
3054       info = info->next;
3055     }
3056
3057     /* again, wait for effect */
3058
3059     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3060         int nwait = 0;
3061
3062         info = open_pipes;
3063         while (info) {
3064           _ckvmssts_noperl(sys$setast(0));
3065           if (info->waiting && info->done)
3066                 info->waiting = 0;
3067           nwait += info->waiting;
3068           _ckvmssts_noperl(sys$setast(1));
3069           info = info->next;
3070         }
3071         if (!nwait) break;
3072         sleep(1);
3073     }
3074
3075     info = open_pipes;
3076     while (info) {
3077       _ckvmssts_noperl(sys$setast(0));
3078       if (!info->done) {  /* We tried to be nice . . . */
3079         sts = sys$delprc(&info->pid,0);
3080         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3081         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3082       }
3083       _ckvmssts_noperl(sys$setast(1));
3084       info = info->next;
3085     }
3086
3087     while(open_pipes) {
3088
3089 #if defined(PERL_IMPLICIT_CONTEXT)
3090       /* We need to use the Perl context of the thread that created */
3091       /* the pipe. */
3092       pTHX;
3093       if (open_pipes->err)
3094           aTHX = open_pipes->err->thx;
3095       else if (open_pipes->out)
3096           aTHX = open_pipes->out->thx;
3097       else if (open_pipes->in)
3098           aTHX = open_pipes->in->thx;
3099 #endif
3100       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3101       else if (!(sts & 1)) retsts = sts;
3102     }
3103     return retsts;
3104 }
3105
3106 static struct exit_control_block pipe_exitblock =
3107        {(struct exit_control_block *) 0,
3108         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3109
3110 static void pipe_mbxtofd_ast(pPipe p);
3111 static void pipe_tochild1_ast(pPipe p);
3112 static void pipe_tochild2_ast(pPipe p);
3113
3114 static void
3115 popen_completion_ast(pInfo info)
3116 {
3117   pInfo i = open_pipes;
3118   int iss;
3119   int sts;
3120   pXpipe x;
3121
3122   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3123   closed_list[closed_index].pid = info->pid;
3124   closed_list[closed_index].completion = info->completion;
3125   closed_index++;
3126   if (closed_index == NKEEPCLOSED)
3127     closed_index = 0;
3128   closed_num++;
3129
3130   while (i) {
3131     if (i == info) break;
3132     i = i->next;
3133   }
3134   if (!i) return;       /* unlinked, probably freed too */
3135
3136   info->done = TRUE;
3137
3138 /*
3139     Writing to subprocess ...
3140             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3141
3142             chan_out may be waiting for "done" flag, or hung waiting
3143             for i/o completion to child...cancel the i/o.  This will
3144             put it into "snarf mode" (done but no EOF yet) that discards
3145             input.
3146
3147     Output from subprocess (stdout, stderr) needs to be flushed and
3148     shut down.   We try sending an EOF, but if the mbx is full the pipe
3149     routine should still catch the "shut_on_empty" flag, telling it to
3150     use immediate-style reads so that "mbx empty" -> EOF.
3151
3152
3153 */
3154   if (info->in && !info->in_done) {               /* only for mode=w */
3155         if (info->in->shut_on_empty && info->in->need_wake) {
3156             info->in->need_wake = FALSE;
3157             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3158         } else {
3159             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3160         }
3161   }
3162
3163   if (info->out && !info->out_done) {             /* were we also piping output? */
3164       info->out->shut_on_empty = TRUE;
3165       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3166       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3167       _ckvmssts_noperl(iss);
3168   }
3169
3170   if (info->err && !info->err_done) {        /* we were piping stderr */
3171         info->err->shut_on_empty = TRUE;
3172         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3173         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3174         _ckvmssts_noperl(iss);
3175   }
3176   _ckvmssts_noperl(sys$setef(pipe_ef));
3177
3178 }
3179
3180 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3181 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3182
3183 /*
3184     we actually differ from vmstrnenv since we use this to
3185     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3186     are pointing to the same thing
3187 */
3188
3189 static unsigned short
3190 popen_translate(pTHX_ char *logical, char *result)
3191 {
3192     int iss;
3193     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3194     $DESCRIPTOR(d_log,"");
3195     struct _il3 {
3196         unsigned short length;
3197         unsigned short code;
3198         char *         buffer_addr;
3199         unsigned short *retlenaddr;
3200     } itmlst[2];
3201     unsigned short l, ifi;
3202
3203     d_log.dsc$a_pointer = logical;
3204     d_log.dsc$w_length  = strlen(logical);
3205
3206     itmlst[0].code = LNM$_STRING;
3207     itmlst[0].length = 255;
3208     itmlst[0].buffer_addr = result;
3209     itmlst[0].retlenaddr = &l;
3210
3211     itmlst[1].code = 0;
3212     itmlst[1].length = 0;
3213     itmlst[1].buffer_addr = 0;
3214     itmlst[1].retlenaddr = 0;
3215
3216     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3217     if (iss == SS$_NOLOGNAM) {
3218         iss = SS$_NORMAL;
3219         l = 0;
3220     }
3221     if (!(iss&1)) lib$signal(iss);
3222     result[l] = '\0';
3223 /*
3224     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3225     strip it off and return the ifi, if any
3226 */
3227     ifi  = 0;
3228     if (result[0] == 0x1b && result[1] == 0x00) {
3229         memmove(&ifi,result+2,2);
3230         strcpy(result,result+4);
3231     }
3232     return ifi;     /* this is the RMS internal file id */
3233 }
3234
3235 static void pipe_infromchild_ast(pPipe p);
3236
3237 /*
3238     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3239     inside an AST routine without worrying about reentrancy and which Perl
3240     memory allocator is being used.
3241
3242     We read data and queue up the buffers, then spit them out one at a
3243     time to the output mailbox when the output mailbox is ready for one.
3244
3245 */
3246 #define INITIAL_TOCHILDQUEUE  2
3247
3248 static pPipe
3249 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3250 {
3251     pPipe p;
3252     pCBuf b;
3253     char mbx1[64], mbx2[64];
3254     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3255                                       DSC$K_CLASS_S, mbx1},
3256                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3257                                       DSC$K_CLASS_S, mbx2};
3258     unsigned int dviitm = DVI$_DEVBUFSIZ;
3259     int j, n;
3260
3261     n = sizeof(Pipe);
3262     _ckvmssts_noperl(lib$get_vm(&n, &p));
3263
3264     create_mbx(&p->chan_in , &d_mbx1);
3265     create_mbx(&p->chan_out, &d_mbx2);
3266     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3267
3268     p->buf           = 0;
3269     p->shut_on_empty = FALSE;
3270     p->need_wake     = FALSE;
3271     p->type          = 0;
3272     p->retry         = 0;
3273     p->iosb.status   = SS$_NORMAL;
3274     p->iosb2.status  = SS$_NORMAL;
3275     p->free          = RQE_ZERO;
3276     p->wait          = RQE_ZERO;
3277     p->curr          = 0;
3278     p->curr2         = 0;
3279     p->info          = 0;
3280 #ifdef PERL_IMPLICIT_CONTEXT
3281     p->thx           = aTHX;
3282 #endif
3283
3284     n = sizeof(CBuf) + p->bufsize;
3285
3286     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3287         _ckvmssts_noperl(lib$get_vm(&n, &b));
3288         b->buf = (char *) b + sizeof(CBuf);
3289         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3290     }
3291
3292     pipe_tochild2_ast(p);
3293     pipe_tochild1_ast(p);
3294     strcpy(wmbx, mbx1);
3295     strcpy(rmbx, mbx2);
3296     return p;
3297 }
3298
3299 /*  reads the MBX Perl is writing, and queues */
3300
3301 static void
3302 pipe_tochild1_ast(pPipe p)
3303 {
3304     pCBuf b = p->curr;
3305     int iss = p->iosb.status;
3306     int eof = (iss == SS$_ENDOFFILE);
3307     int sts;
3308 #ifdef PERL_IMPLICIT_CONTEXT
3309     pTHX = p->thx;
3310 #endif
3311
3312     if (p->retry) {
3313         if (eof) {
3314             p->shut_on_empty = TRUE;
3315             b->eof     = TRUE;
3316             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3317         } else  {
3318             _ckvmssts_noperl(iss);
3319         }
3320
3321         b->eof  = eof;
3322         b->size = p->iosb.count;
3323         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3324         if (p->need_wake) {
3325             p->need_wake = FALSE;
3326             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3327         }
3328     } else {
3329         p->retry = 1;   /* initial call */
3330     }
3331
3332     if (eof) {                  /* flush the free queue, return when done */
3333         int n = sizeof(CBuf) + p->bufsize;
3334         while (1) {
3335             iss = lib$remqti(&p->free, &b);
3336             if (iss == LIB$_QUEWASEMP) return;
3337             _ckvmssts_noperl(iss);
3338             _ckvmssts_noperl(lib$free_vm(&n, &b));
3339         }
3340     }
3341
3342     iss = lib$remqti(&p->free, &b);
3343     if (iss == LIB$_QUEWASEMP) {
3344         int n = sizeof(CBuf) + p->bufsize;
3345         _ckvmssts_noperl(lib$get_vm(&n, &b));
3346         b->buf = (char *) b + sizeof(CBuf);
3347     } else {
3348        _ckvmssts_noperl(iss);
3349     }
3350
3351     p->curr = b;
3352     iss = sys$qio(0,p->chan_in,
3353              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3354              &p->iosb,
3355              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3356     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3357     _ckvmssts_noperl(iss);
3358 }
3359
3360
3361 /* writes queued buffers to output, waits for each to complete before
3362    doing the next */
3363
3364 static void
3365 pipe_tochild2_ast(pPipe p)
3366 {
3367     pCBuf b = p->curr2;
3368     int iss = p->iosb2.status;
3369     int n = sizeof(CBuf) + p->bufsize;
3370     int done = (p->info && p->info->done) ||
3371               iss == SS$_CANCEL || iss == SS$_ABORT;
3372 #if defined(PERL_IMPLICIT_CONTEXT)
3373     pTHX = p->thx;
3374 #endif
3375
3376     do {
3377         if (p->type) {         /* type=1 has old buffer, dispose */
3378             if (p->shut_on_empty) {
3379                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3380             } else {
3381                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3382             }
3383             p->type = 0;
3384         }
3385
3386         iss = lib$remqti(&p->wait, &b);
3387         if (iss == LIB$_QUEWASEMP) {
3388             if (p->shut_on_empty) {
3389                 if (done) {
3390                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3391                     *p->pipe_done = TRUE;
3392                     _ckvmssts_noperl(sys$setef(pipe_ef));
3393                 } else {
3394                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3395                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3396                 }
3397                 return;
3398             }
3399             p->need_wake = TRUE;
3400             return;
3401         }
3402         _ckvmssts_noperl(iss);
3403         p->type = 1;
3404     } while (done);
3405
3406
3407     p->curr2 = b;
3408     if (b->eof) {
3409         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3410             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3411     } else {
3412         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3413             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3414     }
3415
3416     return;
3417
3418 }
3419
3420
3421 static pPipe
3422 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3423 {
3424     pPipe p;
3425     char mbx1[64], mbx2[64];
3426     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3427                                       DSC$K_CLASS_S, mbx1},
3428                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3429                                       DSC$K_CLASS_S, mbx2};
3430     unsigned int dviitm = DVI$_DEVBUFSIZ;
3431
3432     int n = sizeof(Pipe);
3433     _ckvmssts_noperl(lib$get_vm(&n, &p));
3434     create_mbx(&p->chan_in , &d_mbx1);
3435     create_mbx(&p->chan_out, &d_mbx2);
3436
3437     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3438     n = p->bufsize * sizeof(char);
3439     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3440     p->shut_on_empty = FALSE;
3441     p->info   = 0;
3442     p->type   = 0;
3443     p->iosb.status = SS$_NORMAL;
3444 #if defined(PERL_IMPLICIT_CONTEXT)
3445     p->thx = aTHX;
3446 #endif
3447     pipe_infromchild_ast(p);
3448
3449     strcpy(wmbx, mbx1);
3450     strcpy(rmbx, mbx2);
3451     return p;
3452 }
3453
3454 static void
3455 pipe_infromchild_ast(pPipe p)
3456 {
3457     int iss = p->iosb.status;
3458     int eof = (iss == SS$_ENDOFFILE);
3459     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3460     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3461 #if defined(PERL_IMPLICIT_CONTEXT)
3462     pTHX = p->thx;
3463 #endif
3464
3465     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3466         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3467         p->chan_out = 0;
3468     }
3469
3470     /* read completed:
3471             input shutdown if EOF from self (done or shut_on_empty)
3472             output shutdown if closing flag set (my_pclose)
3473             send data/eof from child or eof from self
3474             otherwise, re-read (snarf of data from child)
3475     */
3476
3477     if (p->type == 1) {
3478         p->type = 0;
3479         if (myeof && p->chan_in) {                  /* input shutdown */
3480             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3481             p->chan_in = 0;
3482         }
3483
3484         if (p->chan_out) {
3485             if (myeof || kideof) {      /* pass EOF to parent */
3486                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3487                                          pipe_infromchild_ast, p,
3488                                          0, 0, 0, 0, 0, 0));
3489                 return;
3490             } else if (eof) {       /* eat EOF --- fall through to read*/
3491
3492             } else {                /* transmit data */
3493                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3494                                          pipe_infromchild_ast,p,
3495                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3496                 return;
3497             }
3498         }
3499     }
3500
3501     /*  everything shut? flag as done */
3502
3503     if (!p->chan_in && !p->chan_out) {
3504         *p->pipe_done = TRUE;
3505         _ckvmssts_noperl(sys$setef(pipe_ef));
3506         return;
3507     }
3508
3509     /* write completed (or read, if snarfing from child)
3510             if still have input active,
3511                queue read...immediate mode if shut_on_empty so we get EOF if empty
3512             otherwise,
3513                check if Perl reading, generate EOFs as needed
3514     */
3515
3516     if (p->type == 0) {
3517         p->type = 1;
3518         if (p->chan_in) {
3519             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3520                           pipe_infromchild_ast,p,
3521                           p->buf, p->bufsize, 0, 0, 0, 0);
3522             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3523             _ckvmssts_noperl(iss);
3524         } else {           /* send EOFs for extra reads */
3525             p->iosb.status = SS$_ENDOFFILE;
3526             p->iosb.dvispec = 0;
3527             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3528                                      0, 0, 0,
3529                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3530         }
3531     }
3532 }
3533
3534 static pPipe
3535 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3536 {
3537     pPipe p;
3538     char mbx[64];
3539     unsigned long dviitm = DVI$_DEVBUFSIZ;
3540     struct stat s;
3541     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3542                                       DSC$K_CLASS_S, mbx};
3543     int n = sizeof(Pipe);
3544
3545     /* things like terminals and mbx's don't need this filter */
3546     if (fd && fstat(fd,&s) == 0) {
3547         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3548         char device[65];
3549         unsigned short dev_len;
3550         struct dsc$descriptor_s d_dev;
3551         char * cptr;
3552         struct item_list_3 items[3];
3553         int status;
3554         unsigned short dvi_iosb[4];
3555
3556         cptr = getname(fd, out, 1);
3557         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3558         d_dev.dsc$a_pointer = out;
3559         d_dev.dsc$w_length = strlen(out);
3560         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3561         d_dev.dsc$b_class = DSC$K_CLASS_S;
3562
3563         items[0].len = 4;
3564         items[0].code = DVI$_DEVCHAR;
3565         items[0].bufadr = &devchar;
3566         items[0].retadr = NULL;
3567         items[1].len = 64;
3568         items[1].code = DVI$_FULLDEVNAM;
3569         items[1].bufadr = device;
3570         items[1].retadr = &dev_len;
3571         items[2].len = 0;
3572         items[2].code = 0;
3573
3574         status = sys$getdviw
3575                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3576         _ckvmssts_noperl(status);
3577         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3578             device[dev_len] = 0;
3579
3580             if (!(devchar & DEV$M_DIR)) {
3581                 strcpy(out, device);
3582                 return 0;
3583             }
3584         }
3585     }
3586
3587     _ckvmssts_noperl(lib$get_vm(&n, &p));
3588     p->fd_out = dup(fd);
3589     create_mbx(&p->chan_in, &d_mbx);
3590     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3591     n = (p->bufsize+1) * sizeof(char);
3592     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3593     p->shut_on_empty = FALSE;
3594     p->retry = 0;
3595     p->info  = 0;
3596     strcpy(out, mbx);
3597
3598     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3599                              pipe_mbxtofd_ast, p,
3600                              p->buf, p->bufsize, 0, 0, 0, 0));
3601
3602     return p;
3603 }
3604
3605 static void
3606 pipe_mbxtofd_ast(pPipe p)
3607 {
3608     int iss = p->iosb.status;
3609     int done = p->info->done;
3610     int iss2;
3611     int eof = (iss == SS$_ENDOFFILE);
3612     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3613     int err = !(iss&1) && !eof;
3614 #if defined(PERL_IMPLICIT_CONTEXT)
3615     pTHX = p->thx;
3616 #endif
3617
3618     if (done && myeof) {               /* end piping */
3619         close(p->fd_out);
3620         sys$dassgn(p->chan_in);
3621         *p->pipe_done = TRUE;
3622         _ckvmssts_noperl(sys$setef(pipe_ef));
3623         return;
3624     }
3625
3626     if (!err && !eof) {             /* good data to send to file */
3627         p->buf[p->iosb.count] = '\n';
3628         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3629         if (iss2 < 0) {
3630             p->retry++;
3631             if (p->retry < MAX_RETRY) {
3632                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3633                 return;
3634             }
3635         }
3636         p->retry = 0;
3637     } else if (err) {
3638         _ckvmssts_noperl(iss);
3639     }
3640
3641
3642     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3643           pipe_mbxtofd_ast, p,
3644           p->buf, p->bufsize, 0, 0, 0, 0);
3645     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3646     _ckvmssts_noperl(iss);
3647 }
3648
3649
3650 typedef struct _pipeloc     PLOC;
3651 typedef struct _pipeloc*   pPLOC;
3652
3653 struct _pipeloc {
3654     pPLOC   next;
3655     char    dir[NAM$C_MAXRSS+1];
3656 };
3657 static pPLOC  head_PLOC = 0;
3658
3659 void
3660 free_pipelocs(pTHX_ void *head)
3661 {
3662     pPLOC p, pnext;
3663     pPLOC *pHead = (pPLOC *)head;
3664
3665     p = *pHead;
3666     while (p) {
3667         pnext = p->next;
3668         PerlMem_free(p);
3669         p = pnext;
3670     }
3671     *pHead = 0;
3672 }
3673
3674 static void
3675 store_pipelocs(pTHX)
3676 {
3677     int    i;
3678     pPLOC  p;
3679     AV    *av = 0;
3680     SV    *dirsv;
3681     GV    *gv;
3682     char  *dir, *x;
3683     char  *unixdir;
3684     char  temp[NAM$C_MAXRSS+1];
3685     STRLEN n_a;
3686
3687     if (head_PLOC)
3688         free_pipelocs(aTHX_ &head_PLOC);
3689
3690 /*  the . directory from @INC comes last */
3691
3692     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3693     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3694     p->next = head_PLOC;
3695     head_PLOC = p;
3696     strcpy(p->dir,"./");
3697
3698 /*  get the directory from $^X */
3699
3700     unixdir = PerlMem_malloc(VMS_MAXRSS);
3701     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3702
3703 #ifdef PERL_IMPLICIT_CONTEXT
3704     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3705 #else
3706     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3707 #endif
3708         strcpy(temp, PL_origargv[0]);
3709         x = strrchr(temp,']');
3710         if (x == NULL) {
3711         x = strrchr(temp,'>');
3712           if (x == NULL) {
3713             /* It could be a UNIX path */
3714             x = strrchr(temp,'/');
3715           }
3716         }
3717         if (x)
3718           x[1] = '\0';
3719         else {
3720           /* Got a bare name, so use default directory */
3721           temp[0] = '.';
3722           temp[1] = '\0';
3723         }
3724
3725         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3726             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3727             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3728             p->next = head_PLOC;
3729             head_PLOC = p;
3730             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3731             p->dir[NAM$C_MAXRSS] = '\0';
3732         }
3733     }
3734
3735 /*  reverse order of @INC entries, skip "." since entered above */
3736
3737 #ifdef PERL_IMPLICIT_CONTEXT
3738     if (aTHX)
3739 #endif
3740     if (PL_incgv) av = GvAVn(PL_incgv);
3741
3742     for (i = 0; av && i <= AvFILL(av); i++) {
3743         dirsv = *av_fetch(av,i,TRUE);
3744
3745         if (SvROK(dirsv)) continue;
3746         dir = SvPVx(dirsv,n_a);
3747         if (strcmp(dir,".") == 0) continue;
3748         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3749             continue;
3750
3751         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3752         p->next = head_PLOC;
3753         head_PLOC = p;
3754         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3755         p->dir[NAM$C_MAXRSS] = '\0';
3756     }
3757
3758 /* most likely spot (ARCHLIB) put first in the list */
3759
3760 #ifdef ARCHLIB_EXP
3761     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3762         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3763         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3764         p->next = head_PLOC;
3765         head_PLOC = p;
3766         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3767         p->dir[NAM$C_MAXRSS] = '\0';
3768     }
3769 #endif
3770     PerlMem_free(unixdir);
3771 }
3772
3773 static I32
3774 Perl_cando_by_name_int
3775    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3776 #if !defined(PERL_IMPLICIT_CONTEXT)
3777 #define cando_by_name_int               Perl_cando_by_name_int
3778 #else
3779 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3780 #endif
3781
3782 static char *
3783 find_vmspipe(pTHX)
3784 {
3785     static int   vmspipe_file_status = 0;
3786     static char  vmspipe_file[NAM$C_MAXRSS+1];
3787
3788     /* already found? Check and use ... need read+execute permission */
3789
3790     if (vmspipe_file_status == 1) {
3791         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3792          && cando_by_name_int
3793            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3794             return vmspipe_file;
3795         }
3796         vmspipe_file_status = 0;
3797     }
3798
3799     /* scan through stored @INC, $^X */
3800
3801     if (vmspipe_file_status == 0) {
3802         char file[NAM$C_MAXRSS+1];
3803         pPLOC  p = head_PLOC;
3804
3805         while (p) {
3806             char * exp_res;
3807             int dirlen;
3808             strcpy(file, p->dir);
3809             dirlen = strlen(file);
3810             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3811             file[NAM$C_MAXRSS] = '\0';
3812             p = p->next;
3813
3814             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3815             if (!exp_res) continue;
3816
3817             if (cando_by_name_int
3818                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3819              && cando_by_name_int
3820                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3821                 vmspipe_file_status = 1;
3822                 return vmspipe_file;
3823             }
3824         }
3825         vmspipe_file_status = -1;   /* failed, use tempfiles */
3826     }
3827
3828     return 0;
3829 }
3830
3831 static FILE *
3832 vmspipe_tempfile(pTHX)
3833 {
3834     char file[NAM$C_MAXRSS+1];
3835     FILE *fp;
3836     static int index = 0;
3837     Stat_t s0, s1;
3838     int cmp_result;
3839
3840     /* create a tempfile */
3841
3842     /* we can't go from   W, shr=get to  R, shr=get without
3843        an intermediate vulnerable state, so don't bother trying...
3844
3845        and lib$spawn doesn't shr=put, so have to close the write
3846
3847        So... match up the creation date/time and the FID to
3848        make sure we're dealing with the same file
3849
3850     */
3851
3852     index++;
3853     if (!decc_filename_unix_only) {
3854       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3855       fp = fopen(file,"w");
3856       if (!fp) {
3857         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3858         fp = fopen(file,"w");
3859         if (!fp) {
3860             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3861             fp = fopen(file,"w");
3862         }
3863       }
3864      }
3865      else {
3866       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3867       fp = fopen(file,"w");
3868       if (!fp) {
3869         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3870         fp = fopen(file,"w");
3871         if (!fp) {
3872           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3873           fp = fopen(file,"w");
3874         }
3875       }
3876     }
3877     if (!fp) return 0;  /* we're hosed */
3878
3879     fprintf(fp,"$! 'f$verify(0)'\n");
3880     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3881     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3882     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3883     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3884     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3885     fprintf(fp,"$ perl_del    = \"delete\"\n");
3886     fprintf(fp,"$ pif         = \"if\"\n");
3887     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3888     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3889     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3890     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3891     fprintf(fp,"$!  --- build command line to get max possible length\n");
3892     fprintf(fp,"$c=perl_popen_cmd0\n");
3893     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3894     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3895     fprintf(fp,"$x=perl_popen_cmd3\n");
3896     fprintf(fp,"$c=c+x\n");
3897     fprintf(fp,"$ perl_on\n");
3898     fprintf(fp,"$ 'c'\n");
3899     fprintf(fp,"$ perl_status = $STATUS\n");
3900     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3901     fprintf(fp,"$ perl_exit 'perl_status'\n");
3902     fsync(fileno(fp));
3903
3904     fgetname(fp, file, 1);
3905     fstat(fileno(fp), &s0.crtl_stat);
3906     fclose(fp);
3907
3908     if (decc_filename_unix_only)
3909         int_tounixspec(file, file, NULL);
3910     fp = fopen(file,"r","shr=get");
3911     if (!fp) return 0;
3912     fstat(fileno(fp), &s1.crtl_stat);
3913
3914     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3915     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3916         fclose(fp);
3917         return 0;
3918     }
3919
3920     return fp;
3921 }
3922
3923
3924 static int vms_is_syscommand_xterm(void)
3925 {
3926     const static struct dsc$descriptor_s syscommand_dsc =
3927       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3928
3929     const static struct dsc$descriptor_s decwdisplay_dsc =
3930       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3931
3932     struct item_list_3 items[2];
3933     unsigned short dvi_iosb[4];
3934     unsigned long devchar;
3935     unsigned long devclass;
3936     int status;
3937
3938     /* Very simple check to guess if sys$command is a decterm? */
3939     /* First see if the DECW$DISPLAY: device exists */
3940     items[0].len = 4;
3941     items[0].code = DVI$_DEVCHAR;
3942     items[0].bufadr = &devchar;
3943     items[0].retadr = NULL;
3944     items[1].len = 0;
3945     items[1].code = 0;
3946
3947     status = sys$getdviw
3948         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3949
3950     if ($VMS_STATUS_SUCCESS(status)) {
3951         status = dvi_iosb[0];
3952     }
3953
3954     if (!$VMS_STATUS_SUCCESS(status)) {
3955         SETERRNO(EVMSERR, status);
3956         return -1;
3957     }
3958
3959     /* If it does, then for now assume that we are on a workstation */
3960     /* Now verify that SYS$COMMAND is a terminal */
3961     /* for creating the debugger DECTerm */
3962
3963     items[0].len = 4;
3964     items[0].code = DVI$_DEVCLASS;
3965     items[0].bufadr = &devclass;
3966     items[0].retadr = NULL;
3967     items[1].len = 0;
3968     items[1].code = 0;
3969
3970     status = sys$getdviw
3971         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3972
3973     if ($VMS_STATUS_SUCCESS(status)) {
3974         status = dvi_iosb[0];
3975     }
3976
3977     if (!$VMS_STATUS_SUCCESS(status)) {
3978         SETERRNO(EVMSERR, status);
3979         return -1;
3980     }
3981     else {
3982         if (devclass == DC$_TERM) {
3983             return 0;
3984         }
3985     }
3986     return -1;
3987 }
3988
3989 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3990 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3991 {
3992     int status;
3993     int ret_stat;
3994     char * ret_char;
3995     char device_name[65];
3996     unsigned short device_name_len;
3997     struct dsc$descriptor_s customization_dsc;
3998     struct dsc$descriptor_s device_name_dsc;
3999     const char * cptr;
4000     char * tptr;
4001     char customization[200];
4002     char title[40];
4003     pInfo info = NULL;
4004     char mbx1[64];
4005     unsigned short p_chan;
4006     int n;
4007     unsigned short iosb[4];
4008     struct item_list_3 items[2];
4009     const char * cust_str =
4010         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
4011     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
4012                                           DSC$K_CLASS_S, mbx1};
4013
4014      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4015     /*---------------------------------------*/
4016     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
4017
4018
4019     /* Make sure that this is from the Perl debugger */
4020     ret_char = strstr(cmd," xterm ");
4021     if (ret_char == NULL)
4022         return NULL;
4023     cptr = ret_char + 7;
4024     ret_char = strstr(cmd,"tty");
4025     if (ret_char == NULL)
4026         return NULL;
4027     ret_char = strstr(cmd,"sleep");
4028     if (ret_char == NULL)
4029         return NULL;
4030
4031     if (decw_term_port == 0) {
4032         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4033         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4034         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4035
4036        status = lib$find_image_symbol
4037                                (&filename1_dsc,
4038                                 &decw_term_port_dsc,
4039                                 (void *)&decw_term_port,
4040                                 NULL,
4041                                 0);
4042
4043         /* Try again with the other image name */
4044         if (!$VMS_STATUS_SUCCESS(status)) {
4045
4046            status = lib$find_image_symbol
4047                                (&filename2_dsc,
4048                                 &decw_term_port_dsc,
4049                                 (void *)&decw_term_port,
4050                                 NULL,
4051                                 0);
4052
4053         }
4054
4055     }
4056
4057
4058     /* No decw$term_port, give it up */
4059     if (!$VMS_STATUS_SUCCESS(status))
4060         return NULL;
4061
4062     /* Are we on a workstation? */
4063     /* to do: capture the rows / columns and pass their properties */
4064     ret_stat = vms_is_syscommand_xterm();
4065     if (ret_stat < 0)
4066         return NULL;
4067
4068     /* Make the title: */
4069     ret_char = strstr(cptr,"-title");
4070     if (ret_char != NULL) {
4071         while ((*cptr != 0) && (*cptr != '\"')) {
4072             cptr++;
4073         }
4074         if (*cptr == '\"')
4075             cptr++;
4076         n = 0;
4077         while ((*cptr != 0) && (*cptr != '\"')) {
4078             title[n] = *cptr;
4079             n++;
4080             if (n == 39) {
4081                 title[39] == 0;
4082                 break;
4083             }
4084             cptr++;
4085         }
4086         title[n] = 0;
4087     }
4088     else {
4089             /* Default title */
4090             strcpy(title,"Perl Debug DECTerm");
4091     }
4092     sprintf(customization, cust_str, title);
4093
4094     customization_dsc.dsc$a_pointer = customization;
4095     customization_dsc.dsc$w_length = strlen(customization);
4096     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4097     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4098
4099     device_name_dsc.dsc$a_pointer = device_name;
4100     device_name_dsc.dsc$w_length = sizeof device_name -1;
4101     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4102     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4103
4104     device_name_len = 0;
4105
4106     /* Try to create the window */
4107      status = (*decw_term_port)
4108        (NULL,
4109         NULL,
4110         &customization_dsc,
4111         &device_name_dsc,
4112         &device_name_len,
4113         NULL,
4114         NULL,
4115         NULL);
4116     if (!$VMS_STATUS_SUCCESS(status)) {
4117         SETERRNO(EVMSERR, status);
4118         return NULL;
4119     }
4120
4121     device_name[device_name_len] = '\0';
4122
4123     /* Need to set this up to look like a pipe for cleanup */
4124     n = sizeof(Info);
4125     status = lib$get_vm(&n, &info);
4126     if (!$VMS_STATUS_SUCCESS(status)) {
4127         SETERRNO(ENOMEM, status);
4128         return NULL;
4129     }
4130
4131     info->mode = *mode;
4132     info->done = FALSE;
4133     info->completion = 0;
4134     info->closing    = FALSE;
4135     info->in         = 0;
4136     info->out        = 0;
4137     info->err        = 0;
4138     info->fp         = NULL;
4139     info->useFILE    = 0;
4140     info->waiting    = 0;
4141     info->in_done    = TRUE;
4142     info->out_done   = TRUE;
4143     info->err_done   = TRUE;
4144
4145     /* Assign a channel on this so that it will persist, and not login */
4146     /* We stash this channel in the info structure for reference. */
4147     /* The created xterm self destructs when the last channel is removed */
4148     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4149     /* So leave this assigned. */
4150     device_name_dsc.dsc$w_length = device_name_len;
4151     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4152     if (!$VMS_STATUS_SUCCESS(status)) {
4153         SETERRNO(EVMSERR, status);
4154         return NULL;
4155     }
4156     info->xchan_valid = 1;
4157
4158     /* Now create a mailbox to be read by the application */
4159
4160     create_mbx(&p_chan, &d_mbx1);
4161
4162     /* write the name of the created terminal to the mailbox */
4163     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4164             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4165
4166     if (!$VMS_STATUS_SUCCESS(status)) {
4167         SETERRNO(EVMSERR, status);
4168         return NULL;
4169     }
4170
4171     info->fp  = PerlIO_open(mbx1, mode);
4172
4173     /* Done with this channel */
4174     sys$dassgn(p_chan);
4175
4176     /* If any errors, then clean up */
4177     if (!info->fp) {
4178         n = sizeof(Info);
4179         _ckvmssts_noperl(lib$free_vm(&n, &info));
4180         return NULL;
4181         }
4182
4183     /* All done */
4184     return info->fp;
4185 }
4186
4187 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4188
4189 static PerlIO *
4190 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4191 {
4192     static int handler_set_up = FALSE;
4193     PerlIO * ret_fp;
4194     unsigned long int sts, flags = CLI$M_NOWAIT;
4195     /* The use of a GLOBAL table (as was done previously) rendered
4196      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4197      * environment.  Hence we've switched to LOCAL symbol table.
4198      */
4199     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4200     int j, wait = 0, n;
4201     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4202     char *in, *out, *err, mbx[512];
4203     FILE *tpipe = 0;
4204     char tfilebuf[NAM$C_MAXRSS+1];
4205     pInfo info = NULL;
4206     char cmd_sym_name[20];
4207     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4208                                       DSC$K_CLASS_S, symbol};
4209     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4210                                       DSC$K_CLASS_S, 0};
4211     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4212                                       DSC$K_CLASS_S, cmd_sym_name};
4213     struct dsc$descriptor_s *vmscmd;
4214     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4215     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4216     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4217
4218     /* Check here for Xterm create request.  This means looking for
4219      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4220      *  is possible to create an xterm.
4221      */
4222     if (*in_mode == 'r') {
4223         PerlIO * xterm_fd;
4224
4225         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4226         if (xterm_fd != NULL)
4227             return xterm_fd;
4228     }
4229
4230     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4231
4232     /* once-per-program initialization...
4233        note that the SETAST calls and the dual test of pipe_ef
4234        makes sure that only the FIRST thread through here does
4235        the initialization...all other threads wait until it's
4236        done.
4237
4238        Yeah, uglier than a pthread call, it's got all the stuff inline
4239        rather than in a separate routine.
4240     */
4241
4242     if (!pipe_ef) {
4243         _ckvmssts_noperl(sys$setast(0));
4244         if (!pipe_ef) {
4245             unsigned long int pidcode = JPI$_PID;
4246             $DESCRIPTOR(d_delay, RETRY_DELAY);
4247             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4248             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4249             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4250         }
4251         if (!handler_set_up) {
4252           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4253           handler_set_up = TRUE;
4254         }
4255         _ckvmssts_noperl(sys$setast(1));
4256     }
4257
4258     /* see if we can find a VMSPIPE.COM */
4259
4260     tfilebuf[0] = '@';
4261     vmspipe = find_vmspipe(aTHX);
4262     if (vmspipe) {
4263         strcpy(tfilebuf+1,vmspipe);
4264     } else {        /* uh, oh...we're in tempfile hell */
4265         tpipe = vmspipe_tempfile(aTHX);
4266         if (!tpipe) {       /* a fish popular in Boston */
4267             if (ckWARN(WARN_PIPE)) {
4268                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4269             }
4270         return NULL;
4271         }
4272         fgetname(tpipe,tfilebuf+1,1);
4273     }
4274     vmspipedsc.dsc$a_pointer = tfilebuf;
4275     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4276
4277     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4278     if (!(sts & 1)) {
4279       switch (sts) {
4280         case RMS$_FNF:  case RMS$_DNF:
4281           set_errno(ENOENT); break;
4282         case RMS$_DIR:
4283           set_errno(ENOTDIR); break;
4284         case RMS$_DEV:
4285           set_errno(ENODEV); break;
4286         case RMS$_PRV:
4287           set_errno(EACCES); break;
4288         case RMS$_SYN:
4289           set_errno(EINVAL); break;
4290         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4291           set_errno(E2BIG); break;
4292         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4293           _ckvmssts_noperl(sts); /* fall through */
4294         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4295           set_errno(EVMSERR);
4296       }
4297       set_vaxc_errno(sts);
4298       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4299         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4300       }
4301       *psts = sts;
4302       return NULL;
4303     }
4304     n = sizeof(Info);
4305     _ckvmssts_noperl(lib$get_vm(&n, &info));
4306
4307     strcpy(mode,in_mode);
4308     info->mode = *mode;
4309     info->done = FALSE;
4310     info->completion = 0;
4311     info->closing    = FALSE;
4312     info->in         = 0;
4313     info->out        = 0;
4314     info->err        = 0;
4315     info->fp         = NULL;
4316     info->useFILE    = 0;
4317     info->waiting    = 0;
4318     info->in_done    = TRUE;
4319     info->out_done   = TRUE;
4320     info->err_done   = TRUE;
4321     info->xchan      = 0;
4322     info->xchan_valid = 0;
4323
4324     in = PerlMem_malloc(VMS_MAXRSS);
4325     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4326     out = PerlMem_malloc(VMS_MAXRSS);
4327     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4328     err = PerlMem_malloc(VMS_MAXRSS);
4329     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4330
4331     in[0] = out[0] = err[0] = '\0';
4332
4333     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4334         info->useFILE = 1;
4335         strcpy(p,p+1);
4336     }
4337     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4338         wait = 1;
4339         strcpy(p,p+1);
4340     }
4341
4342     if (*mode == 'r') {             /* piping from subroutine */
4343
4344         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4345         if (info->out) {
4346             info->out->pipe_done = &info->out_done;
4347             info->out_done = FALSE;
4348             info->out->info = info;
4349         }
4350         if (!info->useFILE) {
4351             info->fp  = PerlIO_open(mbx, mode);
4352         } else {
4353             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4354             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4355         }
4356
4357         if (!info->fp && info->out) {
4358             sys$cancel(info->out->chan_out);
4359
4360             while (!info->out_done) {
4361                 int done;
4362                 _ckvmssts_noperl(sys$setast(0));
4363                 done = info->out_done;
4364                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4365                 _ckvmssts_noperl(sys$setast(1));
4366                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4367             }
4368
4369             if (info->out->buf) {
4370                 n = info->out->bufsize * sizeof(char);
4371                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4372             }
4373             n = sizeof(Pipe);
4374             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4375             n = sizeof(Info);
4376             _ckvmssts_noperl(lib$free_vm(&n, &info));
4377             *psts = RMS$_FNF;
4378             return NULL;
4379         }
4380
4381         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4382         if (info->err) {
4383             info->err->pipe_done = &info->err_done;
4384             info->err_done = FALSE;
4385             info->err->info = info;
4386         }
4387
4388     } else if (*mode == 'w') {      /* piping to subroutine */
4389
4390         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4391         if (info->out) {
4392             info->out->pipe_done = &info->out_done;
4393             info->out_done = FALSE;
4394             info->out->info = info;
4395         }
4396
4397         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4398         if (info->err) {
4399             info->err->pipe_done = &info->err_done;
4400             info->err_done = FALSE;
4401             info->err->info = info;
4402         }
4403
4404         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4405         if (!info->useFILE) {
4406             info->fp  = PerlIO_open(mbx, mode);
4407         } else {
4408             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4409             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4410         }
4411
4412         if (info->in) {
4413             info->in->pipe_done = &info->in_done;
4414             info->in_done = FALSE;
4415             info->in->info = info;
4416         }
4417
4418         /* error cleanup */
4419         if (!info->fp && info->in) {
4420             info->done = TRUE;
4421             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4422                                       0, 0, 0, 0, 0, 0, 0, 0));
4423
4424             while (!info->in_done) {
4425                 int done;
4426                 _ckvmssts_noperl(sys$setast(0));
4427                 done = info->in_done;
4428                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4429                 _ckvmssts_noperl(sys$setast(1));
4430                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4431             }
4432
4433             if (info->in->buf) {
4434                 n = info->in->bufsize * sizeof(char);
4435                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4436             }
4437             n = sizeof(Pipe);
4438             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4439             n = sizeof(Info);
4440             _ckvmssts_noperl(lib$free_vm(&n, &info));
4441             *psts = RMS$_FNF;
4442             return NULL;
4443         }
4444
4445
4446     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4447         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4448         if (info->out) {
4449             info->out->pipe_done = &info->out_done;
4450             info->out_done = FALSE;
4451             info->out->info = info;
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
4462     symbol[MAX_DCL_SYMBOL] = '\0';
4463
4464     strncpy(symbol, in, MAX_DCL_SYMBOL);
4465     d_symbol.dsc$w_length = strlen(symbol);
4466     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4467
4468     strncpy(symbol, err, MAX_DCL_SYMBOL);
4469     d_symbol.dsc$w_length = strlen(symbol);
4470     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4471
4472     strncpy(symbol, out, MAX_DCL_SYMBOL);
4473     d_symbol.dsc$w_length = strlen(symbol);
4474     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4475
4476     /* Done with the names for the pipes */
4477     PerlMem_free(err);
4478     PerlMem_free(out);
4479     PerlMem_free(in);
4480
4481     p = vmscmd->dsc$a_pointer;
4482     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4483     if (*p == '$') p++;                         /* remove leading $ */
4484     while (*p == ' ' || *p == '\t') p++;
4485
4486     for (j = 0; j < 4; j++) {
4487         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4488         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4489
4490     strncpy(symbol, p, MAX_DCL_SYMBOL);
4491     d_symbol.dsc$w_length = strlen(symbol);
4492     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4493
4494         if (strlen(p) > MAX_DCL_SYMBOL) {
4495             p += MAX_DCL_SYMBOL;
4496         } else {
4497             p += strlen(p);
4498         }
4499     }
4500     _ckvmssts_noperl(sys$setast(0));
4501     info->next=open_pipes;  /* prepend to list */
4502     open_pipes=info;
4503     _ckvmssts_noperl(sys$setast(1));
4504     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4505      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4506      * have SYS$COMMAND if we need it.
4507      */
4508     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4509                       0, &info->pid, &info->completion,
4510                       0, popen_completion_ast,info,0,0,0));
4511
4512     /* if we were using a tempfile, close it now */
4513
4514     if (tpipe) fclose(tpipe);
4515
4516     /* once the subprocess is spawned, it has copied the symbols and
4517        we can get rid of ours */
4518
4519     for (j = 0; j < 4; j++) {
4520         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4521         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4522     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4523     }
4524     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4525     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4526     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4527     vms_execfree(vmscmd);
4528
4529 #ifdef PERL_IMPLICIT_CONTEXT
4530     if (aTHX)
4531 #endif
4532     PL_forkprocess = info->pid;
4533
4534     ret_fp = info->fp;
4535     if (wait) {
4536          dSAVEDERRNO;
4537          int done = 0;
4538          while (!done) {
4539              _ckvmssts_noperl(sys$setast(0));
4540              done = info->done;
4541              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4542              _ckvmssts_noperl(sys$setast(1));
4543              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4544          }
4545         *psts = info->completion;
4546 /* Caller thinks it is open and tries to close it. */
4547 /* This causes some problems, as it changes the error status */
4548 /*        my_pclose(info->fp); */
4549
4550          /* If we did not have a file pointer open, then we have to */
4551          /* clean up here or eventually we will run out of something */
4552          SAVE_ERRNO;
4553          if (info->fp == NULL) {
4554              my_pclose_pinfo(aTHX_ info);
4555          }
4556          RESTORE_ERRNO;
4557
4558     } else {
4559         *psts = info->pid;
4560     }
4561     return ret_fp;
4562 }  /* end of safe_popen */
4563
4564
4565 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4566 PerlIO *
4567 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4568 {
4569     int sts;
4570     TAINT_ENV();
4571     TAINT_PROPER("popen");
4572     PERL_FLUSHALL_FOR_CHILD;
4573     return safe_popen(aTHX_ cmd,mode,&sts);
4574 }
4575
4576 /*}}}*/
4577
4578
4579 /* Routine to close and cleanup a pipe info structure */
4580
4581 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4582
4583     unsigned long int retsts;
4584     int done, iss, n;
4585     int status;
4586     pInfo next, last;
4587
4588     /* If we were writing to a subprocess, insure that someone reading from
4589      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4590      * produce an EOF record in the mailbox.
4591      *
4592      *  well, at least sometimes it *does*, so we have to watch out for
4593      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4594      */
4595      if (info->fp) {
4596         if (!info->useFILE
4597 #if defined(USE_ITHREADS)
4598           && my_perl
4599 #endif
4600           && PL_perlio_fd_refcnt)
4601             PerlIO_flush(info->fp);
4602         else
4603             fflush((FILE *)info->fp);
4604     }
4605
4606     _ckvmssts(sys$setast(0));
4607      info->closing = TRUE;
4608      done = info->done && info->in_done && info->out_done && info->err_done;
4609      /* hanging on write to Perl's input? cancel it */
4610      if (info->mode == 'r' && info->out && !info->out_done) {
4611         if (info->out->chan_out) {
4612             _ckvmssts(sys$cancel(info->out->chan_out));
4613             if (!info->out->chan_in) {   /* EOF generation, need AST */
4614                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4615             }
4616         }
4617      }
4618      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4619          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4620                            0, 0, 0, 0, 0, 0));
4621     _ckvmssts(sys$setast(1));
4622     if (info->fp) {
4623      if (!info->useFILE
4624 #if defined(USE_ITHREADS)
4625          && my_perl
4626 #endif
4627          && PL_perlio_fd_refcnt)
4628         PerlIO_close(info->fp);
4629      else
4630         fclose((FILE *)info->fp);
4631     }
4632      /*
4633         we have to wait until subprocess completes, but ALSO wait until all
4634         the i/o completes...otherwise we'll be freeing the "info" structure
4635         that the i/o ASTs could still be using...
4636      */
4637
4638      while (!done) {
4639          _ckvmssts(sys$setast(0));
4640          done = info->done && info->in_done && info->out_done && info->err_done;
4641          if (!done) _ckvmssts(sys$clref(pipe_ef));
4642          _ckvmssts(sys$setast(1));
4643          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4644      }
4645      retsts = info->completion;
4646
4647     /* remove from list of open pipes */
4648     _ckvmssts(sys$setast(0));
4649     last = NULL;
4650     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4651         if (next == info)
4652             break;
4653     }
4654
4655     if (last)
4656         last->next = info->next;
4657     else
4658         open_pipes = info->next;
4659     _ckvmssts(sys$setast(1));
4660
4661     /* free buffers and structures */
4662
4663     if (info->in) {
4664         if (info->in->buf) {
4665             n = info->in->bufsize * sizeof(char);
4666             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4667         }
4668         n = sizeof(Pipe);
4669         _ckvmssts(lib$free_vm(&n, &info->in));
4670     }
4671     if (info->out) {
4672         if (info->out->buf) {
4673             n = info->out->bufsize * sizeof(char);
4674             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4675         }
4676         n = sizeof(Pipe);
4677         _ckvmssts(lib$free_vm(&n, &info->out));
4678     }
4679     if (info->err) {
4680         if (info->err->buf) {
4681             n = info->err->bufsize * sizeof(char);
4682             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4683         }
4684         n = sizeof(Pipe);
4685         _ckvmssts(lib$free_vm(&n, &info->err));
4686     }
4687     n = sizeof(Info);
4688     _ckvmssts(lib$free_vm(&n, &info));
4689
4690     return retsts;
4691 }
4692
4693
4694 /*{{{  I32 my_pclose(PerlIO *fp)*/
4695 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4696 {
4697     pInfo info, last = NULL;
4698     I32 ret_status;
4699
4700     /* Fixme - need ast and mutex protection here */
4701     for (info = open_pipes; info != NULL; last = info, info = info->next)
4702         if (info->fp == fp) break;
4703
4704     if (info == NULL) {  /* no such pipe open */
4705       set_errno(ECHILD); /* quoth POSIX */
4706       set_vaxc_errno(SS$_NONEXPR);
4707       return -1;
4708     }
4709
4710     ret_status = my_pclose_pinfo(aTHX_ info);
4711
4712     return ret_status;
4713
4714 }  /* end of my_pclose() */
4715
4716 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4717   /* Roll our own prototype because we want this regardless of whether
4718    * _VMS_WAIT is defined.
4719    */
4720   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4721 #endif
4722 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4723    created with popen(); otherwise partially emulate waitpid() unless
4724    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4725    Also check processes not considered by the CRTL waitpid().
4726  */
4727 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4728 Pid_t
4729 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4730 {
4731     pInfo info;
4732     int done;
4733     int sts;
4734     int j;
4735
4736     if (statusp) *statusp = 0;
4737
4738     for (info = open_pipes; info != NULL; info = info->next)
4739         if (info->pid == pid) break;
4740
4741     if (info != NULL) {  /* we know about this child */
4742       while (!info->done) {
4743           _ckvmssts(sys$setast(0));
4744           done = info->done;
4745           if (!done) _ckvmssts(sys$clref(pipe_ef));
4746           _ckvmssts(sys$setast(1));
4747           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4748       }
4749
4750       if (statusp) *statusp = info->completion;
4751       return pid;
4752     }
4753
4754     /* child that already terminated? */
4755
4756     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4757         if (closed_list[j].pid == pid) {
4758             if (statusp) *statusp = closed_list[j].completion;
4759             return pid;
4760         }
4761     }
4762
4763     /* fall through if this child is not one of our own pipe children */
4764
4765 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4766
4767       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4768        * in 7.2 did we get a version that fills in the VMS completion
4769        * status as Perl has always tried to do.
4770        */
4771
4772       sts = __vms_waitpid( pid, statusp, flags );
4773
4774       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4775          return sts;
4776
4777       /* If the real waitpid tells us the child does not exist, we
4778        * fall through here to implement waiting for a child that
4779        * was created by some means other than exec() (say, spawned
4780        * from DCL) or to wait for a process that is not a subprocess
4781        * of the current process.
4782        */
4783
4784 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4785
4786     {
4787       $DESCRIPTOR(intdsc,"0 00:00:01");
4788       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4789       unsigned long int pidcode = JPI$_PID, mypid;
4790       unsigned long int interval[2];
4791       unsigned int jpi_iosb[2];
4792       struct itmlst_3 jpilist[2] = {
4793           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4794           {                      0,         0,                 0, 0}
4795       };
4796
4797       if (pid <= 0) {
4798         /* Sorry folks, we don't presently implement rooting around for
4799            the first child we can find, and we definitely don't want to
4800            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4801          */
4802         set_errno(ENOTSUP);
4803         return -1;
4804       }
4805
4806       /* Get the owner of the child so I can warn if it's not mine. If the
4807        * process doesn't exist or I don't have the privs to look at it,
4808        * I can go home early.
4809        */
4810       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4811       if (sts & 1) sts = jpi_iosb[0];
4812       if (!(sts & 1)) {
4813         switch (sts) {
4814             case SS$_NONEXPR:
4815                 set_errno(ECHILD);
4816                 break;
4817             case SS$_NOPRIV:
4818                 set_errno(EACCES);
4819                 break;
4820             default:
4821                 _ckvmssts(sts);
4822         }
4823         set_vaxc_errno(sts);
4824         return -1;
4825       }
4826
4827       if (ckWARN(WARN_EXEC)) {
4828         /* remind folks they are asking for non-standard waitpid behavior */
4829         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4830         if (ownerpid != mypid)
4831           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4832                       "waitpid: process %x is not a child of process %x",
4833                       pid,mypid);
4834       }
4835
4836       /* simply check on it once a second until it's not there anymore. */
4837
4838       _ckvmssts(sys$bintim(&intdsc,interval));
4839       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4840             _ckvmssts(sys$schdwk(0,0,interval,0));
4841             _ckvmssts(sys$hiber());
4842       }
4843       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4844
4845       _ckvmssts(sts);
4846       return pid;
4847     }
4848 }  /* end of waitpid() */
4849 /*}}}*/
4850 /*}}}*/
4851 /*}}}*/
4852
4853 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4854 char *
4855 my_gconvert(double val, int ndig, int trail, char *buf)
4856 {
4857   static char __gcvtbuf[DBL_DIG+1];
4858   char *loc;
4859
4860   loc = buf ? buf : __gcvtbuf;
4861
4862 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4863   if (val < 1) {
4864     sprintf(loc,"%.*g",ndig,val);
4865     return loc;
4866   }
4867 #endif
4868
4869   if (val) {
4870     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4871     return gcvt(val,ndig,loc);
4872   }
4873   else {
4874     loc[0] = '0'; loc[1] = '\0';
4875     return loc;
4876   }
4877
4878 }
4879 /*}}}*/
4880
4881 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4882 static int rms_free_search_context(struct FAB * fab)
4883 {
4884 struct NAM * nam;
4885
4886     nam = fab->fab$l_nam;
4887     nam->nam$b_nop |= NAM$M_SYNCHK;
4888     nam->nam$l_rlf = NULL;
4889     fab->fab$b_dns = 0;
4890     return sys$parse(fab, NULL, NULL);
4891 }
4892
4893 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4894 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4895 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4896 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4897 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4898 #define rms_nam_esll(nam) nam.nam$b_esl
4899 #define rms_nam_esl(nam) nam.nam$b_esl
4900 #define rms_nam_name(nam) nam.nam$l_name
4901 #define rms_nam_namel(nam) nam.nam$l_name
4902 #define rms_nam_type(nam) nam.nam$l_type
4903 #define rms_nam_typel(nam) nam.nam$l_type
4904 #define rms_nam_ver(nam) nam.nam$l_ver
4905 #define rms_nam_verl(nam) nam.nam$l_ver
4906 #define rms_nam_rsll(nam) nam.nam$b_rsl
4907 #define rms_nam_rsl(nam) nam.nam$b_rsl
4908 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4909 #define rms_set_fna(fab, nam, name, size) \
4910         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4911 #define rms_get_fna(fab, nam) fab.fab$l_fna
4912 #define rms_set_dna(fab, nam, name, size) \
4913         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4914 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4915 #define rms_set_esa(nam, name, size) \
4916         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4917 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4918         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4919 #define rms_set_rsa(nam, name, size) \
4920         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4921 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4922         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4923 #define rms_nam_name_type_l_size(nam) \
4924         (nam.nam$b_name + nam.nam$b_type)
4925 #else
4926 static int rms_free_search_context(struct FAB * fab)
4927 {
4928 struct NAML * nam;
4929
4930     nam = fab->fab$l_naml;
4931     nam->naml$b_nop |= NAM$M_SYNCHK;
4932     nam->naml$l_rlf = NULL;
4933     nam->naml$l_long_defname_size = 0;
4934
4935     fab->fab$b_dns = 0;
4936     return sys$parse(fab, NULL, NULL);
4937 }
4938
4939 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4940 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4941 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4942 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4943 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4944 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4945 #define rms_nam_esl(nam) nam.naml$b_esl
4946 #define rms_nam_name(nam) nam.naml$l_name
4947 #define rms_nam_namel(nam) nam.naml$l_long_name
4948 #define rms_nam_type(nam) nam.naml$l_type
4949 #define rms_nam_typel(nam) nam.naml$l_long_type
4950 #define rms_nam_ver(nam) nam.naml$l_ver
4951 #define rms_nam_verl(nam) nam.naml$l_long_ver
4952 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4953 #define rms_nam_rsl(nam) nam.naml$b_rsl
4954 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4955 #define rms_set_fna(fab, nam, name, size) \
4956         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4957         nam.naml$l_long_filename_size = size; \
4958         nam.naml$l_long_filename = name;}
4959 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4960 #define rms_set_dna(fab, nam, name, size) \
4961         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4962         nam.naml$l_long_defname_size = size; \
4963         nam.naml$l_long_defname = name; }
4964 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4965 #define rms_set_esa(nam, name, size) \
4966         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4967         nam.naml$l_long_expand_alloc = size; \
4968         nam.naml$l_long_expand = name; }
4969 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4970         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4971         nam.naml$l_long_expand = l_name; \
4972         nam.naml$l_long_expand_alloc = l_size; }
4973 #define rms_set_rsa(nam, name, size) \
4974         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4975         nam.naml$l_long_result = name; \
4976         nam.naml$l_long_result_alloc = size; }
4977 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4978         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4979         nam.naml$l_long_result = l_name; \
4980         nam.naml$l_long_result_alloc = l_size; }
4981 #define rms_nam_name_type_l_size(nam) \
4982         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4983 #endif
4984
4985
4986 /* rms_erase
4987  * The CRTL for 8.3 and later can create symbolic links in any mode,
4988  * however in 8.3 the unlink/remove/delete routines will only properly handle
4989  * them if one of the PCP modes is active.
4990  */
4991 static int rms_erase(const char * vmsname)
4992 {
4993   int status;
4994   struct FAB myfab = cc$rms_fab;
4995   rms_setup_nam(mynam);
4996
4997   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4998   rms_bind_fab_nam(myfab, mynam);
4999
5000   /* Are we removing all versions? */
5001   if (vms_unlink_all_versions == 1) {
5002     const char * defspec = ";*";
5003     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5004   }
5005
5006 #ifdef NAML$M_OPEN_SPECIAL
5007   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5008 #endif
5009
5010   status = sys$erase(&myfab, 0, 0);
5011
5012   return status;
5013 }
5014
5015
5016 static int
5017 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5018                     const struct dsc$descriptor_s * vms_dst_dsc,
5019                     unsigned long flags)
5020 {
5021     /*  VMS and UNIX handle file permissions differently and the
5022      * the same ACL trick may be needed for renaming files,
5023      * especially if they are directories.
5024      */
5025
5026    /* todo: get kill_file and rename to share common code */
5027    /* I can not find online documentation for $change_acl
5028     * it appears to be replaced by $set_security some time ago */
5029
5030 const unsigned int access_mode = 0;
5031 $DESCRIPTOR(obj_file_dsc,"FILE");
5032 char *vmsname;
5033 char *rslt;
5034 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
5035 int aclsts, fndsts, rnsts = -1;
5036 unsigned int ctx = 0;
5037 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5038 struct dsc$descriptor_s * clean_dsc;
5039
5040 struct myacedef {
5041     unsigned char myace$b_length;
5042     unsigned char myace$b_type;
5043     unsigned short int myace$w_flags;
5044     unsigned long int myace$l_access;
5045     unsigned long int myace$l_ident;
5046 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5047              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5048              0},
5049              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5050
5051 struct item_list_3
5052         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5053                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5054                       {0,0,0,0}},
5055         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5056         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5057                      {0,0,0,0}};
5058
5059
5060     /* Expand the input spec using RMS, since we do not want to put
5061      * ACLs on the target of a symbolic link */
5062     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
5063     if (vmsname == NULL)
5064         return SS$_INSFMEM;
5065
5066     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5067                         vmsname,
5068                         PERL_RMSEXPAND_M_SYMLINK);
5069     if (rslt == NULL) {
5070         PerlMem_free(vmsname);
5071         return SS$_INSFMEM;
5072     }
5073
5074     /* So we get our own UIC to use as a rights identifier,
5075      * and the insert an ACE at the head of the ACL which allows us
5076      * to delete the file.
5077      */
5078     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5079
5080     fildsc.dsc$w_length = strlen(vmsname);
5081     fildsc.dsc$a_pointer = vmsname;
5082     ctx = 0;
5083     newace.myace$l_ident = oldace.myace$l_ident;
5084     rnsts = SS$_ABORT;
5085
5086     /* Grab any existing ACEs with this identifier in case we fail */
5087     clean_dsc = &fildsc;
5088     aclsts = fndsts = sys$get_security(&obj_file_dsc,
5089                                &fildsc,
5090                                NULL,
5091                                OSS$M_WLOCK,
5092                                findlst,
5093                                &ctx,
5094                                &access_mode);
5095
5096     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
5097         /* Add the new ACE . . . */
5098
5099         /* if the sys$get_security succeeded, then ctx is valid, and the
5100          * object/file descriptors will be ignored.  But otherwise they
5101          * are needed
5102          */
5103         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5104                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
5105         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5106             set_errno(EVMSERR);
5107             set_vaxc_errno(aclsts);
5108             PerlMem_free(vmsname);
5109             return aclsts;
5110         }
5111
5112         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5113                                 NULL, NULL,
5114                                 &flags,
5115                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5116
5117         if ($VMS_STATUS_SUCCESS(rnsts)) {
5118             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5119         }
5120
5121         /* Put things back the way they were. */
5122         ctx = 0;
5123         aclsts = sys$get_security(&obj_file_dsc,
5124                                   clean_dsc,
5125                                   NULL,
5126                                   OSS$M_WLOCK,
5127                                   findlst,
5128                                   &ctx,
5129                                   &access_mode);
5130
5131         if ($VMS_STATUS_SUCCESS(aclsts)) {
5132         int sec_flags;
5133
5134             sec_flags = 0;
5135             if (!$VMS_STATUS_SUCCESS(fndsts))
5136                 sec_flags = OSS$M_RELCTX;
5137
5138             /* Get rid of the new ACE */
5139             aclsts = sys$set_security(NULL, NULL, NULL,
5140                                   sec_flags, dellst, &ctx, &access_mode);
5141
5142             /* If there was an old ACE, put it back */
5143             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5144                 addlst[0].bufadr = &oldace;
5145                 aclsts = sys$set_security(NULL, NULL, NULL,
5146                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5147                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5148                     set_errno(EVMSERR);
5149                     set_vaxc_errno(aclsts);
5150                     rnsts = aclsts;
5151                 }
5152             } else {
5153             int aclsts2;
5154
5155                 /* Try to clear the lock on the ACL list */
5156                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5157                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5158
5159                 /* Rename errors are most important */
5160                 if (!$VMS_STATUS_SUCCESS(rnsts))
5161                     aclsts = rnsts;
5162                 set_errno(EVMSERR);
5163                 set_vaxc_errno(aclsts);
5164                 rnsts = aclsts;
5165             }
5166         }
5167         else {
5168             if (aclsts != SS$_ACLEMPTY)
5169                 rnsts = aclsts;
5170         }
5171     }
5172     else
5173         rnsts = fndsts;
5174
5175     PerlMem_free(vmsname);
5176     return rnsts;
5177 }
5178
5179
5180 /*{{{int rename(const char *, const char * */
5181 /* Not exactly what X/Open says to do, but doing it absolutely right
5182  * and efficiently would require a lot more work.  This should be close
5183  * enough to pass all but the most strict X/Open compliance test.
5184  */
5185 int
5186 Perl_rename(pTHX_ const char *src, const char * dst)
5187 {
5188 int retval;
5189 int pre_delete = 0;
5190 int src_sts;
5191 int dst_sts;
5192 Stat_t src_st;
5193 Stat_t dst_st;
5194
5195     /* Validate the source file */
5196     src_sts = flex_lstat(src, &src_st);
5197     if (src_sts != 0) {
5198
5199         /* No source file or other problem */
5200         return src_sts;
5201     }
5202
5203     dst_sts = flex_lstat(dst, &dst_st);
5204     if (dst_sts == 0) {
5205
5206         if (dst_st.st_dev != src_st.st_dev) {
5207             /* Must be on the same device */
5208             errno = EXDEV;
5209             return -1;
5210         }
5211
5212         /* VMS_INO_T_COMPARE is true if the inodes are different
5213          * to match the output of memcmp
5214          */
5215
5216         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5217             /* That was easy, the files are the same! */
5218             return 0;
5219         }
5220
5221         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5222             /* If source is a directory, so must be dest */
5223                 errno = EISDIR;
5224                 return -1;
5225         }
5226
5227     }
5228
5229
5230     if ((dst_sts == 0) &&
5231         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5232
5233         /* We have issues here if vms_unlink_all_versions is set
5234          * If the destination exists, and is not a directory, then
5235          * we must delete in advance.
5236          *
5237          * If the src is a directory, then we must always pre-delete
5238          * the destination.
5239          *
5240          * If we successfully delete the dst in advance, and the rename fails
5241          * X/Open requires that errno be EIO.
5242          *
5243          */
5244
5245         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5246             int d_sts;
5247             d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5248             if (d_sts != 0)
5249                 return d_sts;
5250
5251             /* We killed the destination, so only errno now is EIO */
5252             pre_delete = 1;
5253         }
5254     }
5255
5256     /* Originally the idea was to call the CRTL rename() and only
5257      * try the lib$rename_file if it failed.
5258      * It turns out that there are too many variants in what the
5259      * the CRTL rename might do, so only use lib$rename_file
5260      */
5261     retval = -1;
5262
5263     {
5264         /* Is the source and dest both in VMS format */
5265         /* if the source is a directory, then need to fileify */
5266         /*  and dest must be a directory or non-existant. */
5267
5268         char * vms_src;
5269         char * vms_dst;
5270         int sts;
5271         char * ret_str;
5272         unsigned long flags;
5273         struct dsc$descriptor_s old_file_dsc;
5274         struct dsc$descriptor_s new_file_dsc;
5275
5276         /* We need to modify the src and dst depending
5277          * on if one or more of them are directories.
5278          */
5279
5280         vms_src = PerlMem_malloc(VMS_MAXRSS);
5281         if (vms_src == NULL)
5282             _ckvmssts_noperl(SS$_INSFMEM);
5283
5284         /* Source is always a VMS format file */
5285         ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5286         if (ret_str == NULL) {
5287             PerlMem_free(vms_src);
5288             errno = EIO;
5289             return -1;
5290         }
5291
5292         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5293         if (vms_dst == NULL)
5294             _ckvmssts_noperl(SS$_INSFMEM);
5295
5296         if (S_ISDIR(src_st.st_mode)) {
5297         char * ret_str;
5298         char * vms_dir_file;
5299
5300             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5301             if (vms_dir_file == NULL)
5302                 _ckvmssts_noperl(SS$_INSFMEM);
5303
5304             /* The source must be a file specification */
5305             ret_str = int_fileify_dirspec(vms_src, vms_dir_file, NULL);
5306             if (ret_str == NULL) {
5307                 PerlMem_free(vms_src);
5308                 PerlMem_free(vms_dst);
5309                 PerlMem_free(vms_dir_file);
5310                 errno = EIO;
5311                 return -1;
5312             }
5313             PerlMem_free(vms_src);
5314             vms_src = vms_dir_file;
5315
5316             /* If the dest is a directory, we must remove it
5317             if (dst_sts == 0) {
5318                 int d_sts;
5319                 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5320                 if (d_sts != 0) {
5321                     PerlMem_free(vms_src);
5322                     PerlMem_free(vms_dst);
5323                     errno = EIO;
5324                     return sts;
5325                 }
5326
5327                 pre_delete = 1;
5328             }
5329
5330            /* The dest must be a VMS file specification */
5331            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5332            if (ret_str == NULL) {
5333                 PerlMem_free(vms_src);
5334                 PerlMem_free(vms_dst);
5335                 errno = EIO;
5336                 return -1;
5337            }
5338
5339             /* The source must be a file specification */
5340             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5341             if (vms_dir_file == NULL)
5342                 _ckvmssts_noperl(SS$_INSFMEM);
5343
5344             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5345             if (ret_str == NULL) {
5346                 PerlMem_free(vms_src);
5347                 PerlMem_free(vms_dst);
5348                 PerlMem_free(vms_dir_file);
5349                 errno = EIO;
5350                 return -1;
5351             }
5352             PerlMem_free(vms_dst);
5353             vms_dst = vms_dir_file;
5354
5355         } else {
5356             /* File to file or file to new dir */
5357
5358             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5359                 /* VMS pathify a dir target */
5360                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5361                 if (ret_str == NULL) {
5362                     PerlMem_free(vms_src);
5363                     PerlMem_free(vms_dst);
5364                     errno = EIO;
5365                     return -1;
5366                 }
5367             } else {
5368
5369                 /* fileify a target VMS file specification */
5370                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5371                 if (ret_str == NULL) {
5372                     PerlMem_free(vms_src);
5373                     PerlMem_free(vms_dst);
5374                     errno = EIO;
5375                     return -1;
5376                 }
5377             }
5378         }
5379
5380         old_file_dsc.dsc$a_pointer = vms_src;
5381         old_file_dsc.dsc$w_length = strlen(vms_src);
5382         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5383         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5384
5385         new_file_dsc.dsc$a_pointer = vms_dst;
5386         new_file_dsc.dsc$w_length = strlen(vms_dst);
5387         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5388         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5389
5390         flags = 0;
5391 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5392         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5393 #endif
5394
5395         sts = lib$rename_file(&old_file_dsc,
5396                               &new_file_dsc,
5397                               NULL, NULL,
5398                               &flags,
5399                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5400         if (!$VMS_STATUS_SUCCESS(sts)) {
5401
5402            /* We could have failed because VMS style permissions do not
5403             * permit renames that UNIX will allow.  Just like the hack
5404             * in for kill_file.
5405             */
5406            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5407         }
5408
5409         PerlMem_free(vms_src);
5410         PerlMem_free(vms_dst);
5411         if (!$VMS_STATUS_SUCCESS(sts)) {
5412             errno = EIO;
5413             return -1;
5414         }
5415         retval = 0;
5416     }
5417
5418     if (vms_unlink_all_versions) {
5419         /* Now get rid of any previous versions of the source file that
5420          * might still exist
5421          */
5422         int save_errno;
5423         save_errno = errno;
5424         src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5425         errno = save_errno;
5426     }
5427
5428     /* We deleted the destination, so must force the error to be EIO */
5429     if ((retval != 0) && (pre_delete != 0))
5430         errno = EIO;
5431
5432     return retval;
5433 }
5434 /*}}}*/
5435
5436
5437 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5438 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5439  * to expand file specification.  Allows for a single default file
5440  * specification and a simple mask of options.  If outbuf is non-NULL,
5441  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5442  * the resultant file specification is placed.  If outbuf is NULL, the
5443  * resultant file specification is placed into a static buffer.
5444  * The third argument, if non-NULL, is taken to be a default file
5445  * specification string.  The fourth argument is unused at present.
5446  * rmesexpand() returns the address of the resultant string if
5447  * successful, and NULL on error.
5448  *
5449  * New functionality for previously unused opts value:
5450  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5451  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5452  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5453  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5454  */
5455 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5456
5457 static char *
5458 int_rmsexpand
5459    (const char *filespec,
5460     char *outbuf,
5461     const char *defspec,
5462     unsigned opts,
5463     int * fs_utf8,
5464     int * dfs_utf8)
5465 {
5466   char * ret_spec;
5467   const char * in_spec;
5468   char * spec_buf;
5469   const char * def_spec;
5470   char * vmsfspec, *vmsdefspec;
5471   char * esa;
5472   char * esal = NULL;
5473   char * outbufl;
5474   struct FAB myfab = cc$rms_fab;
5475   rms_setup_nam(mynam);
5476   STRLEN speclen;
5477   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5478   int sts;
5479
5480   /* temp hack until UTF8 is actually implemented */
5481   if (fs_utf8 != NULL)
5482     *fs_utf8 = 0;
5483
5484   if (!filespec || !*filespec) {
5485     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5486     return NULL;
5487   }
5488
5489   vmsfspec = NULL;
5490   vmsdefspec = NULL;
5491   outbufl = NULL;
5492
5493   in_spec = filespec;
5494   isunix = 0;
5495   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5496       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5497       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5498
5499       /* If this is a UNIX file spec, convert it to VMS */
5500       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5501                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5502                            &e_len, &vs_spec, &vs_len);
5503       if (sts != 0) {
5504           isunix = 1;
5505           char * ret_spec;
5506
5507           vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5508           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5509           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5510           if (ret_spec == NULL) {
5511               PerlMem_free(vmsfspec);
5512               return NULL;
5513           }
5514           in_spec = (const char *)vmsfspec;
5515
5516           /* Unless we are forcing to VMS format, a UNIX input means
5517            * UNIX output, and that requires long names to be used
5518            */
5519           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5520 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5521               opts |= PERL_RMSEXPAND_M_LONG;
5522 #endif
5523           else
5524               isunix = 0;
5525       }
5526
5527   }
5528
5529   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5530   rms_bind_fab_nam(myfab, mynam);
5531
5532   /* Process the default file specification if present */
5533   def_spec = defspec;
5534   if (defspec && *defspec) {
5535     int t_isunix;
5536     t_isunix = is_unix_filespec(defspec);
5537     if (t_isunix) {
5538       vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
5539       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5540       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5541
5542       if (ret_spec == NULL) {
5543           /* Clean up and bail */
5544           PerlMem_free(vmsdefspec);
5545           if (vmsfspec != NULL)
5546               PerlMem_free(vmsfspec);
5547               return NULL;
5548           }
5549           def_spec = (const char *)vmsdefspec;
5550       }
5551       rms_set_dna(myfab, mynam,
5552                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5553   }
5554
5555   /* Now we need the expansion buffers */
5556   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5557   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5558 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5559   esal = PerlMem_malloc(VMS_MAXRSS);
5560   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5561 #endif
5562   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5563
5564   /* If a NAML block is used RMS always writes to the long and short
5565    * addresses unless you suppress the short name.
5566    */
5567 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5568   outbufl = PerlMem_malloc(VMS_MAXRSS);
5569   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5570 #endif
5571    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5572
5573 #ifdef NAM$M_NO_SHORT_UPCASE
5574   if (decc_efs_case_preserve)
5575     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5576 #endif
5577
5578    /* We may not want to follow symbolic links */
5579 #ifdef NAML$M_OPEN_SPECIAL
5580   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5581     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5582 #endif
5583
5584   /* First attempt to parse as an existing file */
5585   retsts = sys$parse(&myfab,0,0);
5586   if (!(retsts & STS$K_SUCCESS)) {
5587
5588     /* Could not find the file, try as syntax only if error is not fatal */
5589     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5590     if (retsts == RMS$_DNF ||
5591         retsts == RMS$_DIR ||
5592         retsts == RMS$_DEV ||
5593         retsts == RMS$_PRV) {
5594       retsts = sys$parse(&myfab,0,0);
5595       if (retsts & STS$K_SUCCESS) goto int_expanded;
5596     }
5597
5598      /* Still could not parse the file specification */
5599     /*----------------------------------------------*/
5600     sts = rms_free_search_context(&myfab); /* Free search context */
5601     if (vmsdefspec != NULL)
5602         PerlMem_free(vmsdefspec);
5603     if (vmsfspec != NULL)
5604         PerlMem_free(vmsfspec);
5605     if (outbufl != NULL)
5606         PerlMem_free(outbufl);
5607     PerlMem_free(esa);
5608     if (esal != NULL)
5609         PerlMem_free(esal);
5610     set_vaxc_errno(retsts);
5611     if      (retsts == RMS$_PRV) set_errno(EACCES);
5612     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5613     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5614     else                         set_errno(EVMSERR);
5615     return NULL;
5616   }
5617   retsts = sys$search(&myfab,0,0);
5618   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5619     sts = rms_free_search_context(&myfab); /* Free search context */
5620     if (vmsdefspec != NULL)
5621         PerlMem_free(vmsdefspec);
5622     if (vmsfspec != NULL)
5623         PerlMem_free(vmsfspec);
5624     if (outbufl != NULL)
5625         PerlMem_free(outbufl);
5626     PerlMem_free(esa);
5627     if (esal != NULL)
5628         PerlMem_free(esal);
5629     set_vaxc_errno(retsts);
5630     if      (retsts == RMS$_PRV) set_errno(EACCES);
5631     else                         set_errno(EVMSERR);
5632     return NULL;
5633   }
5634
5635   /* If the input filespec contained any lowercase characters,
5636    * downcase the result for compatibility with Unix-minded code. */
5637 int_expanded:
5638   if (!decc_efs_case_preserve) {
5639     char * tbuf;
5640     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5641       if (islower(*tbuf)) { haslower = 1; break; }
5642   }
5643
5644    /* Is a long or a short name expected */
5645   /*------------------------------------*/
5646   spec_buf = NULL;
5647   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5648     if (rms_nam_rsll(mynam)) {
5649         spec_buf = outbufl;
5650         speclen = rms_nam_rsll(mynam);
5651     }
5652     else {
5653         spec_buf = esal; /* Not esa */
5654         speclen = rms_nam_esll(mynam);
5655     }
5656   }
5657   else {
5658     if (rms_nam_rsl(mynam)) {
5659         spec_buf = outbuf;
5660         speclen = rms_nam_rsl(mynam);
5661     }
5662     else {
5663         spec_buf = esa; /* Not esal */
5664         speclen = rms_nam_esl(mynam);
5665     }
5666   }
5667   spec_buf[speclen] = '\0';
5668
5669   /* Trim off null fields added by $PARSE
5670    * If type > 1 char, must have been specified in original or default spec
5671    * (not true for version; $SEARCH may have added version of existing file).
5672    */
5673   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5674   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5675     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5676              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5677   }
5678   else {
5679     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5680              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5681   }
5682   if (trimver || trimtype) {
5683     if (defspec && *defspec) {
5684       char *defesal = NULL;
5685       char *defesa = NULL;
5686       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5687       if (defesa != NULL) {
5688         struct FAB deffab = cc$rms_fab;
5689 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5690         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5691         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5692 #endif
5693         rms_setup_nam(defnam);
5694
5695         rms_bind_fab_nam(deffab, defnam);
5696
5697         /* Cast ok */
5698         rms_set_fna
5699             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5700
5701         /* RMS needs the esa/esal as a work area if wildcards are involved */
5702         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5703
5704         rms_clear_nam_nop(defnam);
5705         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5706 #ifdef NAM$M_NO_SHORT_UPCASE
5707         if (decc_efs_case_preserve)
5708           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5709 #endif
5710 #ifdef NAML$M_OPEN_SPECIAL
5711         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5712           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5713 #endif
5714         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5715           if (trimver) {
5716              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5717           }
5718           if (trimtype) {
5719             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5720           }
5721         }
5722         if (defesal != NULL)
5723             PerlMem_free(defesal);
5724         PerlMem_free(defesa);
5725       } else {
5726           _ckvmssts_noperl(SS$_INSFMEM);
5727       }
5728     }
5729     if (trimver) {
5730       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5731         if (*(rms_nam_verl(mynam)) != '\"')
5732           speclen = rms_nam_verl(mynam) - spec_buf;
5733       }
5734       else {
5735         if (*(rms_nam_ver(mynam)) != '\"')
5736           speclen = rms_nam_ver(mynam) - spec_buf;
5737       }
5738     }
5739     if (trimtype) {
5740       /* If we didn't already trim version, copy down */
5741       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5742         if (speclen > rms_nam_verl(mynam) - spec_buf)
5743           memmove
5744            (rms_nam_typel(mynam),
5745             rms_nam_verl(mynam),
5746             speclen - (rms_nam_verl(mynam) - spec_buf));
5747           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5748       }
5749       else {
5750         if (speclen > rms_nam_ver(mynam) - spec_buf)
5751           memmove
5752            (rms_nam_type(mynam),
5753             rms_nam_ver(mynam),
5754             speclen - (rms_nam_ver(mynam) - spec_buf));
5755           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5756       }
5757     }
5758   }
5759
5760    /* Done with these copies of the input files */
5761   /*-------------------------------------------*/
5762   if (vmsfspec != NULL)
5763         PerlMem_free(vmsfspec);
5764   if (vmsdefspec != NULL)
5765         PerlMem_free(vmsdefspec);
5766
5767   /* If we just had a directory spec on input, $PARSE "helpfully"
5768    * adds an empty name and type for us */
5769 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5770   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5771     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5772         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5773         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5774       speclen = rms_nam_namel(mynam) - spec_buf;
5775   }
5776   else
5777 #endif
5778   {
5779     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5780         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5781         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5782       speclen = rms_nam_name(mynam) - spec_buf;
5783   }
5784
5785   /* Posix format specifications must have matching quotes */
5786   if (speclen < (VMS_MAXRSS - 1)) {
5787     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5788       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5789         spec_buf[speclen] = '\"';
5790         speclen++;
5791       }
5792     }
5793   }
5794   spec_buf[speclen] = '\0';
5795   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5796
5797   /* Have we been working with an expanded, but not resultant, spec? */
5798   /* Also, convert back to Unix syntax if necessary. */
5799   {
5800   int rsl;
5801
5802 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5803     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5804       rsl = rms_nam_rsll(mynam);
5805     } else
5806 #endif
5807     {
5808       rsl = rms_nam_rsl(mynam);
5809     }
5810     if (!rsl) {
5811       /* rsl is not present, it means that spec_buf is either */
5812       /* esa or esal, and needs to be copied to outbuf */
5813       /* convert to Unix if desired */
5814       if (isunix) {
5815         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5816       } else {
5817         /* VMS file specs are not in UTF-8 */
5818         if (fs_utf8 != NULL)
5819             *fs_utf8 = 0;
5820         strcpy(outbuf, spec_buf);
5821         ret_spec = outbuf;
5822       }
5823     }
5824     else {
5825       /* Now spec_buf is either outbuf or outbufl */
5826       /* We need the result into outbuf */
5827       if (isunix) {
5828            /* If we need this in UNIX, then we need another buffer */
5829            /* to keep things in order */
5830            char * src;
5831            char * new_src = NULL;
5832            if (spec_buf == outbuf) {
5833                new_src = PerlMem_malloc(VMS_MAXRSS);
5834                strcpy(new_src, spec_buf);
5835            } else {
5836                src = spec_buf;
5837            }
5838            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5839            if (new_src) {
5840                PerlMem_free(new_src);
5841            }
5842       } else {
5843            /* VMS file specs are not in UTF-8 */
5844            if (fs_utf8 != NULL)
5845                *fs_utf8 = 0;
5846
5847            /* Copy the buffer if needed */
5848            if (outbuf != spec_buf)
5849                strcpy(outbuf, spec_buf);
5850            ret_spec = outbuf;
5851       }
5852     }
5853   }
5854
5855   /* Need to clean up the search context */
5856   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5857   sts = rms_free_search_context(&myfab); /* Free search context */
5858
5859   /* Clean up the extra buffers */
5860   if (esal != NULL)
5861       PerlMem_free(esal);
5862   PerlMem_free(esa);
5863   if (outbufl != NULL)
5864      PerlMem_free(outbufl);
5865
5866   /* Return the result */
5867   return ret_spec;
5868 }
5869
5870 /* Common simple case - Expand an already VMS spec */
5871 static char *
5872 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5873     opts |= PERL_RMSEXPAND_M_VMS_IN;
5874     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5875 }
5876
5877 /* Common simple case - Expand to a VMS spec */
5878 static char *
5879 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5880     opts |= PERL_RMSEXPAND_M_VMS;
5881     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5882 }
5883
5884
5885 /* Entry point used by perl routines */
5886 static char *
5887 mp_do_rmsexpand
5888    (pTHX_ const char *filespec,
5889     char *outbuf,
5890     int ts,
5891     const char *defspec,
5892     unsigned opts,
5893     int * fs_utf8,
5894     int * dfs_utf8)
5895 {
5896     static char __rmsexpand_retbuf[VMS_MAXRSS];
5897     char * expanded, *ret_spec, *ret_buf;
5898
5899     expanded = NULL;
5900     ret_buf = outbuf;
5901     if (ret_buf == NULL) {
5902         if (ts) {
5903             Newx(expanded, VMS_MAXRSS, char);
5904             if (expanded == NULL)
5905                 _ckvmssts(SS$_INSFMEM);
5906             ret_buf = expanded;
5907         } else {
5908             ret_buf = __rmsexpand_retbuf;
5909         }
5910     }
5911
5912
5913     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5914                              opts, fs_utf8,  dfs_utf8);
5915
5916     if (ret_spec == NULL) {
5917        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5918        if (expanded)
5919            Safefree(expanded);
5920     }
5921
5922     return ret_spec;
5923 }
5924 /*}}}*/
5925 /* External entry points */
5926 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5927 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5928 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5929 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5930 char *Perl_rmsexpand_utf8
5931   (pTHX_ const char *spec, char *buf, const char *def,
5932    unsigned opt, int * fs_utf8, int * dfs_utf8)
5933 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5934 char *Perl_rmsexpand_utf8_ts
5935   (pTHX_ const char *spec, char *buf, const char *def,
5936    unsigned opt, int * fs_utf8, int * dfs_utf8)
5937 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5938
5939
5940 /*
5941 ** The following routines are provided to make life easier when
5942 ** converting among VMS-style and Unix-style directory specifications.
5943 ** All will take input specifications in either VMS or Unix syntax. On
5944 ** failure, all return NULL.  If successful, the routines listed below
5945 ** return a pointer to a buffer containing the appropriately
5946 ** reformatted spec (and, therefore, subsequent calls to that routine
5947 ** will clobber the result), while the routines of the same names with
5948 ** a _ts suffix appended will return a pointer to a mallocd string
5949 ** containing the appropriately reformatted spec.
5950 ** In all cases, only explicit syntax is altered; no check is made that
5951 ** the resulting string is valid or that the directory in question
5952 ** actually exists.
5953 **
5954 **   fileify_dirspec() - convert a directory spec into the name of the
5955 **     directory file (i.e. what you can stat() to see if it's a dir).
5956 **     The style (VMS or Unix) of the result is the same as the style
5957 **     of the parameter passed in.
5958 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5959 **     what you prepend to a filename to indicate what directory it's in).
5960 **     The style (VMS or Unix) of the result is the same as the style
5961 **     of the parameter passed in.
5962 **   tounixpath() - convert a directory spec into a Unix-style path.
5963 **   tovmspath() - convert a directory spec into a VMS-style path.
5964 **   tounixspec() - convert any file spec into a Unix-style file spec.
5965 **   tovmsspec() - convert any file spec into a VMS-style spec.
5966 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5967 **
5968 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5969 ** Permission is given to distribute this code as part of the Perl
5970 ** standard distribution under the terms of the GNU General Public
5971 ** License or the Perl Artistic License.  Copies of each may be
5972 ** found in the Perl standard distribution.
5973  */
5974
5975 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5976 static char *
5977 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
5978 {
5979     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5980     char *cp1, *cp2, *lastdir;
5981     char *trndir, *vmsdir;
5982     unsigned short int trnlnm_iter_count;
5983     int is_vms = 0;
5984     int is_unix = 0;
5985     int sts;
5986     if (utf8_fl != NULL)
5987         *utf8_fl = 0;
5988
5989     if (!dir || !*dir) {
5990       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5991     }
5992     dirlen = strlen(dir);
5993     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5994     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5995       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5996         dir = "/sys$disk";
5997         dirlen = 9;
5998       }
5999       else
6000         dirlen = 1;
6001     }
6002     if (dirlen > (VMS_MAXRSS - 1)) {
6003       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6004       return NULL;
6005     }
6006     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
6007     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6008     if (!strpbrk(dir+1,"/]>:")  &&
6009         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
6010       strcpy(trndir,*dir == '/' ? dir + 1: dir);
6011       trnlnm_iter_count = 0;
6012       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6013         trnlnm_iter_count++;
6014         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6015       }
6016       dirlen = strlen(trndir);
6017     }
6018     else {
6019       strncpy(trndir,dir,dirlen);
6020       trndir[dirlen] = '\0';
6021     }
6022
6023     /* At this point we are done with *dir and use *trndir which is a
6024      * copy that can be modified.  *dir must not be modified.
6025      */
6026
6027     /* If we were handed a rooted logical name or spec, treat it like a
6028      * simple directory, so that
6029      *    $ Define myroot dev:[dir.]
6030      *    ... do_fileify_dirspec("myroot",buf,1) ...
6031      * does something useful.
6032      */
6033     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6034       trndir[--dirlen] = '\0';
6035       trndir[dirlen-1] = ']';
6036     }
6037     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6038       trndir[--dirlen] = '\0';
6039       trndir[dirlen-1] = '>';
6040     }
6041
6042     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6043       /* If we've got an explicit filename, we can just shuffle the string. */
6044       if (*(cp1+1)) hasfilename = 1;
6045       /* Similarly, we can just back up a level if we've got multiple levels
6046          of explicit directories in a VMS spec which ends with directories. */
6047       else {
6048         for (cp2 = cp1; cp2 > trndir; cp2--) {
6049           if (*cp2 == '.') {
6050             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6051 /* fix-me, can not scan EFS file specs backward like this */
6052               *cp2 = *cp1; *cp1 = '\0';
6053               hasfilename = 1;
6054               break;
6055             }
6056           }
6057           if (*cp2 == '[' || *cp2 == '<') break;
6058         }
6059       }
6060     }
6061
6062     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
6063     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6064     cp1 = strpbrk(trndir,"]:>");
6065     if (hasfilename || !cp1) { /* filename present or not VMS */
6066
6067       if (decc_efs_charset && !cp1) {
6068
6069           /* EFS handling for UNIX mode */
6070
6071           /* Just remove the trailing '/' and we should be done */
6072           STRLEN trndir_len;
6073           trndir_len = strlen(trndir);
6074
6075           if (trndir_len > 1) {
6076               trndir_len--;
6077               if (trndir[trndir_len] == '/') {
6078                   trndir[trndir_len] = '\0';
6079               }
6080           }
6081           strcpy(buf, trndir);
6082           PerlMem_free(trndir);
6083           PerlMem_free(vmsdir);
6084           return buf;
6085       }
6086
6087       /* For non-EFS mode, this is left for backwards compatibility */
6088       /* For EFS mode, this is only done for VMS format filespecs as */
6089       /* Perl programs generally have problems when a UNIX format spec */
6090       /* returns a VMS format spec */
6091       if (trndir[0] == '.') {
6092         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6093           PerlMem_free(trndir);
6094           PerlMem_free(vmsdir);
6095           return int_fileify_dirspec("[]", buf, NULL);
6096         }
6097         else if (trndir[1] == '.' &&
6098                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6099           PerlMem_free(trndir);
6100           PerlMem_free(vmsdir);
6101           return int_fileify_dirspec("[-]", buf, NULL);
6102         }
6103       }
6104       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6105         dirlen -= 1;                 /* to last element */
6106         lastdir = strrchr(trndir,'/');
6107       }
6108       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6109         /* If we have "/." or "/..", VMSify it and let the VMS code
6110          * below expand it, rather than repeating the code to handle
6111          * relative components of a filespec here */
6112         do {
6113           if (*(cp1+2) == '.') cp1++;
6114           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6115             char * ret_chr;
6116             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6117                 PerlMem_free(trndir);
6118                 PerlMem_free(vmsdir);
6119                 return NULL;
6120             }
6121             if (strchr(vmsdir,'/') != NULL) {
6122               /* If int_tovmsspec() returned it, it must have VMS syntax
6123                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6124                * the time to check this here only so we avoid a recursion
6125                * loop; otherwise, gigo.
6126                */
6127               PerlMem_free(trndir);
6128               PerlMem_free(vmsdir);
6129               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6130               return NULL;
6131             }
6132             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6133                 PerlMem_free(trndir);
6134                 PerlMem_free(vmsdir);
6135                 return NULL;
6136             }
6137             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6138             PerlMem_free(trndir);
6139             PerlMem_free(vmsdir);
6140             return ret_chr;
6141           }
6142           cp1++;
6143         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6144         lastdir = strrchr(trndir,'/');
6145       }
6146       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6147         char * ret_chr;
6148         /* Ditto for specs that end in an MFD -- let the VMS code
6149          * figure out whether it's a real device or a rooted logical. */
6150
6151         /* This should not happen any more.  Allowing the fake /000000
6152          * in a UNIX pathname causes all sorts of problems when trying
6153          * to run in UNIX emulation.  So the VMS to UNIX conversions
6154          * now remove the fake /000000 directories.
6155          */
6156
6157         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6158         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6159             PerlMem_free(trndir);
6160             PerlMem_free(vmsdir);
6161             return NULL;
6162         }
6163         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6164             PerlMem_free(trndir);
6165             PerlMem_free(vmsdir);
6166             return NULL;
6167         }
6168         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6169         PerlMem_free(trndir);
6170         PerlMem_free(vmsdir);
6171         return ret_chr;
6172       }
6173       else {
6174
6175         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6176              !(lastdir = cp1 = strrchr(trndir,']')) &&
6177              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6178
6179         cp2 = strrchr(cp1,'.');
6180         if (cp2) {
6181             int e_len, vs_len = 0;
6182             int is_dir = 0;
6183             char * cp3;
6184             cp3 = strchr(cp2,';');
6185             e_len = strlen(cp2);
6186             if (cp3) {
6187                 vs_len = strlen(cp3);
6188                 e_len = e_len - vs_len;
6189             }
6190             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6191             if (!is_dir) {
6192                 if (!decc_efs_charset) {
6193                     /* If this is not EFS, then not a directory */
6194                     PerlMem_free(trndir);
6195                     PerlMem_free(vmsdir);
6196                     set_errno(ENOTDIR);
6197                     set_vaxc_errno(RMS$_DIR);
6198                     return NULL;
6199                 }
6200             } else {
6201                 /* Ok, here we have an issue, technically if a .dir shows */
6202                 /* from inside a directory, then we should treat it as */
6203                 /* xxx^.dir.dir.  But we do not have that context at this */
6204                 /* point unless this is totally restructured, so we remove */
6205                 /* The .dir for now, and fix this better later */
6206                 dirlen = cp2 - trndir;
6207             }
6208         }
6209
6210       }
6211
6212       retlen = dirlen + 6;
6213       memcpy(buf, trndir, dirlen);
6214       buf[dirlen] = '\0';
6215
6216       /* We've picked up everything up to the directory file name.
6217          Now just add the type and version, and we're set. */
6218
6219       /* We should only add type for VMS syntax, but historically Perl
6220          has added it for UNIX style also */
6221
6222       /* Fix me - we should not be using the same routine for VMS and
6223          UNIX format files.  Things are too tangled so we need to lookup
6224          what syntax the output is */
6225
6226       is_unix = 0;
6227       is_vms = 0;
6228       lastdir = strrchr(trndir,'/');
6229       if (lastdir) {
6230           is_unix = 1;
6231       } else {
6232           lastdir = strpbrk(trndir,"]:>");
6233           if (lastdir) {
6234               is_vms = 1;
6235           }
6236       }
6237
6238       if ((is_vms == 0) && (is_unix == 0)) {
6239           /* We still do not  know? */
6240           is_unix = decc_filename_unix_report;
6241           if (is_unix == 0)
6242               is_vms = 1;
6243       }
6244
6245       if ((is_unix && !decc_efs_charset) || is_vms) {
6246
6247            /* It is a bug to add a .dir to a UNIX format directory spec */
6248            /* However Perl on VMS may have programs that expect this so */
6249            /* If not using EFS character specifications allow it. */
6250
6251            if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
6252                /* Traditionally Perl expects filenames in lower case */
6253                strcat(buf, ".dir");
6254            } else {
6255                /* VMS expects the .DIR to be in upper case */
6256                strcat(buf, ".DIR");
6257            }
6258
6259            /* It is also a bug to put a VMS format version on a UNIX file */
6260            /* specification.  Perl self tests are looking for this */
6261            if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
6262                strcat(buf, ";1");
6263       }
6264       PerlMem_free(trndir);
6265       PerlMem_free(vmsdir);
6266       return buf;
6267     }
6268     else {  /* VMS-style directory spec */
6269
6270       char *esa, *esal, term, *cp;
6271       char *my_esa;
6272       int my_esa_len;
6273       unsigned long int sts, cmplen, haslower = 0;
6274       unsigned int nam_fnb;
6275       char * nam_type;
6276       struct FAB dirfab = cc$rms_fab;
6277       rms_setup_nam(savnam);
6278       rms_setup_nam(dirnam);
6279
6280       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6281       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6282       esal = NULL;
6283 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6284       esal = PerlMem_malloc(VMS_MAXRSS);
6285       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6286 #endif
6287       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6288       rms_bind_fab_nam(dirfab, dirnam);
6289       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6290       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6291 #ifdef NAM$M_NO_SHORT_UPCASE
6292       if (decc_efs_case_preserve)
6293         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6294 #endif
6295
6296       for (cp = trndir; *cp; cp++)
6297         if (islower(*cp)) { haslower = 1; break; }
6298       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6299         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6300             (dirfab.fab$l_sts == RMS$_DNF) ||
6301             (dirfab.fab$l_sts == RMS$_PRV)) {
6302             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6303             sts = sys$parse(&dirfab);
6304         }
6305         if (!sts) {
6306           PerlMem_free(esa);
6307           if (esal != NULL)
6308               PerlMem_free(esal);
6309           PerlMem_free(trndir);
6310           PerlMem_free(vmsdir);
6311           set_errno(EVMSERR);
6312           set_vaxc_errno(dirfab.fab$l_sts);
6313           return NULL;
6314         }
6315       }
6316       else {
6317         savnam = dirnam;
6318         /* Does the file really exist? */
6319         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6320           /* Yes; fake the fnb bits so we'll check type below */
6321           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6322         }
6323         else { /* No; just work with potential name */
6324           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6325           else {
6326             int fab_sts;
6327             fab_sts = dirfab.fab$l_sts;
6328             sts = rms_free_search_context(&dirfab);
6329             PerlMem_free(esa);
6330             if (esal != NULL)
6331                 PerlMem_free(esal);
6332             PerlMem_free(trndir);
6333             PerlMem_free(vmsdir);
6334             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6335             return NULL;
6336           }
6337         }
6338       }
6339
6340       /* Make sure we are using the right buffer */
6341       if (esal != NULL) {
6342         my_esa = esal;
6343         my_esa_len = rms_nam_esll(dirnam);
6344       } else {
6345         my_esa = esa;
6346         my_esa_len = rms_nam_esl(dirnam);
6347       }
6348       my_esa[my_esa_len] = '\0';
6349       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6350         cp1 = strchr(my_esa,']');
6351         if (!cp1) cp1 = strchr(my_esa,'>');
6352         if (cp1) {  /* Should always be true */
6353           my_esa_len -= cp1 - my_esa - 1;
6354           memmove(my_esa, cp1 + 1, my_esa_len);
6355         }
6356       }
6357       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6358         /* Yep; check version while we're at it, if it's there. */
6359         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6360         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6361           /* Something other than .DIR[;1].  Bzzt. */
6362           sts = rms_free_search_context(&dirfab);
6363           PerlMem_free(esa);
6364           if (esal != NULL)
6365              PerlMem_free(esal);
6366           PerlMem_free(trndir);
6367           PerlMem_free(vmsdir);
6368           set_errno(ENOTDIR);
6369           set_vaxc_errno(RMS$_DIR);
6370           return NULL;
6371         }
6372       }
6373
6374       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6375         /* They provided at least the name; we added the type, if necessary, */
6376         strcpy(buf, my_esa);
6377         sts = rms_free_search_context(&dirfab);
6378         PerlMem_free(trndir);
6379         PerlMem_free(esa);
6380         if (esal != NULL)
6381             PerlMem_free(esal);
6382         PerlMem_free(vmsdir);
6383         return buf;
6384       }
6385       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6386         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6387         *cp1 = '\0';
6388         my_esa_len -= 9;
6389       }
6390       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6391       if (cp1 == NULL) { /* should never happen */
6392         sts = rms_free_search_context(&dirfab);
6393         PerlMem_free(trndir);
6394         PerlMem_free(esa);
6395         if (esal != NULL)
6396             PerlMem_free(esal);
6397         PerlMem_free(vmsdir);
6398         return NULL;
6399       }
6400       term = *cp1;
6401       *cp1 = '\0';
6402       retlen = strlen(my_esa);
6403       cp1 = strrchr(my_esa,'.');
6404       /* ODS-5 directory specifications can have extra "." in them. */
6405       /* Fix-me, can not scan EFS file specifications backwards */
6406       while (cp1 != NULL) {
6407         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6408           break;
6409         else {
6410            cp1--;
6411            while ((cp1 > my_esa) && (*cp1 != '.'))
6412              cp1--;
6413         }
6414         if (cp1 == my_esa)
6415           cp1 = NULL;
6416       }
6417
6418       if ((cp1) != NULL) {
6419         /* There's more than one directory in the path.  Just roll back. */
6420         *cp1 = term;
6421         strcpy(buf, my_esa);
6422       }
6423       else {
6424         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6425           /* Go back and expand rooted logical name */
6426           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6427 #ifdef NAM$M_NO_SHORT_UPCASE
6428           if (decc_efs_case_preserve)
6429             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6430 #endif
6431           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6432             sts = rms_free_search_context(&dirfab);
6433             PerlMem_free(esa);
6434             if (esal != NULL)
6435                 PerlMem_free(esal);
6436             PerlMem_free(trndir);
6437             PerlMem_free(vmsdir);
6438             set_errno(EVMSERR);
6439             set_vaxc_errno(dirfab.fab$l_sts);
6440             return NULL;
6441           }
6442
6443           /* This changes the length of the string of course */
6444           if (esal != NULL) {
6445               my_esa_len = rms_nam_esll(dirnam);
6446           } else {
6447               my_esa_len = rms_nam_esl(dirnam);
6448           }
6449
6450           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6451           cp1 = strstr(my_esa,"][");
6452           if (!cp1) cp1 = strstr(my_esa,"]<");
6453           dirlen = cp1 - my_esa;
6454           memcpy(buf, my_esa, dirlen);
6455           if (!strncmp(cp1+2,"000000]",7)) {
6456             buf[dirlen-1] = '\0';
6457             /* fix-me Not full ODS-5, just extra dots in directories for now */
6458             cp1 = buf + dirlen - 1;
6459             while (cp1 > buf)
6460             {
6461               if (*cp1 == '[')
6462                 break;
6463               if (*cp1 == '.') {
6464                 if (*(cp1-1) != '^')
6465                   break;
6466               }
6467               cp1--;
6468             }
6469             if (*cp1 == '.') *cp1 = ']';
6470             else {
6471               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6472               memmove(cp1+1,"000000]",7);
6473             }
6474           }
6475           else {
6476             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6477             buf[retlen] = '\0';
6478             /* Convert last '.' to ']' */
6479             cp1 = buf+retlen-1;
6480             while (*cp != '[') {
6481               cp1--;
6482               if (*cp1 == '.') {
6483                 /* Do not trip on extra dots in ODS-5 directories */
6484                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6485                 break;
6486               }
6487             }
6488             if (*cp1 == '.') *cp1 = ']';
6489             else {
6490               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6491               memmove(cp1+1,"000000]",7);
6492             }
6493           }
6494         }
6495         else {  /* This is a top-level dir.  Add the MFD to the path. */
6496           cp1 = my_esa;
6497           cp2 = buf;
6498           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6499           strcpy(cp2,":[000000]");
6500           cp1 += 2;
6501           strcpy(cp2+9,cp1);
6502         }
6503       }
6504       sts = rms_free_search_context(&dirfab);
6505       /* We've set up the string up through the filename.  Add the
6506          type and version, and we're done. */
6507       strcat(buf,".DIR;1");
6508
6509       /* $PARSE may have upcased filespec, so convert output to lower
6510        * case if input contained any lowercase characters. */
6511       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6512       PerlMem_free(trndir);
6513       PerlMem_free(esa);
6514       if (esal != NULL)
6515         PerlMem_free(esal);
6516       PerlMem_free(vmsdir);
6517       return buf;
6518     }
6519 }  /* end of int_fileify_dirspec() */
6520
6521
6522 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6523 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6524 {
6525     static char __fileify_retbuf[VMS_MAXRSS];
6526     char * fileified, *ret_spec, *ret_buf;
6527
6528     fileified = NULL;
6529     ret_buf = buf;
6530     if (ret_buf == NULL) {
6531         if (ts) {
6532             Newx(fileified, VMS_MAXRSS, char);
6533             if (fileified == NULL)
6534                 _ckvmssts(SS$_INSFMEM);
6535             ret_buf = fileified;
6536         } else {
6537             ret_buf = __fileify_retbuf;
6538         }
6539     }
6540
6541     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6542
6543     if (ret_spec == NULL) {
6544        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6545        if (fileified)
6546            Safefree(fileified);
6547     }
6548
6549     return ret_spec;
6550 }  /* end of do_fileify_dirspec() */
6551 /*}}}*/
6552
6553 /* External entry points */
6554 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6555 { return do_fileify_dirspec(dir,buf,0,NULL); }
6556 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6557 { return do_fileify_dirspec(dir,buf,1,NULL); }
6558 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6559 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6560 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6561 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6562
6563 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6564     char * v_spec, int v_len, char * r_spec, int r_len,
6565     char * d_spec, int d_len, char * n_spec, int n_len,
6566     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6567
6568     /* VMS specification - Try to do this the simple way */
6569     if ((v_len + r_len > 0) || (d_len > 0)) {
6570         int is_dir;
6571
6572         /* No name or extension component, already a directory */
6573         if ((n_len + e_len + vs_len) == 0) {
6574             strcpy(buf, dir);
6575             return buf;
6576         }
6577
6578         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6579         /* This results from catfile() being used instead of catdir() */
6580         /* So even though it should not work, we need to allow it */
6581
6582         /* If this is .DIR;1 then do a simple conversion */
6583         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6584         if (is_dir || (e_len == 0) && (d_len > 0)) {
6585              int len;
6586              len = v_len + r_len + d_len - 1;
6587              char dclose = d_spec[d_len - 1];
6588              strncpy(buf, dir, len);
6589              buf[len] = '.';
6590              len++;
6591              strncpy(&buf[len], n_spec, n_len);
6592              len += n_len;
6593              buf[len] = dclose;
6594              buf[len + 1] = '\0';
6595              return buf;
6596         }
6597
6598 #ifdef HAS_SYMLINK
6599         else if (d_len > 0) {
6600             /* In the olden days, a directory needed to have a .DIR */
6601             /* extension to be a valid directory, but now it could  */
6602             /* be a symbolic link */
6603             int len;
6604             len = v_len + r_len + d_len - 1;
6605             char dclose = d_spec[d_len - 1];
6606             strncpy(buf, dir, len);
6607             buf[len] = '.';
6608             len++;
6609             strncpy(&buf[len], n_spec, n_len);
6610             len += n_len;
6611             if (e_len > 0) {
6612                 if (decc_efs_charset) {
6613                     buf[len] = '^';
6614                     len++;
6615                     strncpy(&buf[len], e_spec, e_len);
6616                     len += e_len;
6617                 } else {
6618                     set_vaxc_errno(RMS$_DIR);
6619                     set_errno(ENOTDIR);
6620                     return NULL;
6621                 }
6622             }
6623             buf[len] = dclose;
6624             buf[len + 1] = '\0';
6625             return buf;
6626         }
6627 #else
6628         else {
6629             set_vaxc_errno(RMS$_DIR);
6630             set_errno(ENOTDIR);
6631             return NULL;
6632         }
6633 #endif
6634     }
6635     set_vaxc_errno(RMS$_DIR);
6636     set_errno(ENOTDIR);
6637     return NULL;
6638 }
6639
6640
6641 /* Internal routine to make sure or convert a directory to be in a */
6642 /* path specification.  No utf8 flag because it is not changed or used */
6643 static char *int_pathify_dirspec(const char *dir, char *buf)
6644 {
6645     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6646     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6647     char * exp_spec, *ret_spec;
6648     char * trndir;
6649     unsigned short int trnlnm_iter_count;
6650     STRLEN trnlen;
6651     int need_to_lower;
6652
6653     if (vms_debug_fileify) {
6654         if (dir == NULL)
6655             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6656         else
6657             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6658     }
6659
6660     /* We may need to lower case the result if we translated  */
6661     /* a logical name or got the current working directory */
6662     need_to_lower = 0;
6663
6664     if (!dir || !*dir) {
6665       set_errno(EINVAL);
6666       set_vaxc_errno(SS$_BADPARAM);
6667       return NULL;
6668     }
6669
6670     trndir = PerlMem_malloc(VMS_MAXRSS);
6671     if (trndir == NULL)
6672         _ckvmssts_noperl(SS$_INSFMEM);
6673
6674     /* If no directory specified use the current default */
6675     if (*dir)
6676         strcpy(trndir, dir);
6677     else {
6678         getcwd(trndir, VMS_MAXRSS - 1);
6679         need_to_lower = 1;
6680     }
6681
6682     /* now deal with bare names that could be logical names */
6683     trnlnm_iter_count = 0;
6684     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6685            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6686         trnlnm_iter_count++;
6687         need_to_lower = 1;
6688         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6689             break;
6690         trnlen = strlen(trndir);
6691
6692         /* Trap simple rooted lnms, and return lnm:[000000] */
6693         if (!strcmp(trndir+trnlen-2,".]")) {
6694             strcpy(buf, dir);
6695             strcat(buf, ":[000000]");
6696             PerlMem_free(trndir);
6697
6698             if (vms_debug_fileify) {
6699                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6700             }
6701             return buf;
6702         }
6703     }
6704
6705     /* At this point we do not work with *dir, but the copy in  *trndir */
6706
6707     if (need_to_lower && !decc_efs_case_preserve) {
6708         /* Legacy mode, lower case the returned value */
6709         __mystrtolower(trndir);
6710     }
6711
6712
6713     /* Some special cases, '..', '.' */
6714     sts = 0;
6715     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6716        /* Force UNIX filespec */
6717        sts = 1;
6718
6719     } else {
6720         /* Is this Unix or VMS format? */
6721         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6722                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6723                              &e_len, &vs_spec, &vs_len);
6724         if (sts == 0) {
6725
6726             /* Just a filename? */
6727             if ((v_len + r_len + d_len) == 0) {
6728
6729                 /* Now we have a problem, this could be Unix or VMS */
6730                 /* We have to guess.  .DIR usually means VMS */
6731
6732                 /* In UNIX report mode, the .DIR extension is removed */
6733                 /* if one shows up, it is for a non-directory or a directory */
6734                 /* in EFS charset mode */
6735
6736                 /* So if we are in Unix report mode, assume that this */
6737                 /* is a relative Unix directory specification */
6738
6739                 sts = 1;
6740                 if (!decc_filename_unix_report && decc_efs_charset) {
6741                     int is_dir;
6742                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6743
6744                     if (is_dir) {
6745                         /* Traditional mode, assume .DIR is directory */
6746                         buf[0] = '[';
6747                         buf[1] = '.';
6748                         strncpy(&buf[2], n_spec, n_len);
6749                         buf[n_len + 2] = ']';
6750                         buf[n_len + 3] = '\0';
6751                         PerlMem_free(trndir);
6752                         if (vms_debug_fileify) {
6753                             fprintf(stderr,
6754                                     "int_pathify_dirspec: buf = %s\n",
6755                                     buf);
6756                         }
6757                         return buf;
6758                     }
6759                 }
6760             }
6761         }
6762     }
6763     if (sts == 0) {
6764         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6765             v_spec, v_len, r_spec, r_len,
6766             d_spec, d_len, n_spec, n_len,
6767             e_spec, e_len, vs_spec, vs_len);
6768
6769         if (ret_spec != NULL) {
6770             PerlMem_free(trndir);
6771             if (vms_debug_fileify) {
6772                 fprintf(stderr,
6773                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6774             }
6775             return ret_spec;
6776         }
6777
6778         /* Simple way did not work, which means that a logical name */
6779         /* was present for the directory specification.             */
6780         /* Need to use an rmsexpand variant to decode it completely */
6781         exp_spec = PerlMem_malloc(VMS_MAXRSS);
6782         if (exp_spec == NULL)
6783             _ckvmssts_noperl(SS$_INSFMEM);
6784
6785         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6786         if (ret_spec != NULL) {
6787             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6788                                  &r_spec, &r_len, &d_spec, &d_len,
6789                                  &n_spec, &n_len, &e_spec,
6790                                  &e_len, &vs_spec, &vs_len);
6791             if (sts == 0) {
6792                 ret_spec = int_pathify_dirspec_simple(
6793                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6794                     d_spec, d_len, n_spec, n_len,
6795                     e_spec, e_len, vs_spec, vs_len);
6796
6797                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6798                     /* Legacy mode, lower case the returned value */
6799                     __mystrtolower(ret_spec);
6800                 }
6801             } else {
6802                 set_vaxc_errno(RMS$_DIR);
6803                 set_errno(ENOTDIR);
6804                 ret_spec = NULL;
6805             }
6806         }
6807         PerlMem_free(exp_spec);
6808         PerlMem_free(trndir);
6809         if (vms_debug_fileify) {
6810             if (ret_spec == NULL)
6811                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6812             else
6813                 fprintf(stderr,
6814                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6815         }
6816         return ret_spec;
6817
6818     } else {
6819         /* Unix specification, Could be trivial conversion */
6820         STRLEN dir_len;
6821         dir_len = strlen(trndir);
6822
6823         /* If the extended file character set is in effect */
6824         /* then pathify is simple */
6825
6826         if (!decc_efs_charset) {
6827             /* Have to deal with traiing '.dir' or extra '.' */
6828             /* that should not be there in legacy mode, but is */
6829
6830             char * lastdot;
6831             char * lastslash;
6832             int is_dir;
6833
6834             lastslash = strrchr(trndir, '/');
6835             if (lastslash == NULL)
6836                 lastslash = trndir;
6837             else
6838                 lastslash++;
6839
6840             lastdot = NULL;
6841
6842             /* '..' or '.' are valid directory components */
6843             is_dir = 0;
6844             if (lastslash[0] == '.') {
6845                 if (lastslash[1] == '\0') {
6846                    is_dir = 1;
6847                 } else if (lastslash[1] == '.') {
6848                     if (lastslash[2] == '\0') {
6849                         is_dir = 1;
6850                     } else {
6851                         /* And finally allow '...' */
6852                         if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6853                             is_dir = 1;
6854                         }
6855                     }
6856                 }
6857             }
6858
6859             if (!is_dir) {
6860                lastdot = strrchr(lastslash, '.');
6861             }
6862             if (lastdot != NULL) {
6863                 STRLEN e_len;
6864
6865                 /* '.dir' is discarded, and any other '.' is invalid */
6866                 e_len = strlen(lastdot);
6867
6868                 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6869
6870                 if (is_dir) {
6871                     dir_len = dir_len - 4;
6872
6873                 }
6874             }
6875         }
6876
6877         strcpy(buf, trndir);
6878         if (buf[dir_len - 1] != '/') {
6879             buf[dir_len] = '/';
6880             buf[dir_len + 1] = '\0';
6881         }
6882
6883         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6884         if (!decc_efs_charset) {
6885              int dir_start = 0;
6886              char * str = buf;
6887              if (str[0] == '.') {
6888                  char * dots = str;
6889                  int cnt = 1;
6890                  while ((dots[cnt] == '.') && (cnt < 3))
6891                      cnt++;
6892                  if (cnt <= 3) {
6893                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6894                          dir_start = 1;
6895                          str += cnt;
6896                      }
6897                  }
6898              }
6899              for (; *str; ++str) {
6900                  while (*str == '/') {
6901                      dir_start = 1;
6902                      *str++;
6903                  }
6904                  if (dir_start) {
6905
6906                      /* Have to skip up to three dots which could be */
6907                      /* directories, 3 dots being a VMS extension for Perl */
6908                      char * dots = str;
6909                      int cnt = 0;
6910                      while ((dots[cnt] == '.') && (cnt < 3)) {
6911                          cnt++;
6912                      }
6913                      if (dots[cnt] == '\0')
6914                          break;
6915                      if ((cnt > 1) && (dots[cnt] != '/')) {
6916                          dir_start = 0;
6917                      } else {
6918                          str += cnt;
6919                      }
6920
6921                      /* too many dots? */
6922                      if ((cnt == 0) || (cnt > 3)) {
6923                          dir_start = 0;
6924                      }
6925                  }
6926                  if (!dir_start && (*str == '.')) {
6927                      *str = '_';
6928                  }
6929              }
6930         }
6931         PerlMem_free(trndir);
6932         ret_spec = buf;
6933         if (vms_debug_fileify) {
6934             if (ret_spec == NULL)
6935                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6936             else
6937                 fprintf(stderr,
6938                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6939         }
6940         return ret_spec;
6941     }
6942 }
6943
6944 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6945 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6946 {
6947     static char __pathify_retbuf[VMS_MAXRSS];
6948     char * pathified, *ret_spec, *ret_buf;
6949
6950     pathified = NULL;
6951     ret_buf = buf;
6952     if (ret_buf == NULL) {
6953         if (ts) {
6954             Newx(pathified, VMS_MAXRSS, char);
6955             if (pathified == NULL)
6956                 _ckvmssts(SS$_INSFMEM);
6957             ret_buf = pathified;
6958         } else {
6959             ret_buf = __pathify_retbuf;
6960         }
6961     }
6962
6963     ret_spec = int_pathify_dirspec(dir, ret_buf);
6964
6965     if (ret_spec == NULL) {
6966        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6967        if (pathified)
6968            Safefree(pathified);
6969     }
6970
6971     return ret_spec;
6972
6973 }  /* end of do_pathify_dirspec() */
6974
6975
6976 /* External entry points */
6977 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6978 { return do_pathify_dirspec(dir,buf,0,NULL); }
6979 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6980 { return do_pathify_dirspec(dir,buf,1,NULL); }
6981 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6982 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6983 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6984 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6985
6986 /* Internal tounixspec routine that does not use a thread context */
6987 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6988 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
6989 {
6990   char *dirend, *cp1, *cp3, *tmp;
6991   const char *cp2;
6992   int devlen, dirlen, retlen = VMS_MAXRSS;
6993   int expand = 1; /* guarantee room for leading and trailing slashes */
6994   unsigned short int trnlnm_iter_count;
6995   int cmp_rslt;
6996   if (utf8_fl != NULL)
6997     *utf8_fl = 0;
6998
6999   if (vms_debug_fileify) {
7000       if (spec == NULL)
7001           fprintf(stderr, "int_tounixspec: spec = NULL\n");
7002       else
7003           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7004   }
7005
7006
7007   if (spec == NULL) {
7008       set_errno(EINVAL);
7009       set_vaxc_errno(SS$_BADPARAM);
7010       return NULL;
7011   }
7012   if (strlen(spec) > (VMS_MAXRSS-1)) {
7013       set_errno(E2BIG);
7014       set_vaxc_errno(SS$_BUFFEROVF);
7015       return NULL;
7016   }
7017
7018   /* New VMS specific format needs translation
7019    * glob passes filenames with trailing '\n' and expects this preserved.
7020    */
7021   if (decc_posix_compliant_pathnames) {
7022     if (strncmp(spec, "\"^UP^", 5) == 0) {
7023       char * uspec;
7024       char *tunix;
7025       int tunix_len;
7026       int nl_flag;
7027
7028       tunix = PerlMem_malloc(VMS_MAXRSS);
7029       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7030       strcpy(tunix, spec);
7031       tunix_len = strlen(tunix);
7032       nl_flag = 0;
7033       if (tunix[tunix_len - 1] == '\n') {
7034         tunix[tunix_len - 1] = '\"';
7035         tunix[tunix_len] = '\0';
7036         tunix_len--;
7037         nl_flag = 1;
7038       }
7039       uspec = decc$translate_vms(tunix);
7040       PerlMem_free(tunix);
7041       if ((int)uspec > 0) {
7042         strcpy(rslt,uspec);
7043         if (nl_flag) {
7044           strcat(rslt,"\n");
7045         }
7046         else {
7047           /* If we can not translate it, makemaker wants as-is */
7048           strcpy(rslt, spec);
7049         }
7050         return rslt;
7051       }
7052     }
7053   }
7054
7055   cmp_rslt = 0; /* Presume VMS */
7056   cp1 = strchr(spec, '/');
7057   if (cp1 == NULL)
7058     cmp_rslt = 0;
7059
7060     /* Look for EFS ^/ */
7061     if (decc_efs_charset) {
7062       while (cp1 != NULL) {
7063         cp2 = cp1 - 1;
7064         if (*cp2 != '^') {
7065           /* Found illegal VMS, assume UNIX */
7066           cmp_rslt = 1;
7067           break;
7068         }
7069       cp1++;
7070       cp1 = strchr(cp1, '/');
7071     }
7072   }
7073
7074   /* Look for "." and ".." */
7075   if (decc_filename_unix_report) {
7076     if (spec[0] == '.') {
7077       if ((spec[1] == '\0') || (spec[1] == '\n')) {
7078         cmp_rslt = 1;
7079       }
7080       else {
7081         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7082           cmp_rslt = 1;
7083         }
7084       }
7085     }
7086   }
7087   /* This is already UNIX or at least nothing VMS understands */
7088   if (cmp_rslt) {
7089     strcpy(rslt,spec);
7090     if (vms_debug_fileify) {
7091         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7092     }
7093     return rslt;
7094   }
7095
7096   cp1 = rslt;
7097   cp2 = spec;
7098   dirend = strrchr(spec,']');
7099   if (dirend == NULL) dirend = strrchr(spec,'>');
7100   if (dirend == NULL) dirend = strchr(spec,':');
7101   if (dirend == NULL) {
7102     strcpy(rslt,spec);
7103     if (vms_debug_fileify) {
7104         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7105     }
7106     return rslt;
7107   }
7108
7109   /* Special case 1 - sys$posix_root = / */
7110 #if __CRTL_VER >= 70000000
7111   if (!decc_disable_posix_root) {
7112     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7113       *cp1 = '/';
7114       cp1++;
7115       cp2 = cp2 + 15;
7116       }
7117   }
7118 #endif
7119
7120   /* Special case 2 - Convert NLA0: to /dev/null */
7121 #if __CRTL_VER < 70000000
7122   cmp_rslt = strncmp(spec,"NLA0:", 5);
7123   if (cmp_rslt != 0)
7124      cmp_rslt = strncmp(spec,"nla0:", 5);
7125 #else
7126   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7127 #endif
7128   if (cmp_rslt == 0) {
7129     strcpy(rslt, "/dev/null");
7130     cp1 = cp1 + 9;
7131     cp2 = cp2 + 5;
7132     if (spec[6] != '\0') {
7133       cp1[9] == '/';
7134       cp1++;
7135       cp2++;
7136     }
7137   }
7138
7139    /* Also handle special case "SYS$SCRATCH:" */
7140 #if __CRTL_VER < 70000000
7141   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
7142   if (cmp_rslt != 0)
7143      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
7144 #else
7145   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7146 #endif
7147   tmp = PerlMem_malloc(VMS_MAXRSS);
7148   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7149   if (cmp_rslt == 0) {
7150   int islnm;
7151
7152     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7153     if (!islnm) {
7154       strcpy(rslt, "/tmp");
7155       cp1 = cp1 + 4;
7156       cp2 = cp2 + 12;
7157       if (spec[12] != '\0') {
7158         cp1[4] == '/';
7159         cp1++;
7160         cp2++;
7161       }
7162     }
7163   }
7164
7165   if (*cp2 != '[' && *cp2 != '<') {
7166     *(cp1++) = '/';
7167   }
7168   else {  /* the VMS spec begins with directories */
7169     cp2++;
7170     if (*cp2 == ']' || *cp2 == '>') {
7171       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7172       PerlMem_free(tmp);
7173       return rslt;
7174     }
7175     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7176       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7177         PerlMem_free(tmp);
7178         if (vms_debug_fileify) {
7179             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7180         }
7181         return NULL;
7182       }
7183       trnlnm_iter_count = 0;
7184       do {
7185         cp3 = tmp;
7186         while (*cp3 != ':' && *cp3) cp3++;
7187         *(cp3++) = '\0';
7188         if (strchr(cp3,']') != NULL) break;
7189         trnlnm_iter_count++;
7190         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7191       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7192       cp1 = rslt;
7193       cp3 = tmp;
7194       *(cp1++) = '/';
7195       while (*cp3) {
7196         *(cp1++) = *(cp3++);
7197         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7198             PerlMem_free(tmp);
7199             set_errno(ENAMETOOLONG);
7200             set_vaxc_errno(SS$_BUFFEROVF);
7201             if (vms_debug_fileify) {
7202                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7203             }
7204             return NULL; /* No room */
7205         }
7206       }
7207       *(cp1++) = '/';
7208     }
7209     if ((*cp2 == '^')) {
7210         /* EFS file escape, pass the next character as is */
7211         /* Fix me: HEX encoding for Unicode not implemented */
7212         cp2++;
7213     }
7214     else if ( *cp2 == '.') {
7215       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7216         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7217         cp2 += 3;
7218       }
7219       else cp2++;
7220     }
7221   }
7222   PerlMem_free(tmp);
7223   for (; cp2 <= dirend; cp2++) {
7224     if ((*cp2 == '^')) {
7225         /* EFS file escape, pass the next character as is */
7226         /* Fix me: HEX encoding for Unicode not implemented */
7227         *(cp1++) = *(++cp2);
7228         /* An escaped dot stays as is -- don't convert to slash */
7229         if (*cp2 == '.') cp2++;
7230     }
7231     if (*cp2 == ':') {
7232       *(cp1++) = '/';
7233       if (*(cp2+1) == '[') cp2++;
7234     }
7235     else if (*cp2 == ']' || *cp2 == '>') {
7236       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7237     }
7238     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7239       *(cp1++) = '/';
7240       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7241         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7242                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7243         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7244             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7245       }
7246       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7247         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7248         cp2 += 2;
7249       }
7250     }
7251     else if (*cp2 == '-') {
7252       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7253         while (*cp2 == '-') {
7254           cp2++;
7255           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7256         }
7257         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7258                                                          /* filespecs like */
7259           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7260           if (vms_debug_fileify) {
7261               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7262           }
7263           return NULL;
7264         }
7265       }
7266       else *(cp1++) = *cp2;
7267     }
7268     else *(cp1++) = *cp2;
7269   }
7270   /* Translate the rest of the filename. */
7271   while (*cp2) {
7272       int dot_seen;
7273       dot_seen = 0;
7274       switch(*cp2) {
7275       /* Fixme - for compatibility with the CRTL we should be removing */
7276       /* spaces from the file specifications, but this may show that */
7277       /* some tests that were appearing to pass are not really passing */
7278       case '%':
7279           cp2++;
7280           *(cp1++) = '?';
7281           break;
7282       case '^':
7283           /* Fix me hex expansions not implemented */
7284           cp2++;  /* '^.' --> '.' and other. */
7285           if (*cp2) {
7286               if (*cp2 == '_') {
7287                   cp2++;
7288                   *(cp1++) = ' ';
7289               } else {
7290                   *(cp1++) = *(cp2++);
7291               }
7292           }
7293           break;
7294       case ';':
7295           if (decc_filename_unix_no_version) {
7296               /* Easy, drop the version */
7297               while (*cp2)
7298                   cp2++;
7299               break;
7300           } else {
7301               /* Punt - passing the version as a dot will probably */
7302               /* break perl in weird ways, but so did passing */
7303               /* through the ; as a version.  Follow the CRTL and */
7304               /* hope for the best. */
7305               cp2++;
7306               *(cp1++) = '.';
7307           }
7308           break;
7309       case '.':
7310           if (dot_seen) {
7311               /* We will need to fix this properly later */
7312               /* As Perl may be installed on an ODS-5 volume, but not */
7313               /* have the EFS_CHARSET enabled, it still may encounter */
7314               /* filenames with extra dots in them, and a precedent got */
7315               /* set which allowed them to work, that we will uphold here */
7316               /* If extra dots are present in a name and no ^ is on them */
7317               /* VMS assumes that the first one is the extension delimiter */
7318               /* the rest have an implied ^. */
7319
7320               /* this is also a conflict as the . is also a version */
7321               /* delimiter in VMS, */
7322
7323               *(cp1++) = *(cp2++);
7324               break;
7325           }
7326           dot_seen = 1;
7327           /* This is an extension */
7328           if (decc_readdir_dropdotnotype) {
7329               cp2++;
7330               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7331                   /* Drop the dot for the extension */
7332                   break;
7333               } else {
7334                   *(cp1++) = '.';
7335               }
7336               break;
7337           }
7338       default:
7339           *(cp1++) = *(cp2++);
7340       }
7341   }
7342   *cp1 = '\0';
7343
7344   /* This still leaves /000000/ when working with a
7345    * VMS device root or concealed root.
7346    */
7347   {
7348   int ulen;
7349   char * zeros;
7350
7351       ulen = strlen(rslt);
7352
7353       /* Get rid of "000000/ in rooted filespecs */
7354       if (ulen > 7) {
7355         zeros = strstr(rslt, "/000000/");
7356         if (zeros != NULL) {
7357           int mlen;
7358           mlen = ulen - (zeros - rslt) - 7;
7359           memmove(zeros, &zeros[7], mlen);
7360           ulen = ulen - 7;
7361           rslt[ulen] = '\0';
7362         }
7363       }
7364   }
7365
7366   if (vms_debug_fileify) {
7367       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7368   }
7369   return rslt;
7370
7371 }  /* end of int_tounixspec() */
7372
7373
7374 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7375 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7376 {
7377     static char __tounixspec_retbuf[VMS_MAXRSS];
7378     char * unixspec, *ret_spec, *ret_buf;
7379
7380     unixspec = NULL;
7381     ret_buf = buf;
7382     if (ret_buf == NULL) {
7383         if (ts) {
7384             Newx(unixspec, VMS_MAXRSS, char);
7385             if (unixspec == NULL)
7386                 _ckvmssts(SS$_INSFMEM);
7387             ret_buf = unixspec;
7388         } else {
7389             ret_buf = __tounixspec_retbuf;
7390         }
7391     }
7392
7393     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7394
7395     if (ret_spec == NULL) {
7396        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7397        if (unixspec)
7398            Safefree(unixspec);
7399     }
7400
7401     return ret_spec;
7402
7403 }  /* end of do_tounixspec() */
7404 /*}}}*/
7405 /* External entry points */
7406 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7407   { return do_tounixspec(spec,buf,0, NULL); }
7408 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7409   { return do_tounixspec(spec,buf,1, NULL); }
7410 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7411   { return do_tounixspec(spec,buf,0, utf8_fl); }
7412 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7413   { return do_tounixspec(spec,buf,1, utf8_fl); }
7414
7415 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7416
7417 /*
7418  This procedure is used to identify if a path is based in either
7419  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7420  it returns the OpenVMS format directory for it.
7421
7422  It is expecting specifications of only '/' or '/xxxx/'
7423
7424  If a posix root does not exist, or 'xxxx' is not a directory
7425  in the posix root, it returns a failure.
7426
7427  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7428
7429  It is used only internally by posix_to_vmsspec_hardway().
7430  */
7431
7432 static int posix_root_to_vms
7433   (char *vmspath, int vmspath_len,
7434    const char *unixpath,
7435    const int * utf8_fl)
7436 {
7437 int sts;
7438 struct FAB myfab = cc$rms_fab;
7439 rms_setup_nam(mynam);
7440 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7441 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7442 char * esa, * esal, * rsa, * rsal;
7443 char *vms_delim;
7444 int dir_flag;
7445 int unixlen;
7446
7447     dir_flag = 0;
7448     vmspath[0] = '\0';
7449     unixlen = strlen(unixpath);
7450     if (unixlen == 0) {
7451       return RMS$_FNF;
7452     }
7453
7454 #if __CRTL_VER >= 80200000
7455   /* If not a posix spec already, convert it */
7456   if (decc_posix_compliant_pathnames) {
7457     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7458       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7459     }
7460     else {
7461       /* This is already a VMS specification, no conversion */
7462       unixlen--;
7463       strncpy(vmspath,unixpath, vmspath_len);
7464     }
7465   }
7466   else
7467 #endif
7468   {
7469   int path_len;
7470   int i,j;
7471
7472      /* Check to see if this is under the POSIX root */
7473      if (decc_disable_posix_root) {
7474         return RMS$_FNF;
7475      }
7476
7477      /* Skip leading / */
7478      if (unixpath[0] == '/') {
7479         unixpath++;
7480         unixlen--;
7481      }
7482
7483
7484      strcpy(vmspath,"SYS$POSIX_ROOT:");
7485
7486      /* If this is only the / , or blank, then... */
7487      if (unixpath[0] == '\0') {
7488         /* by definition, this is the answer */
7489         return SS$_NORMAL;
7490      }
7491
7492      /* Need to look up a directory */
7493      vmspath[15] = '[';
7494      vmspath[16] = '\0';
7495
7496      /* Copy and add '^' escape characters as needed */
7497      j = 16;
7498      i = 0;
7499      while (unixpath[i] != 0) {
7500      int k;
7501
7502         j += copy_expand_unix_filename_escape
7503             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7504         i += k;
7505      }
7506
7507      path_len = strlen(vmspath);
7508      if (vmspath[path_len - 1] == '/')
7509         path_len--;
7510      vmspath[path_len] = ']';
7511      path_len++;
7512      vmspath[path_len] = '\0';
7513
7514   }
7515   vmspath[vmspath_len] = 0;
7516   if (unixpath[unixlen - 1] == '/')
7517   dir_flag = 1;
7518   esal = PerlMem_malloc(VMS_MAXRSS);
7519   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7520   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7521   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7522   rsal = PerlMem_malloc(VMS_MAXRSS);
7523   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7524   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7525   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7526   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7527   rms_bind_fab_nam(myfab, mynam);
7528   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7529   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7530   if (decc_efs_case_preserve)
7531     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7532 #ifdef NAML$M_OPEN_SPECIAL
7533   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7534 #endif
7535
7536   /* Set up the remaining naml fields */
7537   sts = sys$parse(&myfab);
7538
7539   /* It failed! Try again as a UNIX filespec */
7540   if (!(sts & 1)) {
7541     PerlMem_free(esal);
7542     PerlMem_free(esa);
7543     PerlMem_free(rsal);
7544     PerlMem_free(rsa);
7545     return sts;
7546   }
7547
7548    /* get the Device ID and the FID */
7549    sts = sys$search(&myfab);
7550
7551    /* These are no longer needed */
7552    PerlMem_free(esa);
7553    PerlMem_free(rsal);
7554    PerlMem_free(rsa);
7555
7556    /* on any failure, returned the POSIX ^UP^ filespec */
7557    if (!(sts & 1)) {
7558       PerlMem_free(esal);
7559       return sts;
7560    }
7561    specdsc.dsc$a_pointer = vmspath;
7562    specdsc.dsc$w_length = vmspath_len;
7563
7564    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7565    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7566    sts = lib$fid_to_name
7567       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7568
7569   /* on any failure, returned the POSIX ^UP^ filespec */
7570   if (!(sts & 1)) {
7571      /* This can happen if user does not have permission to read directories */
7572      if (strncmp(unixpath,"\"^UP^",5) != 0)
7573        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7574      else
7575        strcpy(vmspath, unixpath);
7576   }
7577   else {
7578     vmspath[specdsc.dsc$w_length] = 0;
7579
7580     /* Are we expecting a directory? */
7581     if (dir_flag != 0) {
7582     int i;
7583     char *eptr;
7584
7585       eptr = NULL;
7586
7587       i = specdsc.dsc$w_length - 1;
7588       while (i > 0) {
7589       int zercnt;
7590         zercnt = 0;
7591         /* Version must be '1' */
7592         if (vmspath[i--] != '1')
7593           break;
7594         /* Version delimiter is one of ".;" */
7595         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7596           break;
7597         i--;
7598         if (vmspath[i--] != 'R')
7599           break;
7600         if (vmspath[i--] != 'I')
7601           break;
7602         if (vmspath[i--] != 'D')
7603           break;
7604         if (vmspath[i--] != '.')
7605           break;
7606         eptr = &vmspath[i+1];
7607         while (i > 0) {
7608           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7609             if (vmspath[i-1] != '^') {
7610               if (zercnt != 6) {
7611                 *eptr = vmspath[i];
7612                 eptr[1] = '\0';
7613                 vmspath[i] = '.';
7614                 break;
7615               }
7616               else {
7617                 /* Get rid of 6 imaginary zero directory filename */
7618                 vmspath[i+1] = '\0';
7619               }
7620             }
7621           }
7622           if (vmspath[i] == '0')
7623             zercnt++;
7624           else
7625             zercnt = 10;
7626           i--;
7627         }
7628         break;
7629       }
7630     }
7631   }
7632   PerlMem_free(esal);
7633   return sts;
7634 }
7635
7636 /* /dev/mumble needs to be handled special.
7637    /dev/null becomes NLA0:, And there is the potential for other stuff
7638    like /dev/tty which may need to be mapped to something.
7639 */
7640
7641 static int
7642 slash_dev_special_to_vms
7643    (const char * unixptr,
7644     char * vmspath,
7645     int vmspath_len)
7646 {
7647 char * nextslash;
7648 int len;
7649 int cmp;
7650 int islnm;
7651
7652     unixptr += 4;
7653     nextslash = strchr(unixptr, '/');
7654     len = strlen(unixptr);
7655     if (nextslash != NULL)
7656         len = nextslash - unixptr;
7657     cmp = strncmp("null", unixptr, 5);
7658     if (cmp == 0) {
7659         if (vmspath_len >= 6) {
7660             strcpy(vmspath, "_NLA0:");
7661             return SS$_NORMAL;
7662         }
7663     }
7664 }
7665
7666
7667 /* The built in routines do not understand perl's special needs, so
7668     doing a manual conversion from UNIX to VMS
7669
7670     If the utf8_fl is not null and points to a non-zero value, then
7671     treat 8 bit characters as UTF-8.
7672
7673     The sequence starting with '$(' and ending with ')' will be passed
7674     through with out interpretation instead of being escaped.
7675
7676   */
7677 static int posix_to_vmsspec_hardway
7678   (char *vmspath, int vmspath_len,
7679    const char *unixpath,
7680    int dir_flag,
7681    int * utf8_fl) {
7682
7683 char *esa;
7684 const char *unixptr;
7685 const char *unixend;
7686 char *vmsptr;
7687 const char *lastslash;
7688 const char *lastdot;
7689 int unixlen;
7690 int vmslen;
7691 int dir_start;
7692 int dir_dot;
7693 int quoted;
7694 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7695 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7696
7697   if (utf8_fl != NULL)
7698     *utf8_fl = 0;
7699
7700   unixptr = unixpath;
7701   dir_dot = 0;
7702
7703   /* Ignore leading "/" characters */
7704   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7705     unixptr++;
7706   }
7707   unixlen = strlen(unixptr);
7708
7709   /* Do nothing with blank paths */
7710   if (unixlen == 0) {
7711     vmspath[0] = '\0';
7712     return SS$_NORMAL;
7713   }
7714
7715   quoted = 0;
7716   /* This could have a "^UP^ on the front */
7717   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7718     quoted = 1;
7719     unixptr+= 5;
7720     unixlen-= 5;
7721   }
7722
7723   lastslash = strrchr(unixptr,'/');
7724   lastdot = strrchr(unixptr,'.');
7725   unixend = strrchr(unixptr,'\"');
7726   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7727     unixend = unixptr + unixlen;
7728   }
7729
7730   /* last dot is last dot or past end of string */
7731   if (lastdot == NULL)
7732     lastdot = unixptr + unixlen;
7733
7734   /* if no directories, set last slash to beginning of string */
7735   if (lastslash == NULL) {
7736     lastslash = unixptr;
7737   }
7738   else {
7739     /* Watch out for trailing "." after last slash, still a directory */
7740     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7741       lastslash = unixptr + unixlen;
7742     }
7743
7744     /* Watch out for traiing ".." after last slash, still a directory */
7745     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7746       lastslash = unixptr + unixlen;
7747     }
7748
7749     /* dots in directories are aways escaped */
7750     if (lastdot < lastslash)
7751       lastdot = unixptr + unixlen;
7752   }
7753
7754   /* if (unixptr < lastslash) then we are in a directory */
7755
7756   dir_start = 0;
7757
7758   vmsptr = vmspath;
7759   vmslen = 0;
7760
7761   /* Start with the UNIX path */
7762   if (*unixptr != '/') {
7763     /* relative paths */
7764
7765     /* If allowing logical names on relative pathnames, then handle here */
7766     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7767         !decc_posix_compliant_pathnames) {
7768     char * nextslash;
7769     int seg_len;
7770     char * trn;
7771     int islnm;
7772
7773         /* Find the next slash */
7774         nextslash = strchr(unixptr,'/');
7775
7776         esa = PerlMem_malloc(vmspath_len);
7777         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7778
7779         trn = PerlMem_malloc(VMS_MAXRSS);
7780         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7781
7782         if (nextslash != NULL) {
7783
7784             seg_len = nextslash - unixptr;
7785             strncpy(esa, unixptr, seg_len);
7786             esa[seg_len] = 0;
7787         }
7788         else {
7789             strcpy(esa, unixptr);
7790             seg_len = strlen(unixptr);
7791         }
7792         /* trnlnm(section) */
7793         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7794
7795         if (islnm) {
7796             /* Now fix up the directory */
7797
7798             /* Split up the path to find the components */
7799             sts = vms_split_path
7800                   (trn,
7801                    &v_spec,
7802                    &v_len,
7803                    &r_spec,
7804                    &r_len,
7805                    &d_spec,
7806                    &d_len,
7807                    &n_spec,
7808                    &n_len,
7809                    &e_spec,
7810                    &e_len,
7811                    &vs_spec,
7812                    &vs_len);
7813
7814             while (sts == 0) {
7815             char * strt;
7816             int cmp;
7817
7818                 /* A logical name must be a directory  or the full
7819                    specification.  It is only a full specification if
7820                    it is the only component */
7821                 if ((unixptr[seg_len] == '\0') ||
7822                     (unixptr[seg_len+1] == '\0')) {
7823
7824                     /* Is a directory being required? */
7825                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7826                         /* Not a logical name */
7827                         break;
7828                     }
7829
7830
7831                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7832                         /* This must be a directory */
7833                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7834                             strcpy(vmsptr, esa);
7835                             vmslen=strlen(vmsptr);
7836                             vmsptr[vmslen] = ':';
7837                             vmslen++;
7838                             vmsptr[vmslen] = '\0';
7839                             return SS$_NORMAL;
7840                         }
7841                     }
7842
7843                 }
7844
7845
7846                 /* must be dev/directory - ignore version */
7847                 if ((n_len + e_len) != 0)
7848                     break;
7849
7850                 /* transfer the volume */
7851                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7852                     strncpy(vmsptr, v_spec, v_len);
7853                     vmsptr += v_len;
7854                     vmsptr[0] = '\0';
7855                     vmslen += v_len;
7856                 }
7857
7858                 /* unroot the rooted directory */
7859                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7860                     r_spec[0] = '[';
7861                     r_spec[r_len - 1] = ']';
7862
7863                     /* This should not be there, but nothing is perfect */
7864                     if (r_len > 9) {
7865                         cmp = strcmp(&r_spec[1], "000000.");
7866                         if (cmp == 0) {
7867                             r_spec += 7;
7868                             r_spec[7] = '[';
7869                             r_len -= 7;
7870                             if (r_len == 2)
7871                                 r_len = 0;
7872                         }
7873                     }
7874                     if (r_len > 0) {
7875                         strncpy(vmsptr, r_spec, r_len);
7876                         vmsptr += r_len;
7877                         vmslen += r_len;
7878                         vmsptr[0] = '\0';
7879                     }
7880                 }
7881                 /* Bring over the directory. */
7882                 if ((d_len > 0) &&
7883                     ((d_len + vmslen) < vmspath_len)) {
7884                     d_spec[0] = '[';
7885                     d_spec[d_len - 1] = ']';
7886                     if (d_len > 9) {
7887                         cmp = strcmp(&d_spec[1], "000000.");
7888                         if (cmp == 0) {
7889                             d_spec += 7;
7890                             d_spec[7] = '[';
7891                             d_len -= 7;
7892                             if (d_len == 2)
7893                                 d_len = 0;
7894                         }
7895                     }
7896
7897                     if (r_len > 0) {
7898                         /* Remove the redundant root */
7899                         if (r_len > 0) {
7900                             /* remove the ][ */
7901                             vmsptr--;
7902                             vmslen--;
7903                             d_spec++;
7904                             d_len--;
7905                         }
7906                         strncpy(vmsptr, d_spec, d_len);
7907                             vmsptr += d_len;
7908                             vmslen += d_len;
7909                             vmsptr[0] = '\0';
7910                     }
7911                 }
7912                 break;
7913             }
7914         }
7915
7916         PerlMem_free(esa);
7917         PerlMem_free(trn);
7918     }
7919
7920     if (lastslash > unixptr) {
7921     int dotdir_seen;
7922
7923       /* skip leading ./ */
7924       dotdir_seen = 0;
7925       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7926         dotdir_seen = 1;
7927         unixptr++;
7928         unixptr++;
7929       }
7930
7931       /* Are we still in a directory? */
7932       if (unixptr <= lastslash) {
7933         *vmsptr++ = '[';
7934         vmslen = 1;
7935         dir_start = 1;
7936
7937         /* if not backing up, then it is relative forward. */
7938         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7939               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7940           *vmsptr++ = '.';
7941           vmslen++;
7942           dir_dot = 1;
7943           }
7944        }
7945        else {
7946          if (dotdir_seen) {
7947            /* Perl wants an empty directory here to tell the difference
7948             * between a DCL commmand and a filename
7949             */
7950           *vmsptr++ = '[';
7951           *vmsptr++ = ']';
7952           vmslen = 2;
7953         }
7954       }
7955     }
7956     else {
7957       /* Handle two special files . and .. */
7958       if (unixptr[0] == '.') {
7959         if (&unixptr[1] == unixend) {
7960           *vmsptr++ = '[';
7961           *vmsptr++ = ']';
7962           vmslen += 2;
7963           *vmsptr++ = '\0';
7964           return SS$_NORMAL;
7965         }
7966         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7967           *vmsptr++ = '[';
7968           *vmsptr++ = '-';
7969           *vmsptr++ = ']';
7970           vmslen += 3;
7971           *vmsptr++ = '\0';
7972           return SS$_NORMAL;
7973         }
7974       }
7975     }
7976   }
7977   else {        /* Absolute PATH handling */
7978   int sts;
7979   char * nextslash;
7980   int seg_len;
7981     /* Need to find out where root is */
7982
7983     /* In theory, this procedure should never get an absolute POSIX pathname
7984      * that can not be found on the POSIX root.
7985      * In practice, that can not be relied on, and things will show up
7986      * here that are a VMS device name or concealed logical name instead.
7987      * So to make things work, this procedure must be tolerant.
7988      */
7989     esa = PerlMem_malloc(vmspath_len);
7990     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7991
7992     sts = SS$_NORMAL;
7993     nextslash = strchr(&unixptr[1],'/');
7994     seg_len = 0;
7995     if (nextslash != NULL) {
7996     int cmp;
7997       seg_len = nextslash - &unixptr[1];
7998       strncpy(vmspath, unixptr, seg_len + 1);
7999       vmspath[seg_len+1] = 0;
8000       cmp = 1;
8001       if (seg_len == 3) {
8002         cmp = strncmp(vmspath, "dev", 4);
8003         if (cmp == 0) {
8004             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
8005             if (sts = SS$_NORMAL)
8006                 return SS$_NORMAL;
8007         }
8008       }
8009       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
8010     }
8011
8012     if ($VMS_STATUS_SUCCESS(sts)) {
8013       /* This is verified to be a real path */
8014
8015       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8016       if ($VMS_STATUS_SUCCESS(sts)) {
8017         strcpy(vmspath, esa);
8018         vmslen = strlen(vmspath);
8019         vmsptr = vmspath + vmslen;
8020         unixptr++;
8021         if (unixptr < lastslash) {
8022         char * rptr;
8023           vmsptr--;
8024           *vmsptr++ = '.';
8025           dir_start = 1;
8026           dir_dot = 1;
8027           if (vmslen > 7) {
8028           int cmp;
8029             rptr = vmsptr - 7;
8030             cmp = strcmp(rptr,"000000.");
8031             if (cmp == 0) {
8032               vmslen -= 7;
8033               vmsptr -= 7;
8034               vmsptr[1] = '\0';
8035             } /* removing 6 zeros */
8036           } /* vmslen < 7, no 6 zeros possible */
8037         } /* Not in a directory */
8038       } /* Posix root found */
8039       else {
8040         /* No posix root, fall back to default directory */
8041         strcpy(vmspath, "SYS$DISK:[");
8042         vmsptr = &vmspath[10];
8043         vmslen = 10;
8044         if (unixptr > lastslash) {
8045            *vmsptr = ']';
8046            vmsptr++;
8047            vmslen++;
8048         }
8049         else {
8050            dir_start = 1;
8051         }
8052       }
8053     } /* end of verified real path handling */
8054     else {
8055     int add_6zero;
8056     int islnm;
8057
8058       /* Ok, we have a device or a concealed root that is not in POSIX
8059        * or we have garbage.  Make the best of it.
8060        */
8061
8062       /* Posix to VMS destroyed this, so copy it again */
8063       strncpy(vmspath, &unixptr[1], seg_len);
8064       vmspath[seg_len] = 0;
8065       vmslen = seg_len;
8066       vmsptr = &vmsptr[vmslen];
8067       islnm = 0;
8068
8069       /* Now do we need to add the fake 6 zero directory to it? */
8070       add_6zero = 1;
8071       if ((*lastslash == '/') && (nextslash < lastslash)) {
8072         /* No there is another directory */
8073         add_6zero = 0;
8074       }
8075       else {
8076       int trnend;
8077       int cmp;
8078
8079         /* now we have foo:bar or foo:[000000]bar to decide from */
8080         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8081
8082         if (!islnm && !decc_posix_compliant_pathnames) {
8083
8084             cmp = strncmp("bin", vmspath, 4);
8085             if (cmp == 0) {
8086                 /* bin => SYS$SYSTEM: */
8087                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8088             }
8089             else {
8090                 /* tmp => SYS$SCRATCH: */
8091                 cmp = strncmp("tmp", vmspath, 4);
8092                 if (cmp == 0) {
8093                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8094                 }
8095             }
8096         }
8097
8098         trnend = islnm ? islnm - 1 : 0;
8099
8100         /* if this was a logical name, ']' or '>' must be present */
8101         /* if not a logical name, then assume a device and hope. */
8102         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8103
8104         /* if log name and trailing '.' then rooted - treat as device */
8105         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8106
8107         /* Fix me, if not a logical name, a device lookup should be
8108          * done to see if the device is file structured.  If the device
8109          * is not file structured, the 6 zeros should not be put on.
8110          *
8111          * As it is, perl is occasionally looking for dev:[000000]tty.
8112          * which looks a little strange.
8113          *
8114          * Not that easy to detect as "/dev" may be file structured with
8115          * special device files.
8116          */
8117
8118         if ((add_6zero == 0) && (*nextslash == '/') &&
8119             (&nextslash[1] == unixend)) {
8120           /* No real directory present */
8121           add_6zero = 1;
8122         }
8123       }
8124
8125       /* Put the device delimiter on */
8126       *vmsptr++ = ':';
8127       vmslen++;
8128       unixptr = nextslash;
8129       unixptr++;
8130
8131       /* Start directory if needed */
8132       if (!islnm || add_6zero) {
8133         *vmsptr++ = '[';
8134         vmslen++;
8135         dir_start = 1;
8136       }
8137
8138       /* add fake 000000] if needed */
8139       if (add_6zero) {
8140         *vmsptr++ = '0';
8141         *vmsptr++ = '0';
8142         *vmsptr++ = '0';
8143         *vmsptr++ = '0';
8144         *vmsptr++ = '0';
8145         *vmsptr++ = '0';
8146         *vmsptr++ = ']';
8147         vmslen += 7;
8148         dir_start = 0;
8149       }
8150
8151     } /* non-POSIX translation */
8152     PerlMem_free(esa);
8153   } /* End of relative/absolute path handling */
8154
8155   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8156   int dash_flag;
8157   int in_cnt;
8158   int out_cnt;
8159
8160     dash_flag = 0;
8161
8162     if (dir_start != 0) {
8163
8164       /* First characters in a directory are handled special */
8165       while ((*unixptr == '/') ||
8166              ((*unixptr == '.') &&
8167               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8168                 (&unixptr[1]==unixend)))) {
8169       int loop_flag;
8170
8171         loop_flag = 0;
8172
8173         /* Skip redundant / in specification */
8174         while ((*unixptr == '/') && (dir_start != 0)) {
8175           loop_flag = 1;
8176           unixptr++;
8177           if (unixptr == lastslash)
8178             break;
8179         }
8180         if (unixptr == lastslash)
8181           break;
8182
8183         /* Skip redundant ./ characters */
8184         while ((*unixptr == '.') &&
8185                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8186           loop_flag = 1;
8187           unixptr++;
8188           if (unixptr == lastslash)
8189             break;
8190           if (*unixptr == '/')
8191             unixptr++;
8192         }
8193         if (unixptr == lastslash)
8194           break;
8195
8196         /* Skip redundant ../ characters */
8197         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8198              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8199           /* Set the backing up flag */
8200           loop_flag = 1;
8201           dir_dot = 0;
8202           dash_flag = 1;
8203           *vmsptr++ = '-';
8204           vmslen++;
8205           unixptr++; /* first . */
8206           unixptr++; /* second . */
8207           if (unixptr == lastslash)
8208             break;
8209           if (*unixptr == '/') /* The slash */
8210             unixptr++;
8211         }
8212         if (unixptr == lastslash)
8213           break;
8214
8215         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8216         /* Not needed when VMS is pretending to be UNIX. */
8217
8218         /* Is this loop stuck because of too many dots? */
8219         if (loop_flag == 0) {
8220           /* Exit the loop and pass the rest through */
8221           break;
8222         }
8223       }
8224
8225       /* Are we done with directories yet? */
8226       if (unixptr >= lastslash) {
8227
8228         /* Watch out for trailing dots */
8229         if (dir_dot != 0) {
8230             vmslen --;
8231             vmsptr--;
8232         }
8233         *vmsptr++ = ']';
8234         vmslen++;
8235         dash_flag = 0;
8236         dir_start = 0;
8237         if (*unixptr == '/')
8238           unixptr++;
8239       }
8240       else {
8241         /* Have we stopped backing up? */
8242         if (dash_flag) {
8243           *vmsptr++ = '.';
8244           vmslen++;
8245           dash_flag = 0;
8246           /* dir_start continues to be = 1 */
8247         }
8248         if (*unixptr == '-') {
8249           *vmsptr++ = '^';
8250           *vmsptr++ = *unixptr++;
8251           vmslen += 2;
8252           dir_start = 0;
8253
8254           /* Now are we done with directories yet? */
8255           if (unixptr >= lastslash) {
8256
8257             /* Watch out for trailing dots */
8258             if (dir_dot != 0) {
8259               vmslen --;
8260               vmsptr--;
8261             }
8262
8263             *vmsptr++ = ']';
8264             vmslen++;
8265             dash_flag = 0;
8266             dir_start = 0;
8267           }
8268         }
8269       }
8270     }
8271
8272     /* All done? */
8273     if (unixptr >= unixend)
8274       break;
8275
8276     /* Normal characters - More EFS work probably needed */
8277     dir_start = 0;
8278     dir_dot = 0;
8279
8280     switch(*unixptr) {
8281     case '/':
8282         /* remove multiple / */
8283         while (unixptr[1] == '/') {
8284            unixptr++;
8285         }
8286         if (unixptr == lastslash) {
8287           /* Watch out for trailing dots */
8288           if (dir_dot != 0) {
8289             vmslen --;
8290             vmsptr--;
8291           }
8292           *vmsptr++ = ']';
8293         }
8294         else {
8295           dir_start = 1;
8296           *vmsptr++ = '.';
8297           dir_dot = 1;
8298
8299           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8300           /* Not needed when VMS is pretending to be UNIX. */
8301
8302         }
8303         dash_flag = 0;
8304         if (unixptr != unixend)
8305           unixptr++;
8306         vmslen++;
8307         break;
8308     case '.':
8309         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8310             (&unixptr[1] == unixend)) {
8311           *vmsptr++ = '^';
8312           *vmsptr++ = '.';
8313           vmslen += 2;
8314           unixptr++;
8315
8316           /* trailing dot ==> '^..' on VMS */
8317           if (unixptr == unixend) {
8318             *vmsptr++ = '.';
8319             vmslen++;
8320             unixptr++;
8321           }
8322           break;
8323         }
8324
8325         *vmsptr++ = *unixptr++;
8326         vmslen ++;
8327         break;
8328     case '"':
8329         if (quoted && (&unixptr[1] == unixend)) {
8330             unixptr++;
8331             break;
8332         }
8333         in_cnt = copy_expand_unix_filename_escape
8334                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8335         vmsptr += out_cnt;
8336         unixptr += in_cnt;
8337         break;
8338     case '~':
8339     case ';':
8340     case '\\':
8341     case '?':
8342     case ' ':
8343     default:
8344         in_cnt = copy_expand_unix_filename_escape
8345                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8346         vmsptr += out_cnt;
8347         unixptr += in_cnt;
8348         break;
8349     }
8350   }
8351
8352   /* Make sure directory is closed */
8353   if (unixptr == lastslash) {
8354     char *vmsptr2;
8355     vmsptr2 = vmsptr - 1;
8356
8357     if (*vmsptr2 != ']') {
8358       *vmsptr2--;
8359
8360       /* directories do not end in a dot bracket */
8361       if (*vmsptr2 == '.') {
8362         vmsptr2--;
8363
8364         /* ^. is allowed */
8365         if (*vmsptr2 != '^') {
8366           vmsptr--; /* back up over the dot */
8367         }
8368       }
8369       *vmsptr++ = ']';
8370     }
8371   }
8372   else {
8373     char *vmsptr2;
8374     /* Add a trailing dot if a file with no extension */
8375     vmsptr2 = vmsptr - 1;
8376     if ((vmslen > 1) &&
8377         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8378         (*vmsptr2 != ')') && (*lastdot != '.')) {
8379         *vmsptr++ = '.';
8380         vmslen++;
8381     }
8382   }
8383
8384   *vmsptr = '\0';
8385   return SS$_NORMAL;
8386 }
8387 #endif
8388
8389  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8390 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8391 {
8392 char * result;
8393 int utf8_flag;
8394
8395    /* If a UTF8 flag is being passed, honor it */
8396    utf8_flag = 0;
8397    if (utf8_fl != NULL) {
8398      utf8_flag = *utf8_fl;
8399     *utf8_fl = 0;
8400    }
8401
8402    if (utf8_flag) {
8403      /* If there is a possibility of UTF8, then if any UTF8 characters
8404         are present, then they must be converted to VTF-7
8405       */
8406      result = strcpy(rslt, path); /* FIX-ME */
8407    }
8408    else
8409      result = strcpy(rslt, path);
8410
8411    return result;
8412 }
8413
8414
8415
8416 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8417 static char *int_tovmsspec
8418    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8419   char *dirend;
8420   char *lastdot;
8421   char *vms_delim;
8422   register char *cp1;
8423   const char *cp2;
8424   unsigned long int infront = 0, hasdir = 1;
8425   int rslt_len;
8426   int no_type_seen;
8427   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8428   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8429
8430   if (vms_debug_fileify) {
8431       if (path == NULL)
8432           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8433       else
8434           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8435   }
8436
8437   if (path == NULL) {
8438       /* If we fail, we should be setting errno */
8439       set_errno(EINVAL);
8440       set_vaxc_errno(SS$_BADPARAM);
8441       return NULL;
8442   }
8443   rslt_len = VMS_MAXRSS-1;
8444
8445   /* '.' and '..' are "[]" and "[-]" for a quick check */
8446   if (path[0] == '.') {
8447     if (path[1] == '\0') {
8448       strcpy(rslt,"[]");
8449       if (utf8_flag != NULL)
8450         *utf8_flag = 0;
8451       return rslt;
8452     }
8453     else {
8454       if (path[1] == '.' && path[2] == '\0') {
8455         strcpy(rslt,"[-]");
8456         if (utf8_flag != NULL)
8457            *utf8_flag = 0;
8458         return rslt;
8459       }
8460     }
8461   }
8462
8463    /* Posix specifications are now a native VMS format */
8464   /*--------------------------------------------------*/
8465 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8466   if (decc_posix_compliant_pathnames) {
8467     if (strncmp(path,"\"^UP^",5) == 0) {
8468       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8469       return rslt;
8470     }
8471   }
8472 #endif
8473
8474   /* This is really the only way to see if this is already in VMS format */
8475   sts = vms_split_path
8476        (path,
8477         &v_spec,
8478         &v_len,
8479         &r_spec,
8480         &r_len,
8481         &d_spec,
8482         &d_len,
8483         &n_spec,
8484         &n_len,
8485         &e_spec,
8486         &e_len,
8487         &vs_spec,
8488         &vs_len);
8489   if (sts == 0) {
8490     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8491        replacement, because the above parse just took care of most of
8492        what is needed to do vmspath when the specification is already
8493        in VMS format.
8494
8495        And if it is not already, it is easier to do the conversion as
8496        part of this routine than to call this routine and then work on
8497        the result.
8498      */
8499
8500     /* If VMS punctuation was found, it is already VMS format */
8501     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8502       if (utf8_flag != NULL)
8503         *utf8_flag = 0;
8504       strcpy(rslt, path);
8505       if (vms_debug_fileify) {
8506           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8507       }
8508       return rslt;
8509     }
8510     /* Now, what to do with trailing "." cases where there is no
8511        extension?  If this is a UNIX specification, and EFS characters
8512        are enabled, then the trailing "." should be converted to a "^.".
8513        But if this was already a VMS specification, then it should be
8514        left alone.
8515
8516        So in the case of ambiguity, leave the specification alone.
8517      */
8518
8519
8520     /* If there is a possibility of UTF8, then if any UTF8 characters
8521         are present, then they must be converted to VTF-7
8522      */
8523     if (utf8_flag != NULL)
8524       *utf8_flag = 0;
8525     strcpy(rslt, path);
8526     if (vms_debug_fileify) {
8527         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8528     }
8529     return rslt;
8530   }
8531
8532   dirend = strrchr(path,'/');
8533
8534   if (dirend == NULL) {
8535      char *macro_start;
8536      int has_macro;
8537
8538      /* If we get here with no UNIX directory delimiters, then this is
8539         not a complete file specification, either garbage a UNIX glob
8540         specification that can not be converted to a VMS wildcard, or
8541         it a UNIX shell macro.  MakeMaker wants shell macros passed
8542         through AS-IS,
8543
8544         utf8 flag setting needs to be preserved.
8545       */
8546       hasdir = 0;
8547
8548       has_macro = 0;
8549       macro_start = strchr(path,'$');
8550       if (macro_start != NULL) {
8551           if (macro_start[1] == '(') {
8552               has_macro = 1;
8553           }
8554       }
8555       if ((decc_efs_charset == 0) || (has_macro)) {
8556           strcpy(rslt, path);
8557           if (vms_debug_fileify) {
8558               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8559           }
8560           return rslt;
8561       }
8562   }
8563
8564 /* If POSIX mode active, handle the conversion */
8565 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8566   if (decc_efs_charset) {
8567     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8568     if (vms_debug_fileify) {
8569         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8570     }
8571     return rslt;
8572   }
8573 #endif
8574
8575   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8576     if (!*(dirend+2)) dirend +=2;
8577     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8578     if (decc_efs_charset == 0) {
8579       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8580     }
8581   }
8582
8583   cp1 = rslt;
8584   cp2 = path;
8585   lastdot = strrchr(cp2,'.');
8586   if (*cp2 == '/') {
8587     char *trndev;
8588     int islnm, rooted;
8589     STRLEN trnend;
8590
8591     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8592     if (!*(cp2+1)) {
8593       if (decc_disable_posix_root) {
8594         strcpy(rslt,"sys$disk:[000000]");
8595       }
8596       else {
8597         strcpy(rslt,"sys$posix_root:[000000]");
8598       }
8599       if (utf8_flag != NULL)
8600         *utf8_flag = 0;
8601       if (vms_debug_fileify) {
8602           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8603       }
8604       return rslt;
8605     }
8606     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8607     *cp1 = '\0';
8608     trndev = PerlMem_malloc(VMS_MAXRSS);
8609     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8610     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8611
8612      /* DECC special handling */
8613     if (!islnm) {
8614       if (strcmp(rslt,"bin") == 0) {
8615         strcpy(rslt,"sys$system");
8616         cp1 = rslt + 10;
8617         *cp1 = 0;
8618         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8619       }
8620       else if (strcmp(rslt,"tmp") == 0) {
8621         strcpy(rslt,"sys$scratch");
8622         cp1 = rslt + 11;
8623         *cp1 = 0;
8624         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8625       }
8626       else if (!decc_disable_posix_root) {
8627         strcpy(rslt, "sys$posix_root");
8628         cp1 = rslt + 14;
8629         *cp1 = 0;
8630         cp2 = path;
8631         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8632         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8633       }
8634       else if (strcmp(rslt,"dev") == 0) {
8635         if (strncmp(cp2,"/null", 5) == 0) {
8636           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8637             strcpy(rslt,"NLA0");
8638             cp1 = rslt + 4;
8639             *cp1 = 0;
8640             cp2 = cp2 + 5;
8641             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8642           }
8643         }
8644       }
8645     }
8646
8647     trnend = islnm ? strlen(trndev) - 1 : 0;
8648     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8649     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8650     /* If the first element of the path is a logical name, determine
8651      * whether it has to be translated so we can add more directories. */
8652     if (!islnm || rooted) {
8653       *(cp1++) = ':';
8654       *(cp1++) = '[';
8655       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8656       else cp2++;
8657     }
8658     else {
8659       if (cp2 != dirend) {
8660         strcpy(rslt,trndev);
8661         cp1 = rslt + trnend;
8662         if (*cp2 != 0) {
8663           *(cp1++) = '.';
8664           cp2++;
8665         }
8666       }
8667       else {
8668         if (decc_disable_posix_root) {
8669           *(cp1++) = ':';
8670           hasdir = 0;
8671         }
8672       }
8673     }
8674     PerlMem_free(trndev);
8675   }
8676   else {
8677     *(cp1++) = '[';
8678     if (*cp2 == '.') {
8679       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8680         cp2 += 2;         /* skip over "./" - it's redundant */
8681         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8682       }
8683       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8684         *(cp1++) = '-';                                 /* "../" --> "-" */
8685         cp2 += 3;
8686       }
8687       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8688                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8689         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8690         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8691         cp2 += 4;
8692       }
8693       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8694         /* Escape the extra dots in EFS file specifications */
8695         *(cp1++) = '^';
8696       }
8697       if (cp2 > dirend) cp2 = dirend;
8698     }
8699     else *(cp1++) = '.';
8700   }
8701   for (; cp2 < dirend; cp2++) {
8702     if (*cp2 == '/') {
8703       if (*(cp2-1) == '/') continue;
8704       if (*(cp1-1) != '.') *(cp1++) = '.';
8705       infront = 0;
8706     }
8707     else if (!infront && *cp2 == '.') {
8708       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8709       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8710       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8711         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8712         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8713         else {  /* back up over previous directory name */
8714           cp1--;
8715           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8716           if (*(cp1-1) == '[') {
8717             memcpy(cp1,"000000.",7);
8718             cp1 += 7;
8719           }
8720         }
8721         cp2 += 2;
8722         if (cp2 == dirend) break;
8723       }
8724       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8725                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8726         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8727         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8728         if (!*(cp2+3)) {
8729           *(cp1++) = '.';  /* Simulate trailing '/' */
8730           cp2 += 2;  /* for loop will incr this to == dirend */
8731         }
8732         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8733       }
8734       else {
8735         if (decc_efs_charset == 0)
8736           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8737         else {
8738           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8739           *(cp1++) = '.';
8740         }
8741       }
8742     }
8743     else {
8744       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8745       if (*cp2 == '.') {
8746         if (decc_efs_charset == 0)
8747           *(cp1++) = '_';
8748         else {
8749           *(cp1++) = '^';
8750           *(cp1++) = '.';
8751         }
8752       }
8753       else                  *(cp1++) =  *cp2;
8754       infront = 1;
8755     }
8756   }
8757   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8758   if (hasdir) *(cp1++) = ']';
8759   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8760   /* fixme for ODS5 */
8761   no_type_seen = 0;
8762   if (cp2 > lastdot)
8763     no_type_seen = 1;
8764   while (*cp2) {
8765     switch(*cp2) {
8766     case '?':
8767         if (decc_efs_charset == 0)
8768           *(cp1++) = '%';
8769         else
8770           *(cp1++) = '?';
8771         cp2++;
8772     case ' ':
8773         *(cp1)++ = '^';
8774         *(cp1)++ = '_';
8775         cp2++;
8776         break;
8777     case '.':
8778         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8779             decc_readdir_dropdotnotype) {
8780           *(cp1)++ = '^';
8781           *(cp1)++ = '.';
8782           cp2++;
8783
8784           /* trailing dot ==> '^..' on VMS */
8785           if (*cp2 == '\0') {
8786             *(cp1++) = '.';
8787             no_type_seen = 0;
8788           }
8789         }
8790         else {
8791           *(cp1++) = *(cp2++);
8792           no_type_seen = 0;
8793         }
8794         break;
8795     case '$':
8796          /* This could be a macro to be passed through */
8797         *(cp1++) = *(cp2++);
8798         if (*cp2 == '(') {
8799         const char * save_cp2;
8800         char * save_cp1;
8801         int is_macro;
8802
8803             /* paranoid check */
8804             save_cp2 = cp2;
8805             save_cp1 = cp1;
8806             is_macro = 0;
8807
8808             /* Test through */
8809             *(cp1++) = *(cp2++);
8810             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8811                 *(cp1++) = *(cp2++);
8812                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8813                     *(cp1++) = *(cp2++);
8814                 }
8815                 if (*cp2 == ')') {
8816                     *(cp1++) = *(cp2++);
8817                     is_macro = 1;
8818                 }
8819             }
8820             if (is_macro == 0) {
8821                 /* Not really a macro - never mind */
8822                 cp2 = save_cp2;
8823                 cp1 = save_cp1;
8824             }
8825         }
8826         break;
8827     case '\"':
8828     case '~':
8829     case '`':
8830     case '!':
8831     case '#':
8832     case '%':
8833     case '^':
8834         /* Don't escape again if following character is
8835          * already something we escape.
8836          */
8837         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8838             *(cp1++) = *(cp2++);
8839             break;
8840         }
8841         /* But otherwise fall through and escape it. */
8842     case '&':
8843     case '(':
8844     case ')':
8845     case '=':
8846     case '+':
8847     case '\'':
8848     case '@':
8849     case '[':
8850     case ']':
8851     case '{':
8852     case '}':
8853     case ':':
8854     case '\\':
8855     case '|':
8856     case '<':
8857     case '>':
8858         *(cp1++) = '^';
8859         *(cp1++) = *(cp2++);
8860         break;
8861     case ';':
8862         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8863          * which is wrong.  UNIX notation should be ".dir." unless
8864          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8865          * changing this behavior could break more things at this time.
8866          * efs character set effectively does not allow "." to be a version
8867          * delimiter as a further complication about changing this.
8868          */
8869         if (decc_filename_unix_report != 0) {
8870           *(cp1++) = '^';
8871         }
8872         *(cp1++) = *(cp2++);
8873         break;
8874     default:
8875         *(cp1++) = *(cp2++);
8876     }
8877   }
8878   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8879   char *lcp1;
8880     lcp1 = cp1;
8881     lcp1--;
8882      /* Fix me for "^]", but that requires making sure that you do
8883       * not back up past the start of the filename
8884       */
8885     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8886       *cp1++ = '.';
8887   }
8888   *cp1 = '\0';
8889
8890   if (utf8_flag != NULL)
8891     *utf8_flag = 0;
8892   if (vms_debug_fileify) {
8893       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8894   }
8895   return rslt;
8896
8897 }  /* end of int_tovmsspec() */
8898
8899
8900 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8901 static char *mp_do_tovmsspec
8902    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8903   static char __tovmsspec_retbuf[VMS_MAXRSS];
8904     char * vmsspec, *ret_spec, *ret_buf;
8905
8906     vmsspec = NULL;
8907     ret_buf = buf;
8908     if (ret_buf == NULL) {
8909         if (ts) {
8910             Newx(vmsspec, VMS_MAXRSS, char);
8911             if (vmsspec == NULL)
8912                 _ckvmssts(SS$_INSFMEM);
8913             ret_buf = vmsspec;
8914         } else {
8915             ret_buf = __tovmsspec_retbuf;
8916         }
8917     }
8918
8919     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8920
8921     if (ret_spec == NULL) {
8922        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8923        if (vmsspec)
8924            Safefree(vmsspec);
8925     }
8926
8927     return ret_spec;
8928
8929 }  /* end of mp_do_tovmsspec() */
8930 /*}}}*/
8931 /* External entry points */
8932 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8933   { return do_tovmsspec(path,buf,0,NULL); }
8934 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8935   { return do_tovmsspec(path,buf,1,NULL); }
8936 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8937   { return do_tovmsspec(path,buf,0,utf8_fl); }
8938 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8939   { return do_tovmsspec(path,buf,1,utf8_fl); }
8940
8941 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
8942 /* Internal routine for use with out an explict context present */
8943 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
8944
8945     char * ret_spec, *pathified;
8946
8947     if (path == NULL)
8948         return NULL;
8949
8950     pathified = PerlMem_malloc(VMS_MAXRSS);
8951     if (pathified == NULL)
8952         _ckvmssts_noperl(SS$_INSFMEM);
8953
8954     ret_spec = int_pathify_dirspec(path, pathified);
8955
8956     if (ret_spec == NULL) {
8957         PerlMem_free(pathified);
8958         return NULL;
8959     }
8960
8961     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
8962
8963     PerlMem_free(pathified);
8964     return ret_spec;
8965
8966 }
8967
8968 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8969 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8970   static char __tovmspath_retbuf[VMS_MAXRSS];
8971   int vmslen;
8972   char *pathified, *vmsified, *cp;
8973
8974   if (path == NULL) return NULL;
8975   pathified = PerlMem_malloc(VMS_MAXRSS);
8976   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8977   if (int_pathify_dirspec(path, pathified) == NULL) {
8978     PerlMem_free(pathified);
8979     return NULL;
8980   }
8981
8982   vmsified = NULL;
8983   if (buf == NULL)
8984      Newx(vmsified, VMS_MAXRSS, char);
8985   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8986     PerlMem_free(pathified);
8987     if (vmsified) Safefree(vmsified);
8988     return NULL;
8989   }
8990   PerlMem_free(pathified);
8991   if (buf) {
8992     return buf;
8993   }
8994   else if (ts) {
8995     vmslen = strlen(vmsified);
8996     Newx(cp,vmslen+1,char);
8997     memcpy(cp,vmsified,vmslen);
8998     cp[vmslen] = '\0';
8999     Safefree(vmsified);
9000     return cp;
9001   }
9002   else {
9003     strcpy(__tovmspath_retbuf,vmsified);
9004     Safefree(vmsified);
9005     return __tovmspath_retbuf;
9006   }
9007
9008 }  /* end of do_tovmspath() */
9009 /*}}}*/
9010 /* External entry points */
9011 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
9012   { return do_tovmspath(path,buf,0, NULL); }
9013 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
9014   { return do_tovmspath(path,buf,1, NULL); }
9015 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
9016   { return do_tovmspath(path,buf,0,utf8_fl); }
9017 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
9018   { return do_tovmspath(path,buf,1,utf8_fl); }
9019
9020
9021 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
9022 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9023   static char __tounixpath_retbuf[VMS_MAXRSS];
9024   int unixlen;
9025   char *pathified, *unixified, *cp;
9026
9027   if (path == NULL) return NULL;
9028   pathified = PerlMem_malloc(VMS_MAXRSS);
9029   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9030   if (int_pathify_dirspec(path, pathified) == NULL) {
9031     PerlMem_free(pathified);
9032     return NULL;
9033   }
9034
9035   unixified = NULL;
9036   if (buf == NULL) {
9037       Newx(unixified, VMS_MAXRSS, char);
9038   }
9039   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
9040     PerlMem_free(pathified);
9041     if (unixified) Safefree(unixified);
9042     return NULL;
9043   }
9044   PerlMem_free(pathified);
9045   if (buf) {
9046     return buf;
9047   }
9048   else if (ts) {
9049     unixlen = strlen(unixified);
9050     Newx(cp,unixlen+1,char);
9051     memcpy(cp,unixified,unixlen);
9052     cp[unixlen] = '\0';
9053     Safefree(unixified);
9054     return cp;
9055   }
9056   else {
9057     strcpy(__tounixpath_retbuf,unixified);
9058     Safefree(unixified);
9059     return __tounixpath_retbuf;
9060   }
9061
9062 }  /* end of do_tounixpath() */
9063 /*}}}*/
9064 /* External entry points */
9065 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
9066   { return do_tounixpath(path,buf,0,NULL); }
9067 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9068   { return do_tounixpath(path,buf,1,NULL); }
9069 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9070   { return do_tounixpath(path,buf,0,utf8_fl); }
9071 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9072   { return do_tounixpath(path,buf,1,utf8_fl); }
9073
9074 /*
9075  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
9076  *
9077  *****************************************************************************
9078  *                                                                           *
9079  *  Copyright (C) 1989-1994, 2007 by                                         *
9080  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
9081  *                                                                           *
9082  *  Permission is hereby granted for the reproduction of this software       *
9083  *  on condition that this copyright notice is included in source            *
9084  *  distributions of the software.  The code may be modified and             *
9085  *  distributed under the same terms as Perl itself.                         *
9086  *                                                                           *
9087  *  27-Aug-1994 Modified for inclusion in perl5                              *
9088  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
9089  *****************************************************************************
9090  */
9091
9092 /*
9093  * getredirection() is intended to aid in porting C programs
9094  * to VMS (Vax-11 C).  The native VMS environment does not support
9095  * '>' and '<' I/O redirection, or command line wild card expansion,
9096  * or a command line pipe mechanism using the '|' AND background
9097  * command execution '&'.  All of these capabilities are provided to any
9098  * C program which calls this procedure as the first thing in the
9099  * main program.
9100  * The piping mechanism will probably work with almost any 'filter' type
9101  * of program.  With suitable modification, it may useful for other
9102  * portability problems as well.
9103  *
9104  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
9105  */
9106 struct list_item
9107     {
9108     struct list_item *next;
9109     char *value;
9110     };
9111
9112 static void add_item(struct list_item **head,
9113                      struct list_item **tail,
9114                      char *value,
9115                      int *count);
9116
9117 static void mp_expand_wild_cards(pTHX_ char *item,
9118                                 struct list_item **head,
9119                                 struct list_item **tail,
9120                                 int *count);
9121
9122 static int background_process(pTHX_ int argc, char **argv);
9123
9124 static void pipe_and_fork(pTHX_ char **cmargv);
9125
9126 /*{{{ void getredirection(int *ac, char ***av)*/
9127 static void
9128 mp_getredirection(pTHX_ int *ac, char ***av)
9129 /*
9130  * Process vms redirection arg's.  Exit if any error is seen.
9131  * If getredirection() processes an argument, it is erased
9132  * from the vector.  getredirection() returns a new argc and argv value.
9133  * In the event that a background command is requested (by a trailing "&"),
9134  * this routine creates a background subprocess, and simply exits the program.
9135  *
9136  * Warning: do not try to simplify the code for vms.  The code
9137  * presupposes that getredirection() is called before any data is
9138  * read from stdin or written to stdout.
9139  *
9140  * Normal usage is as follows:
9141  *
9142  *      main(argc, argv)
9143  *      int             argc;
9144  *      char            *argv[];
9145  *      {
9146  *              getredirection(&argc, &argv);
9147  *      }
9148  */
9149 {
9150     int                 argc = *ac;     /* Argument Count         */
9151     char                **argv = *av;   /* Argument Vector        */
9152     char                *ap;            /* Argument pointer       */
9153     int                 j;              /* argv[] index           */
9154     int                 item_count = 0; /* Count of Items in List */
9155     struct list_item    *list_head = 0; /* First Item in List       */
9156     struct list_item    *list_tail;     /* Last Item in List        */
9157     char                *in = NULL;     /* Input File Name          */
9158     char                *out = NULL;    /* Output File Name         */
9159     char                *outmode = "w"; /* Mode to Open Output File */
9160     char                *err = NULL;    /* Error File Name          */
9161     char                *errmode = "w"; /* Mode to Open Error File  */
9162     int                 cmargc = 0;     /* Piped Command Arg Count  */
9163     char                **cmargv = NULL;/* Piped Command Arg Vector */
9164
9165     /*
9166      * First handle the case where the last thing on the line ends with
9167      * a '&'.  This indicates the desire for the command to be run in a
9168      * subprocess, so we satisfy that desire.
9169      */
9170     ap = argv[argc-1];
9171     if (0 == strcmp("&", ap))
9172        exit(background_process(aTHX_ --argc, argv));
9173     if (*ap && '&' == ap[strlen(ap)-1])
9174         {
9175         ap[strlen(ap)-1] = '\0';
9176        exit(background_process(aTHX_ argc, argv));
9177         }
9178     /*
9179      * Now we handle the general redirection cases that involve '>', '>>',
9180      * '<', and pipes '|'.
9181      */
9182     for (j = 0; j < argc; ++j)
9183         {
9184         if (0 == strcmp("<", argv[j]))
9185             {
9186             if (j+1 >= argc)
9187                 {
9188                 fprintf(stderr,"No input file after < on command line");
9189                 exit(LIB$_WRONUMARG);
9190                 }
9191             in = argv[++j];
9192             continue;
9193             }
9194         if ('<' == *(ap = argv[j]))
9195             {
9196             in = 1 + ap;
9197             continue;
9198             }
9199         if (0 == strcmp(">", ap))
9200             {
9201             if (j+1 >= argc)
9202                 {
9203                 fprintf(stderr,"No output file after > on command line");
9204                 exit(LIB$_WRONUMARG);
9205                 }
9206             out = argv[++j];
9207             continue;
9208             }
9209         if ('>' == *ap)
9210             {
9211             if ('>' == ap[1])
9212                 {
9213                 outmode = "a";
9214                 if ('\0' == ap[2])
9215                     out = argv[++j];
9216                 else
9217                     out = 2 + ap;
9218                 }
9219             else
9220                 out = 1 + ap;
9221             if (j >= argc)
9222                 {
9223                 fprintf(stderr,"No output file after > or >> on command line");
9224                 exit(LIB$_WRONUMARG);
9225                 }
9226             continue;
9227             }
9228         if (('2' == *ap) && ('>' == ap[1]))
9229             {
9230             if ('>' == ap[2])
9231                 {
9232                 errmode = "a";
9233                 if ('\0' == ap[3])
9234                     err = argv[++j];
9235                 else
9236                     err = 3 + ap;
9237                 }
9238             else
9239                 if ('\0' == ap[2])
9240                     err = argv[++j];
9241                 else
9242                     err = 2 + ap;
9243             if (j >= argc)
9244                 {
9245                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9246                 exit(LIB$_WRONUMARG);
9247                 }
9248             continue;
9249             }
9250         if (0 == strcmp("|", argv[j]))
9251             {
9252             if (j+1 >= argc)
9253                 {
9254                 fprintf(stderr,"No command into which to pipe on command line");
9255                 exit(LIB$_WRONUMARG);
9256                 }
9257             cmargc = argc-(j+1);
9258             cmargv = &argv[j+1];
9259             argc = j;
9260             continue;
9261             }
9262         if ('|' == *(ap = argv[j]))
9263             {
9264             ++argv[j];
9265             cmargc = argc-j;
9266             cmargv = &argv[j];
9267             argc = j;
9268             continue;
9269             }
9270         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9271         }
9272     /*
9273      * Allocate and fill in the new argument vector, Some Unix's terminate
9274      * the list with an extra null pointer.
9275      */
9276     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9277     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9278     *av = argv;
9279     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9280         argv[j] = list_head->value;
9281     *ac = item_count;
9282     if (cmargv != NULL)
9283         {
9284         if (out != NULL)
9285             {
9286             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9287             exit(LIB$_INVARGORD);
9288             }
9289         pipe_and_fork(aTHX_ cmargv);
9290         }
9291
9292     /* Check for input from a pipe (mailbox) */
9293
9294     if (in == NULL && 1 == isapipe(0))
9295         {
9296         char mbxname[L_tmpnam];
9297         long int bufsize;
9298         long int dvi_item = DVI$_DEVBUFSIZ;
9299         $DESCRIPTOR(mbxnam, "");
9300         $DESCRIPTOR(mbxdevnam, "");
9301
9302         /* Input from a pipe, reopen it in binary mode to disable       */
9303         /* carriage control processing.                                 */
9304
9305         fgetname(stdin, mbxname);
9306         mbxnam.dsc$a_pointer = mbxname;
9307         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9308         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9309         mbxdevnam.dsc$a_pointer = mbxname;
9310         mbxdevnam.dsc$w_length = sizeof(mbxname);
9311         dvi_item = DVI$_DEVNAM;
9312         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9313         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9314         set_errno(0);
9315         set_vaxc_errno(1);
9316         freopen(mbxname, "rb", stdin);
9317         if (errno != 0)
9318             {
9319             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9320             exit(vaxc$errno);
9321             }
9322         }
9323     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9324         {
9325         fprintf(stderr,"Can't open input file %s as stdin",in);
9326         exit(vaxc$errno);
9327         }
9328     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9329         {
9330         fprintf(stderr,"Can't open output file %s as stdout",out);
9331         exit(vaxc$errno);
9332         }
9333         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9334
9335     if (err != NULL) {
9336         if (strcmp(err,"&1") == 0) {
9337             dup2(fileno(stdout), fileno(stderr));
9338             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9339         } else {
9340         FILE *tmperr;
9341         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9342             {
9343             fprintf(stderr,"Can't open error file %s as stderr",err);
9344             exit(vaxc$errno);
9345             }
9346             fclose(tmperr);
9347            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9348                 {
9349                 exit(vaxc$errno);
9350                 }
9351             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9352         }
9353         }
9354 #ifdef ARGPROC_DEBUG
9355     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9356     for (j = 0; j < *ac;  ++j)
9357         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9358 #endif
9359    /* Clear errors we may have hit expanding wildcards, so they don't
9360       show up in Perl's $! later */
9361    set_errno(0); set_vaxc_errno(1);
9362 }  /* end of getredirection() */
9363 /*}}}*/
9364
9365 static void add_item(struct list_item **head,
9366                      struct list_item **tail,
9367                      char *value,
9368                      int *count)
9369 {
9370     if (*head == 0)
9371         {
9372         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9373         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9374         *tail = *head;
9375         }
9376     else {
9377         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9378         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9379         *tail = (*tail)->next;
9380         }
9381     (*tail)->value = value;
9382     ++(*count);
9383 }
9384
9385 static void mp_expand_wild_cards(pTHX_ char *item,
9386                               struct list_item **head,
9387                               struct list_item **tail,
9388                               int *count)
9389 {
9390 int expcount = 0;
9391 unsigned long int context = 0;
9392 int isunix = 0;
9393 int item_len = 0;
9394 char *had_version;
9395 char *had_device;
9396 int had_directory;
9397 char *devdir,*cp;
9398 char *vmsspec;
9399 $DESCRIPTOR(filespec, "");
9400 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9401 $DESCRIPTOR(resultspec, "");
9402 unsigned long int lff_flags = 0;
9403 int sts;
9404 int rms_sts;
9405
9406 #ifdef VMS_LONGNAME_SUPPORT
9407     lff_flags = LIB$M_FIL_LONG_NAMES;
9408 #endif
9409
9410     for (cp = item; *cp; cp++) {
9411         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9412         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9413     }
9414     if (!*cp || isspace(*cp))
9415         {
9416         add_item(head, tail, item, count);
9417         return;
9418         }
9419     else
9420         {
9421      /* "double quoted" wild card expressions pass as is */
9422      /* From DCL that means using e.g.:                  */
9423      /* perl program """perl.*"""                        */
9424      item_len = strlen(item);
9425      if ( '"' == *item && '"' == item[item_len-1] )
9426        {
9427        item++;
9428        item[item_len-2] = '\0';
9429        add_item(head, tail, item, count);
9430        return;
9431        }
9432      }
9433     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9434     resultspec.dsc$b_class = DSC$K_CLASS_D;
9435     resultspec.dsc$a_pointer = NULL;
9436     vmsspec = PerlMem_malloc(VMS_MAXRSS);
9437     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9438     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9439       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9440     if (!isunix || !filespec.dsc$a_pointer)
9441       filespec.dsc$a_pointer = item;
9442     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9443     /*
9444      * Only return version specs, if the caller specified a version
9445      */
9446     had_version = strchr(item, ';');
9447     /*
9448      * Only return device and directory specs, if the caller specifed either.
9449      */
9450     had_device = strchr(item, ':');
9451     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9452
9453     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9454                                  (&filespec, &resultspec, &context,
9455                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9456         {
9457         char *string;
9458         char *c;
9459
9460         string = PerlMem_malloc(resultspec.dsc$w_length+1);
9461         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9462         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
9463         string[resultspec.dsc$w_length] = '\0';
9464         if (NULL == had_version)
9465             *(strrchr(string, ';')) = '\0';
9466         if ((!had_directory) && (had_device == NULL))
9467             {
9468             if (NULL == (devdir = strrchr(string, ']')))
9469                 devdir = strrchr(string, '>');
9470             strcpy(string, devdir + 1);
9471             }
9472         /*
9473          * Be consistent with what the C RTL has already done to the rest of
9474          * the argv items and lowercase all of these names.
9475          */
9476         if (!decc_efs_case_preserve) {
9477             for (c = string; *c; ++c)
9478             if (isupper(*c))
9479                 *c = tolower(*c);
9480         }
9481         if (isunix) trim_unixpath(string,item,1);
9482         add_item(head, tail, string, count);
9483         ++expcount;
9484     }
9485     PerlMem_free(vmsspec);
9486     if (sts != RMS$_NMF)
9487         {
9488         set_vaxc_errno(sts);
9489         switch (sts)
9490             {
9491             case RMS$_FNF: case RMS$_DNF:
9492                 set_errno(ENOENT); break;
9493             case RMS$_DIR:
9494                 set_errno(ENOTDIR); break;
9495             case RMS$_DEV:
9496                 set_errno(ENODEV); break;
9497             case RMS$_FNM: case RMS$_SYN:
9498                 set_errno(EINVAL); break;
9499             case RMS$_PRV:
9500                 set_errno(EACCES); break;
9501             default:
9502                 _ckvmssts_noperl(sts);
9503             }
9504         }
9505     if (expcount == 0)
9506         add_item(head, tail, item, count);
9507     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9508     _ckvmssts_noperl(lib$find_file_end(&context));
9509 }
9510
9511 static int child_st[2];/* Event Flag set when child process completes   */
9512
9513 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9514
9515 static unsigned long int exit_handler(int *status)
9516 {
9517 short iosb[4];
9518
9519     if (0 == child_st[0])
9520         {
9521 #ifdef ARGPROC_DEBUG
9522         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9523 #endif
9524         fflush(stdout);     /* Have to flush pipe for binary data to    */
9525                             /* terminate properly -- <tp@mccall.com>    */
9526         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9527         sys$dassgn(child_chan);
9528         fclose(stdout);
9529         sys$synch(0, child_st);
9530         }
9531     return(1);
9532 }
9533
9534 static void sig_child(int chan)
9535 {
9536 #ifdef ARGPROC_DEBUG
9537     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9538 #endif
9539     if (child_st[0] == 0)
9540         child_st[0] = 1;
9541 }
9542
9543 static struct exit_control_block exit_block =
9544     {
9545     0,
9546     exit_handler,
9547     1,
9548     &exit_block.exit_status,
9549     0
9550     };
9551
9552 static void
9553 pipe_and_fork(pTHX_ char **cmargv)
9554 {
9555     PerlIO *fp;
9556     struct dsc$descriptor_s *vmscmd;
9557     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9558     int sts, j, l, ismcr, quote, tquote = 0;
9559
9560     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9561     vms_execfree(vmscmd);
9562
9563     j = l = 0;
9564     p = subcmd;
9565     q = cmargv[0];
9566     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9567               && toupper(*(q+2)) == 'R' && !*(q+3);
9568
9569     while (q && l < MAX_DCL_LINE_LENGTH) {
9570         if (!*q) {
9571             if (j > 0 && quote) {
9572                 *p++ = '"';
9573                 l++;
9574             }
9575             q = cmargv[++j];
9576             if (q) {
9577                 if (ismcr && j > 1) quote = 1;
9578                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9579                 *p++ = ' ';
9580                 l++;
9581                 if (quote || tquote) {
9582                     *p++ = '"';
9583                     l++;
9584                 }
9585             }
9586         } else {
9587             if ((quote||tquote) && *q == '"') {
9588                 *p++ = '"';
9589                 l++;
9590             }
9591             *p++ = *q++;
9592             l++;
9593         }
9594     }
9595     *p = '\0';
9596
9597     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9598     if (fp == NULL) {
9599         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9600     }
9601 }
9602
9603 static int background_process(pTHX_ int argc, char **argv)
9604 {
9605 char command[MAX_DCL_SYMBOL + 1] = "$";
9606 $DESCRIPTOR(value, "");
9607 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9608 static $DESCRIPTOR(null, "NLA0:");
9609 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9610 char pidstring[80];
9611 $DESCRIPTOR(pidstr, "");
9612 int pid;
9613 unsigned long int flags = 17, one = 1, retsts;
9614 int len;
9615
9616     strcat(command, argv[0]);
9617     len = strlen(command);
9618     while (--argc && (len < MAX_DCL_SYMBOL))
9619         {
9620         strcat(command, " \"");
9621         strcat(command, *(++argv));
9622         strcat(command, "\"");
9623         len = strlen(command);
9624         }
9625     value.dsc$a_pointer = command;
9626     value.dsc$w_length = strlen(value.dsc$a_pointer);
9627     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9628     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9629     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9630         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9631     }
9632     else {
9633         _ckvmssts_noperl(retsts);
9634     }
9635 #ifdef ARGPROC_DEBUG
9636     PerlIO_printf(Perl_debug_log, "%s\n", command);
9637 #endif
9638     sprintf(pidstring, "%08X", pid);
9639     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9640     pidstr.dsc$a_pointer = pidstring;
9641     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9642     lib$set_symbol(&pidsymbol, &pidstr);
9643     return(SS$_NORMAL);
9644 }
9645 /*}}}*/
9646 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9647
9648
9649 /* OS-specific initialization at image activation (not thread startup) */
9650 /* Older VAXC header files lack these constants */
9651 #ifndef JPI$_RIGHTS_SIZE
9652 #  define JPI$_RIGHTS_SIZE 817
9653 #endif
9654 #ifndef KGB$M_SUBSYSTEM
9655 #  define KGB$M_SUBSYSTEM 0x8
9656 #endif
9657
9658 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9659
9660 /*{{{void vms_image_init(int *, char ***)*/
9661 void
9662 vms_image_init(int *argcp, char ***argvp)
9663 {
9664   int status;
9665   char eqv[LNM$C_NAMLENGTH+1] = "";
9666   unsigned int len, tabct = 8, tabidx = 0;
9667   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9668   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9669   unsigned short int dummy, rlen;
9670   struct dsc$descriptor_s **tabvec;
9671 #if defined(PERL_IMPLICIT_CONTEXT)
9672   pTHX = NULL;
9673 #endif
9674   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9675                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9676                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9677                                  {          0,                0,    0,      0} };
9678
9679 #ifdef KILL_BY_SIGPRC
9680     Perl_csighandler_init();
9681 #endif
9682
9683     /* This was moved from the pre-image init handler because on threaded */
9684     /* Perl it was always returning 0 for the default value. */
9685     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9686     if (status > 0) {
9687         int s;
9688         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9689         if (s > 0) {
9690             int initial;
9691             initial = decc$feature_get_value(s, 4);
9692             if (initial > 0) {
9693                 /* initial is: 0 if nothing has set the feature */
9694                 /*            -1 if initialized to default */
9695                 /*             1 if set by logical name */
9696                 /*             2 if set by decc$feature_set_value */
9697                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9698
9699                 /* If the value is not valid, force the feature off */
9700                 if (decc_disable_posix_root < 0) {
9701                     decc$feature_set_value(s, 1, 1);
9702                     decc_disable_posix_root = 1;
9703                 }
9704             }
9705             else {
9706                 /* Nothing has asked for it explicitly, so use our own default. */
9707                 decc_disable_posix_root = 1;
9708                 decc$feature_set_value(s, 1, 1);
9709             }
9710         }
9711     }
9712
9713
9714   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9715   _ckvmssts_noperl(iosb[0]);
9716   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9717     if (iprv[i]) {           /* Running image installed with privs? */
9718       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9719       will_taint = TRUE;
9720       break;
9721     }
9722   }
9723   /* Rights identifiers might trigger tainting as well. */
9724   if (!will_taint && (rlen || rsz)) {
9725     while (rlen < rsz) {
9726       /* We didn't get all the identifiers on the first pass.  Allocate a
9727        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9728        * were needed to hold all identifiers at time of last call; we'll
9729        * allocate that many unsigned long ints), and go back and get 'em.
9730        * If it gave us less than it wanted to despite ample buffer space,
9731        * something's broken.  Is your system missing a system identifier?
9732        */
9733       if (rsz <= jpilist[1].buflen) {
9734          /* Perl_croak accvios when used this early in startup. */
9735          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9736                          rsz, (unsigned long) jpilist[1].buflen,
9737                          "Check your rights database for corruption.\n");
9738          exit(SS$_ABORT);
9739       }
9740       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9741       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9742       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9743       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9744       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9745       _ckvmssts_noperl(iosb[0]);
9746     }
9747     mask = jpilist[1].bufadr;
9748     /* Check attribute flags for each identifier (2nd longword); protected
9749      * subsystem identifiers trigger tainting.
9750      */
9751     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9752       if (mask[i] & KGB$M_SUBSYSTEM) {
9753         will_taint = TRUE;
9754         break;
9755       }
9756     }
9757     if (mask != rlst) PerlMem_free(mask);
9758   }
9759
9760   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9761    * logical, some versions of the CRTL will add a phanthom /000000/
9762    * directory.  This needs to be removed.
9763    */
9764   if (decc_filename_unix_report) {
9765   char * zeros;
9766   int ulen;
9767     ulen = strlen(argvp[0][0]);
9768     if (ulen > 7) {
9769       zeros = strstr(argvp[0][0], "/000000/");
9770       if (zeros != NULL) {
9771         int mlen;
9772         mlen = ulen - (zeros - argvp[0][0]) - 7;
9773         memmove(zeros, &zeros[7], mlen);
9774         ulen = ulen - 7;
9775         argvp[0][0][ulen] = '\0';
9776       }
9777     }
9778     /* It also may have a trailing dot that needs to be removed otherwise
9779      * it will be converted to VMS mode incorrectly.
9780      */
9781     ulen--;
9782     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9783       argvp[0][0][ulen] = '\0';
9784   }
9785
9786   /* We need to use this hack to tell Perl it should run with tainting,
9787    * since its tainting flag may be part of the PL_curinterp struct, which
9788    * hasn't been allocated when vms_image_init() is called.
9789    */
9790   if (will_taint) {
9791     char **newargv, **oldargv;
9792     oldargv = *argvp;
9793     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9794     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9795     newargv[0] = oldargv[0];
9796     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9797     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9798     strcpy(newargv[1], "-T");
9799     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9800     (*argcp)++;
9801     newargv[*argcp] = NULL;
9802     /* We orphan the old argv, since we don't know where it's come from,
9803      * so we don't know how to free it.
9804      */
9805     *argvp = newargv;
9806   }
9807   else {  /* Did user explicitly request tainting? */
9808     int i;
9809     char *cp, **av = *argvp;
9810     for (i = 1; i < *argcp; i++) {
9811       if (*av[i] != '-') break;
9812       for (cp = av[i]+1; *cp; cp++) {
9813         if (*cp == 'T') { will_taint = 1; break; }
9814         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9815                   strchr("DFIiMmx",*cp)) break;
9816       }
9817       if (will_taint) break;
9818     }
9819   }
9820
9821   for (tabidx = 0;
9822        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9823        tabidx++) {
9824     if (!tabidx) {
9825       tabvec = (struct dsc$descriptor_s **)
9826             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9827       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9828     }
9829     else if (tabidx >= tabct) {
9830       tabct += 8;
9831       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9832       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9833     }
9834     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9835     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9836     tabvec[tabidx]->dsc$w_length  = 0;
9837     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9838     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9839     tabvec[tabidx]->dsc$a_pointer = NULL;
9840     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9841   }
9842   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9843
9844   getredirection(argcp,argvp);
9845 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9846   {
9847 # include <reentrancy.h>
9848   decc$set_reentrancy(C$C_MULTITHREAD);
9849   }
9850 #endif
9851   return;
9852 }
9853 /*}}}*/
9854
9855
9856 /* trim_unixpath()
9857  * Trim Unix-style prefix off filespec, so it looks like what a shell
9858  * glob expansion would return (i.e. from specified prefix on, not
9859  * full path).  Note that returned filespec is Unix-style, regardless
9860  * of whether input filespec was VMS-style or Unix-style.
9861  *
9862  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9863  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9864  * vector of options; at present, only bit 0 is used, and if set tells
9865  * trim unixpath to try the current default directory as a prefix when
9866  * presented with a possibly ambiguous ... wildcard.
9867  *
9868  * Returns !=0 on success, with trimmed filespec replacing contents of
9869  * fspec, and 0 on failure, with contents of fpsec unchanged.
9870  */
9871 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9872 int
9873 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9874 {
9875   char *unixified, *unixwild,
9876        *template, *base, *end, *cp1, *cp2;
9877   register int tmplen, reslen = 0, dirs = 0;
9878
9879   if (!wildspec || !fspec) return 0;
9880
9881   unixwild = PerlMem_malloc(VMS_MAXRSS);
9882   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9883   template = unixwild;
9884   if (strpbrk(wildspec,"]>:") != NULL) {
9885     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9886         PerlMem_free(unixwild);
9887         return 0;
9888     }
9889   }
9890   else {
9891     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9892     unixwild[VMS_MAXRSS-1] = 0;
9893   }
9894   unixified = PerlMem_malloc(VMS_MAXRSS);
9895   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9896   if (strpbrk(fspec,"]>:") != NULL) {
9897     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9898         PerlMem_free(unixwild);
9899         PerlMem_free(unixified);
9900         return 0;
9901     }
9902     else base = unixified;
9903     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9904      * check to see that final result fits into (isn't longer than) fspec */
9905     reslen = strlen(fspec);
9906   }
9907   else base = fspec;
9908
9909   /* No prefix or absolute path on wildcard, so nothing to remove */
9910   if (!*template || *template == '/') {
9911     PerlMem_free(unixwild);
9912     if (base == fspec) {
9913         PerlMem_free(unixified);
9914         return 1;
9915     }
9916     tmplen = strlen(unixified);
9917     if (tmplen > reslen) {
9918         PerlMem_free(unixified);
9919         return 0;  /* not enough space */
9920     }
9921     /* Copy unixified resultant, including trailing NUL */
9922     memmove(fspec,unixified,tmplen+1);
9923     PerlMem_free(unixified);
9924     return 1;
9925   }
9926
9927   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9928   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9929     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9930     for (cp1 = end ;cp1 >= base; cp1--)
9931       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9932         { cp1++; break; }
9933     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9934     PerlMem_free(unixified);
9935     PerlMem_free(unixwild);
9936     return 1;
9937   }
9938   else {
9939     char *tpl, *lcres;
9940     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9941     int ells = 1, totells, segdirs, match;
9942     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9943                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9944
9945     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9946     totells = ells;
9947     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9948     tpl = PerlMem_malloc(VMS_MAXRSS);
9949     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9950     if (ellipsis == template && opts & 1) {
9951       /* Template begins with an ellipsis.  Since we can't tell how many
9952        * directory names at the front of the resultant to keep for an
9953        * arbitrary starting point, we arbitrarily choose the current
9954        * default directory as a starting point.  If it's there as a prefix,
9955        * clip it off.  If not, fall through and act as if the leading
9956        * ellipsis weren't there (i.e. return shortest possible path that
9957        * could match template).
9958        */
9959       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9960           PerlMem_free(tpl);
9961           PerlMem_free(unixified);
9962           PerlMem_free(unixwild);
9963           return 0;
9964       }
9965       if (!decc_efs_case_preserve) {
9966         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9967           if (_tolower(*cp1) != _tolower(*cp2)) break;
9968       }
9969       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9970       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9971       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9972         memmove(fspec,cp2+1,end - cp2);
9973         PerlMem_free(tpl);
9974         PerlMem_free(unixified);
9975         PerlMem_free(unixwild);
9976         return 1;
9977       }
9978     }
9979     /* First off, back up over constant elements at end of path */
9980     if (dirs) {
9981       for (front = end ; front >= base; front--)
9982          if (*front == '/' && !dirs--) { front++; break; }
9983     }
9984     lcres = PerlMem_malloc(VMS_MAXRSS);
9985     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9986     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9987          cp1++,cp2++) {
9988             if (!decc_efs_case_preserve) {
9989                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9990             }
9991             else {
9992                 *cp2 = *cp1;
9993             }
9994     }
9995     if (cp1 != '\0') {
9996         PerlMem_free(tpl);
9997         PerlMem_free(unixified);
9998         PerlMem_free(unixwild);
9999         PerlMem_free(lcres);
10000         return 0;  /* Path too long. */
10001     }
10002     lcend = cp2;
10003     *cp2 = '\0';  /* Pick up with memcpy later */
10004     lcfront = lcres + (front - base);
10005     /* Now skip over each ellipsis and try to match the path in front of it. */
10006     while (ells--) {
10007       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
10008         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
10009             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
10010       if (cp1 < template) break; /* template started with an ellipsis */
10011       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
10012         ellipsis = cp1; continue;
10013       }
10014       wilddsc.dsc$a_pointer = tpl;
10015       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
10016       nextell = cp1;
10017       for (segdirs = 0, cp2 = tpl;
10018            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
10019            cp1++, cp2++) {
10020          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
10021          else {
10022             if (!decc_efs_case_preserve) {
10023               *cp2 = _tolower(*cp1);  /* else lowercase for match */
10024             }
10025             else {
10026               *cp2 = *cp1;  /* else preserve case for match */
10027             }
10028          }
10029          if (*cp2 == '/') segdirs++;
10030       }
10031       if (cp1 != ellipsis - 1) {
10032           PerlMem_free(tpl);
10033           PerlMem_free(unixified);
10034           PerlMem_free(unixwild);
10035           PerlMem_free(lcres);
10036           return 0; /* Path too long */
10037       }
10038       /* Back up at least as many dirs as in template before matching */
10039       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
10040         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
10041       for (match = 0; cp1 > lcres;) {
10042         resdsc.dsc$a_pointer = cp1;
10043         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
10044           match++;
10045           if (match == 1) lcfront = cp1;
10046         }
10047         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
10048       }
10049       if (!match) {
10050         PerlMem_free(tpl);
10051         PerlMem_free(unixified);
10052         PerlMem_free(unixwild);
10053         PerlMem_free(lcres);
10054         return 0;  /* Can't find prefix ??? */
10055       }
10056       if (match > 1 && opts & 1) {
10057         /* This ... wildcard could cover more than one set of dirs (i.e.
10058          * a set of similar dir names is repeated).  If the template
10059          * contains more than 1 ..., upstream elements could resolve the
10060          * ambiguity, but it's not worth a full backtracking setup here.
10061          * As a quick heuristic, clip off the current default directory
10062          * if it's present to find the trimmed spec, else use the
10063          * shortest string that this ... could cover.
10064          */
10065         char def[NAM$C_MAXRSS+1], *st;
10066
10067         if (getcwd(def, sizeof def,0) == NULL) {
10068             PerlMem_free(unixified);
10069             PerlMem_free(unixwild);
10070             PerlMem_free(lcres);
10071             PerlMem_free(tpl);
10072             return 0;
10073         }
10074         if (!decc_efs_case_preserve) {
10075           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10076             if (_tolower(*cp1) != _tolower(*cp2)) break;
10077         }
10078         segdirs = dirs - totells;  /* Min # of dirs we must have left */
10079         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10080         if (*cp1 == '\0' && *cp2 == '/') {
10081           memmove(fspec,cp2+1,end - cp2);
10082           PerlMem_free(tpl);
10083           PerlMem_free(unixified);
10084           PerlMem_free(unixwild);
10085           PerlMem_free(lcres);
10086           return 1;
10087         }
10088         /* Nope -- stick with lcfront from above and keep going. */
10089       }
10090     }
10091     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10092     PerlMem_free(tpl);
10093     PerlMem_free(unixified);
10094     PerlMem_free(unixwild);
10095     PerlMem_free(lcres);
10096     return 1;
10097     ellipsis = nextell;
10098   }
10099
10100 }  /* end of trim_unixpath() */
10101 /*}}}*/
10102
10103
10104 /*
10105  *  VMS readdir() routines.
10106  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10107  *
10108  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
10109  *  Minor modifications to original routines.
10110  */
10111
10112 /* readdir may have been redefined by reentr.h, so make sure we get
10113  * the local version for what we do here.
10114  */
10115 #ifdef readdir
10116 # undef readdir
10117 #endif
10118 #if !defined(PERL_IMPLICIT_CONTEXT)
10119 # define readdir Perl_readdir
10120 #else
10121 # define readdir(a) Perl_readdir(aTHX_ a)
10122 #endif
10123
10124     /* Number of elements in vms_versions array */
10125 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
10126
10127 /*
10128  *  Open a directory, return a handle for later use.
10129  */
10130 /*{{{ DIR *opendir(char*name) */
10131 DIR *
10132 Perl_opendir(pTHX_ const char *name)
10133 {
10134     DIR *dd;
10135     char *dir;
10136     Stat_t sb;
10137
10138     Newx(dir, VMS_MAXRSS, char);
10139     if (int_tovmspath(name, dir, NULL) == NULL) {
10140       Safefree(dir);
10141       return NULL;
10142     }
10143     /* Check access before stat; otherwise stat does not
10144      * accurately report whether it's a directory.
10145      */
10146     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10147       /* cando_by_name has already set errno */
10148       Safefree(dir);
10149       return NULL;
10150     }
10151     if (flex_stat(dir,&sb) == -1) return NULL;
10152     if (!S_ISDIR(sb.st_mode)) {
10153       Safefree(dir);
10154       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
10155       return NULL;
10156     }
10157     /* Get memory for the handle, and the pattern. */
10158     Newx(dd,1,DIR);
10159     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10160
10161     /* Fill in the fields; mainly playing with the descriptor. */
10162     sprintf(dd->pattern, "%s*.*",dir);
10163     Safefree(dir);
10164     dd->context = 0;
10165     dd->count = 0;
10166     dd->flags = 0;
10167     /* By saying we always want the result of readdir() in unix format, we
10168      * are really saying we want all the escapes removed.  Otherwise the caller,
10169      * having no way to know whether it's already in VMS format, might send it
10170      * through tovmsspec again, thus double escaping.
10171      */
10172     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
10173     dd->pat.dsc$a_pointer = dd->pattern;
10174     dd->pat.dsc$w_length = strlen(dd->pattern);
10175     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10176     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10177 #if defined(USE_ITHREADS)
10178     Newx(dd->mutex,1,perl_mutex);
10179     MUTEX_INIT( (perl_mutex *) dd->mutex );
10180 #else
10181     dd->mutex = NULL;
10182 #endif
10183
10184     return dd;
10185 }  /* end of opendir() */
10186 /*}}}*/
10187
10188 /*
10189  *  Set the flag to indicate we want versions or not.
10190  */
10191 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10192 void
10193 vmsreaddirversions(DIR *dd, int flag)
10194 {
10195     if (flag)
10196         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10197     else
10198         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10199 }
10200 /*}}}*/
10201
10202 /*
10203  *  Free up an opened directory.
10204  */
10205 /*{{{ void closedir(DIR *dd)*/
10206 void
10207 Perl_closedir(DIR *dd)
10208 {
10209     int sts;
10210
10211     sts = lib$find_file_end(&dd->context);
10212     Safefree(dd->pattern);
10213 #if defined(USE_ITHREADS)
10214     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10215     Safefree(dd->mutex);
10216 #endif
10217     Safefree(dd);
10218 }
10219 /*}}}*/
10220
10221 /*
10222  *  Collect all the version numbers for the current file.
10223  */
10224 static void
10225 collectversions(pTHX_ DIR *dd)
10226 {
10227     struct dsc$descriptor_s     pat;
10228     struct dsc$descriptor_s     res;
10229     struct dirent *e;
10230     char *p, *text, *buff;
10231     int i;
10232     unsigned long context, tmpsts;
10233
10234     /* Convenient shorthand. */
10235     e = &dd->entry;
10236
10237     /* Add the version wildcard, ignoring the "*.*" put on before */
10238     i = strlen(dd->pattern);
10239     Newx(text,i + e->d_namlen + 3,char);
10240     strcpy(text, dd->pattern);
10241     sprintf(&text[i - 3], "%s;*", e->d_name);
10242
10243     /* Set up the pattern descriptor. */
10244     pat.dsc$a_pointer = text;
10245     pat.dsc$w_length = i + e->d_namlen - 1;
10246     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10247     pat.dsc$b_class = DSC$K_CLASS_S;
10248
10249     /* Set up result descriptor. */
10250     Newx(buff, VMS_MAXRSS, char);
10251     res.dsc$a_pointer = buff;
10252     res.dsc$w_length = VMS_MAXRSS - 1;
10253     res.dsc$b_dtype = DSC$K_DTYPE_T;
10254     res.dsc$b_class = DSC$K_CLASS_S;
10255
10256     /* Read files, collecting versions. */
10257     for (context = 0, e->vms_verscount = 0;
10258          e->vms_verscount < VERSIZE(e);
10259          e->vms_verscount++) {
10260         unsigned long rsts;
10261         unsigned long flags = 0;
10262
10263 #ifdef VMS_LONGNAME_SUPPORT
10264         flags = LIB$M_FIL_LONG_NAMES;
10265 #endif
10266         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10267         if (tmpsts == RMS$_NMF || context == 0) break;
10268         _ckvmssts(tmpsts);
10269         buff[VMS_MAXRSS - 1] = '\0';
10270         if ((p = strchr(buff, ';')))
10271             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10272         else
10273             e->vms_versions[e->vms_verscount] = -1;
10274     }
10275
10276     _ckvmssts(lib$find_file_end(&context));
10277     Safefree(text);
10278     Safefree(buff);
10279
10280 }  /* end of collectversions() */
10281
10282 /*
10283  *  Read the next entry from the directory.
10284  */
10285 /*{{{ struct dirent *readdir(DIR *dd)*/
10286 struct dirent *
10287 Perl_readdir(pTHX_ DIR *dd)
10288 {
10289     struct dsc$descriptor_s     res;
10290     char *p, *buff;
10291     unsigned long int tmpsts;
10292     unsigned long rsts;
10293     unsigned long flags = 0;
10294     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10295     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10296
10297     /* Set up result descriptor, and get next file. */
10298     Newx(buff, VMS_MAXRSS, char);
10299     res.dsc$a_pointer = buff;
10300     res.dsc$w_length = VMS_MAXRSS - 1;
10301     res.dsc$b_dtype = DSC$K_DTYPE_T;
10302     res.dsc$b_class = DSC$K_CLASS_S;
10303
10304 #ifdef VMS_LONGNAME_SUPPORT
10305     flags = LIB$M_FIL_LONG_NAMES;
10306 #endif
10307
10308     tmpsts = lib$find_file
10309         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10310     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
10311     if (!(tmpsts & 1)) {
10312       set_vaxc_errno(tmpsts);
10313       switch (tmpsts) {
10314         case RMS$_PRV:
10315           set_errno(EACCES); break;
10316         case RMS$_DEV:
10317           set_errno(ENODEV); break;
10318         case RMS$_DIR:
10319           set_errno(ENOTDIR); break;
10320         case RMS$_FNF: case RMS$_DNF:
10321           set_errno(ENOENT); break;
10322         default:
10323           set_errno(EVMSERR);
10324       }
10325       Safefree(buff);
10326       return NULL;
10327     }
10328     dd->count++;
10329     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10330     buff[res.dsc$w_length] = '\0';
10331     p = buff + res.dsc$w_length;
10332     while (--p >= buff) if (!isspace(*p)) break;
10333     *p = '\0';
10334     if (!decc_efs_case_preserve) {
10335       for (p = buff; *p; p++) *p = _tolower(*p);
10336     }
10337
10338     /* Skip any directory component and just copy the name. */
10339     sts = vms_split_path
10340        (buff,
10341         &v_spec,
10342         &v_len,
10343         &r_spec,
10344         &r_len,
10345         &d_spec,
10346         &d_len,
10347         &n_spec,
10348         &n_len,
10349         &e_spec,
10350         &e_len,
10351         &vs_spec,
10352         &vs_len);
10353
10354     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10355
10356         /* In Unix report mode, remove the ".dir;1" from the name */
10357         /* if it is a real directory. */
10358         if (decc_filename_unix_report || decc_efs_charset) {
10359             if ((e_len == 4) && (vs_len == 2) && (vs_spec[1] == '1')) {
10360                 if ((toupper(e_spec[1]) == 'D') &&
10361                     (toupper(e_spec[2]) == 'I') &&
10362                     (toupper(e_spec[3]) == 'R')) {
10363                     Stat_t statbuf;
10364                     int ret_sts;
10365
10366                     ret_sts = stat(buff, &statbuf.crtl_stat);
10367                     if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10368                         e_len = 0;
10369                         e_spec[0] = 0;
10370                     }
10371                 }
10372             }
10373         }
10374
10375         /* Drop NULL extensions on UNIX file specification */
10376         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10377             e_len = 0;
10378             e_spec[0] = '\0';
10379         }
10380     }
10381
10382     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
10383     dd->entry.d_name[n_len + e_len] = '\0';
10384     dd->entry.d_namlen = strlen(dd->entry.d_name);
10385
10386     /* Convert the filename to UNIX format if needed */
10387     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10388
10389         /* Translate the encoded characters. */
10390         /* Fixme: Unicode handling could result in embedded 0 characters */
10391         if (strchr(dd->entry.d_name, '^') != NULL) {
10392             char new_name[256];
10393             char * q;
10394             p = dd->entry.d_name;
10395             q = new_name;
10396             while (*p != 0) {
10397                 int inchars_read, outchars_added;
10398                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10399                 p += inchars_read;
10400                 q += outchars_added;
10401                 /* fix-me */
10402                 /* if outchars_added > 1, then this is a wide file specification */
10403                 /* Wide file specifications need to be passed in Perl */
10404                 /* counted strings apparently with a Unicode flag */
10405             }
10406             *q = 0;
10407             strcpy(dd->entry.d_name, new_name);
10408             dd->entry.d_namlen = strlen(dd->entry.d_name);
10409         }
10410     }
10411
10412     dd->entry.vms_verscount = 0;
10413     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10414     Safefree(buff);
10415     return &dd->entry;
10416
10417 }  /* end of readdir() */
10418 /*}}}*/
10419
10420 /*
10421  *  Read the next entry from the directory -- thread-safe version.
10422  */
10423 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10424 int
10425 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10426 {
10427     int retval;
10428
10429     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10430
10431     entry = readdir(dd);
10432     *result = entry;
10433     retval = ( *result == NULL ? errno : 0 );
10434
10435     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10436
10437     return retval;
10438
10439 }  /* end of readdir_r() */
10440 /*}}}*/
10441
10442 /*
10443  *  Return something that can be used in a seekdir later.
10444  */
10445 /*{{{ long telldir(DIR *dd)*/
10446 long
10447 Perl_telldir(DIR *dd)
10448 {
10449     return dd->count;
10450 }
10451 /*}}}*/
10452
10453 /*
10454  *  Return to a spot where we used to be.  Brute force.
10455  */
10456 /*{{{ void seekdir(DIR *dd,long count)*/
10457 void
10458 Perl_seekdir(pTHX_ DIR *dd, long count)
10459 {
10460     int old_flags;
10461
10462     /* If we haven't done anything yet... */
10463     if (dd->count == 0)
10464         return;
10465
10466     /* Remember some state, and clear it. */
10467     old_flags = dd->flags;
10468     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10469     _ckvmssts(lib$find_file_end(&dd->context));
10470     dd->context = 0;
10471
10472     /* The increment is in readdir(). */
10473     for (dd->count = 0; dd->count < count; )
10474         readdir(dd);
10475
10476     dd->flags = old_flags;
10477
10478 }  /* end of seekdir() */
10479 /*}}}*/
10480
10481 /* VMS subprocess management
10482  *
10483  * my_vfork() - just a vfork(), after setting a flag to record that
10484  * the current script is trying a Unix-style fork/exec.
10485  *
10486  * vms_do_aexec() and vms_do_exec() are called in response to the
10487  * perl 'exec' function.  If this follows a vfork call, then they
10488  * call out the regular perl routines in doio.c which do an
10489  * execvp (for those who really want to try this under VMS).
10490  * Otherwise, they do exactly what the perl docs say exec should
10491  * do - terminate the current script and invoke a new command
10492  * (See below for notes on command syntax.)
10493  *
10494  * do_aspawn() and do_spawn() implement the VMS side of the perl
10495  * 'system' function.
10496  *
10497  * Note on command arguments to perl 'exec' and 'system': When handled
10498  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10499  * are concatenated to form a DCL command string.  If the first non-numeric
10500  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10501  * the command string is handed off to DCL directly.  Otherwise,
10502  * the first token of the command is taken as the filespec of an image
10503  * to run.  The filespec is expanded using a default type of '.EXE' and
10504  * the process defaults for device, directory, etc., and if found, the resultant
10505  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10506  * the command string as parameters.  This is perhaps a bit complicated,
10507  * but I hope it will form a happy medium between what VMS folks expect
10508  * from lib$spawn and what Unix folks expect from exec.
10509  */
10510
10511 static int vfork_called;
10512
10513 /*{{{int my_vfork()*/
10514 int
10515 my_vfork()
10516 {
10517   vfork_called++;
10518   return vfork();
10519 }
10520 /*}}}*/
10521
10522
10523 static void
10524 vms_execfree(struct dsc$descriptor_s *vmscmd)
10525 {
10526   if (vmscmd) {
10527       if (vmscmd->dsc$a_pointer) {
10528           PerlMem_free(vmscmd->dsc$a_pointer);
10529       }
10530       PerlMem_free(vmscmd);
10531   }
10532 }
10533
10534 static char *
10535 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10536 {
10537   char *junk, *tmps = NULL;
10538   register size_t cmdlen = 0;
10539   size_t rlen;
10540   register SV **idx;
10541   STRLEN n_a;
10542
10543   idx = mark;
10544   if (really) {
10545     tmps = SvPV(really,rlen);
10546     if (*tmps) {
10547       cmdlen += rlen + 1;
10548       idx++;
10549     }
10550   }
10551
10552   for (idx++; idx <= sp; idx++) {
10553     if (*idx) {
10554       junk = SvPVx(*idx,rlen);
10555       cmdlen += rlen ? rlen + 1 : 0;
10556     }
10557   }
10558   Newx(PL_Cmd, cmdlen+1, char);
10559
10560   if (tmps && *tmps) {
10561     strcpy(PL_Cmd,tmps);
10562     mark++;
10563   }
10564   else *PL_Cmd = '\0';
10565   while (++mark <= sp) {
10566     if (*mark) {
10567       char *s = SvPVx(*mark,n_a);
10568       if (!*s) continue;
10569       if (*PL_Cmd) strcat(PL_Cmd," ");
10570       strcat(PL_Cmd,s);
10571     }
10572   }
10573   return PL_Cmd;
10574
10575 }  /* end of setup_argstr() */
10576
10577
10578 static unsigned long int
10579 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10580                    struct dsc$descriptor_s **pvmscmd)
10581 {
10582   char * vmsspec;
10583   char * resspec;
10584   char image_name[NAM$C_MAXRSS+1];
10585   char image_argv[NAM$C_MAXRSS+1];
10586   $DESCRIPTOR(defdsc,".EXE");
10587   $DESCRIPTOR(defdsc2,".");
10588   struct dsc$descriptor_s resdsc;
10589   struct dsc$descriptor_s *vmscmd;
10590   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10591   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10592   register char *s, *rest, *cp, *wordbreak;
10593   char * cmd;
10594   int cmdlen;
10595   register int isdcl;
10596
10597   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10598   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10599
10600   /* vmsspec is a DCL command buffer, not just a filename */
10601   vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10602   if (vmsspec == NULL)
10603       _ckvmssts_noperl(SS$_INSFMEM);
10604
10605   resspec = PerlMem_malloc(VMS_MAXRSS);
10606   if (resspec == NULL)
10607       _ckvmssts_noperl(SS$_INSFMEM);
10608
10609   /* Make a copy for modification */
10610   cmdlen = strlen(incmd);
10611   cmd = PerlMem_malloc(cmdlen+1);
10612   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10613   strncpy(cmd, incmd, cmdlen);
10614   cmd[cmdlen] = 0;
10615   image_name[0] = 0;
10616   image_argv[0] = 0;
10617
10618   resdsc.dsc$a_pointer = resspec;
10619   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10620   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10621   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10622
10623   vmscmd->dsc$a_pointer = NULL;
10624   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10625   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10626   vmscmd->dsc$w_length = 0;
10627   if (pvmscmd) *pvmscmd = vmscmd;
10628
10629   if (suggest_quote) *suggest_quote = 0;
10630
10631   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10632     PerlMem_free(cmd);
10633     PerlMem_free(vmsspec);
10634     PerlMem_free(resspec);
10635     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10636   }
10637
10638   s = cmd;
10639
10640   while (*s && isspace(*s)) s++;
10641
10642   if (*s == '@' || *s == '$') {
10643     vmsspec[0] = *s;  rest = s + 1;
10644     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10645   }
10646   else { cp = vmsspec; rest = s; }
10647   if (*rest == '.' || *rest == '/') {
10648     char *cp2;
10649     for (cp2 = resspec;
10650          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10651          rest++, cp2++) *cp2 = *rest;
10652     *cp2 = '\0';
10653     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10654       s = vmsspec;
10655
10656       /* When a UNIX spec with no file type is translated to VMS, */
10657       /* A trailing '.' is appended under ODS-5 rules.            */
10658       /* Here we do not want that trailing "." as it prevents     */
10659       /* Looking for a implied ".exe" type. */
10660       if (decc_efs_charset) {
10661           int i;
10662           i = strlen(vmsspec);
10663           if (vmsspec[i-1] == '.') {
10664               vmsspec[i-1] = '\0';
10665           }
10666       }
10667
10668       if (*rest) {
10669         for (cp2 = vmsspec + strlen(vmsspec);
10670              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10671              rest++, cp2++) *cp2 = *rest;
10672         *cp2 = '\0';
10673       }
10674     }
10675   }
10676   /* Intuit whether verb (first word of cmd) is a DCL command:
10677    *   - if first nonspace char is '@', it's a DCL indirection
10678    * otherwise
10679    *   - if verb contains a filespec separator, it's not a DCL command
10680    *   - if it doesn't, caller tells us whether to default to a DCL
10681    *     command, or to a local image unless told it's DCL (by leading '$')
10682    */
10683   if (*s == '@') {
10684       isdcl = 1;
10685       if (suggest_quote) *suggest_quote = 1;
10686   } else {
10687     register char *filespec = strpbrk(s,":<[.;");
10688     rest = wordbreak = strpbrk(s," \"\t/");
10689     if (!wordbreak) wordbreak = s + strlen(s);
10690     if (*s == '$') check_img = 0;
10691     if (filespec && (filespec < wordbreak)) isdcl = 0;
10692     else isdcl = !check_img;
10693   }
10694
10695   if (!isdcl) {
10696     int rsts;
10697     imgdsc.dsc$a_pointer = s;
10698     imgdsc.dsc$w_length = wordbreak - s;
10699     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10700     if (!(retsts&1)) {
10701         _ckvmssts_noperl(lib$find_file_end(&cxt));
10702         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10703       if (!(retsts & 1) && *s == '$') {
10704         _ckvmssts_noperl(lib$find_file_end(&cxt));
10705         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10706         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10707         if (!(retsts&1)) {
10708           _ckvmssts_noperl(lib$find_file_end(&cxt));
10709           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10710         }
10711       }
10712     }
10713     _ckvmssts_noperl(lib$find_file_end(&cxt));
10714
10715     if (retsts & 1) {
10716       FILE *fp;
10717       s = resspec;
10718       while (*s && !isspace(*s)) s++;
10719       *s = '\0';
10720
10721       /* check that it's really not DCL with no file extension */
10722       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10723       if (fp) {
10724         char b[256] = {0,0,0,0};
10725         read(fileno(fp), b, 256);
10726         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10727         if (isdcl) {
10728           int shebang_len;
10729
10730           /* Check for script */
10731           shebang_len = 0;
10732           if ((b[0] == '#') && (b[1] == '!'))
10733              shebang_len = 2;
10734 #ifdef ALTERNATE_SHEBANG
10735           else {
10736             shebang_len = strlen(ALTERNATE_SHEBANG);
10737             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10738               char * perlstr;
10739                 perlstr = strstr("perl",b);
10740                 if (perlstr == NULL)
10741                   shebang_len = 0;
10742             }
10743             else
10744               shebang_len = 0;
10745           }
10746 #endif
10747
10748           if (shebang_len > 0) {
10749           int i;
10750           int j;
10751           char tmpspec[NAM$C_MAXRSS + 1];
10752
10753             i = shebang_len;
10754              /* Image is following after white space */
10755             /*--------------------------------------*/
10756             while (isprint(b[i]) && isspace(b[i]))
10757                 i++;
10758
10759             j = 0;
10760             while (isprint(b[i]) && !isspace(b[i])) {
10761                 tmpspec[j++] = b[i++];
10762                 if (j >= NAM$C_MAXRSS)
10763                    break;
10764             }
10765             tmpspec[j] = '\0';
10766
10767              /* There may be some default parameters to the image */
10768             /*---------------------------------------------------*/
10769             j = 0;
10770             while (isprint(b[i])) {
10771                 image_argv[j++] = b[i++];
10772                 if (j >= NAM$C_MAXRSS)
10773                    break;
10774             }
10775             while ((j > 0) && !isprint(image_argv[j-1]))
10776                 j--;
10777             image_argv[j] = 0;
10778
10779             /* It will need to be converted to VMS format and validated */
10780             if (tmpspec[0] != '\0') {
10781               char * iname;
10782
10783                /* Try to find the exact program requested to be run */
10784               /*---------------------------------------------------*/
10785               iname = int_rmsexpand
10786                  (tmpspec, image_name, ".exe",
10787                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10788               if (iname != NULL) {
10789                 if (cando_by_name_int
10790                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10791                   /* MCR prefix needed */
10792                   isdcl = 0;
10793                 }
10794                 else {
10795                    /* Try again with a null type */
10796                   /*----------------------------*/
10797                   iname = int_rmsexpand
10798                     (tmpspec, image_name, ".",
10799                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10800                   if (iname != NULL) {
10801                     if (cando_by_name_int
10802                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10803                       /* MCR prefix needed */
10804                       isdcl = 0;
10805                     }
10806                   }
10807                 }
10808
10809                  /* Did we find the image to run the script? */
10810                 /*------------------------------------------*/
10811                 if (isdcl) {
10812                   char *tchr;
10813
10814                    /* Assume DCL or foreign command exists */
10815                   /*--------------------------------------*/
10816                   tchr = strrchr(tmpspec, '/');
10817                   if (tchr != NULL) {
10818                     tchr++;
10819                   }
10820                   else {
10821                     tchr = tmpspec;
10822                   }
10823                   strcpy(image_name, tchr);
10824                 }
10825               }
10826             }
10827           }
10828         }
10829         fclose(fp);
10830       }
10831       if (check_img && isdcl) {
10832           PerlMem_free(cmd);
10833           PerlMem_free(resspec);
10834           PerlMem_free(vmsspec);
10835           return RMS$_FNF;
10836       }
10837
10838       if (cando_by_name(S_IXUSR,0,resspec)) {
10839         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10840         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10841         if (!isdcl) {
10842             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10843             if (image_name[0] != 0) {
10844                 strcat(vmscmd->dsc$a_pointer, image_name);
10845                 strcat(vmscmd->dsc$a_pointer, " ");
10846             }
10847         } else if (image_name[0] != 0) {
10848             strcpy(vmscmd->dsc$a_pointer, image_name);
10849             strcat(vmscmd->dsc$a_pointer, " ");
10850         } else {
10851             strcpy(vmscmd->dsc$a_pointer,"@");
10852         }
10853         if (suggest_quote) *suggest_quote = 1;
10854
10855         /* If there is an image name, use original command */
10856         if (image_name[0] == 0)
10857             strcat(vmscmd->dsc$a_pointer,resspec);
10858         else {
10859             rest = cmd;
10860             while (*rest && isspace(*rest)) rest++;
10861         }
10862
10863         if (image_argv[0] != 0) {
10864           strcat(vmscmd->dsc$a_pointer,image_argv);
10865           strcat(vmscmd->dsc$a_pointer, " ");
10866         }
10867         if (rest) {
10868            int rest_len;
10869            int vmscmd_len;
10870
10871            rest_len = strlen(rest);
10872            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10873            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10874               strcat(vmscmd->dsc$a_pointer,rest);
10875            else
10876              retsts = CLI$_BUFOVF;
10877         }
10878         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10879         PerlMem_free(cmd);
10880         PerlMem_free(vmsspec);
10881         PerlMem_free(resspec);
10882         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10883       }
10884       else
10885         retsts = RMS$_PRV;
10886     }
10887   }
10888   /* It's either a DCL command or we couldn't find a suitable image */
10889   vmscmd->dsc$w_length = strlen(cmd);
10890
10891   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10892   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10893   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10894
10895   PerlMem_free(cmd);
10896   PerlMem_free(resspec);
10897   PerlMem_free(vmsspec);
10898
10899   /* check if it's a symbol (for quoting purposes) */
10900   if (suggest_quote && !*suggest_quote) {
10901     int iss;
10902     char equiv[LNM$C_NAMLENGTH];
10903     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10904     eqvdsc.dsc$a_pointer = equiv;
10905
10906     iss = lib$get_symbol(vmscmd,&eqvdsc);
10907     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10908   }
10909   if (!(retsts & 1)) {
10910     /* just hand off status values likely to be due to user error */
10911     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10912         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10913        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10914     else { _ckvmssts_noperl(retsts); }
10915   }
10916
10917   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10918
10919 }  /* end of setup_cmddsc() */
10920
10921
10922 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10923 bool
10924 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10925 {
10926 bool exec_sts;
10927 char * cmd;
10928
10929   if (sp > mark) {
10930     if (vfork_called) {           /* this follows a vfork - act Unixish */
10931       vfork_called--;
10932       if (vfork_called < 0) {
10933         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10934         vfork_called = 0;
10935       }
10936       else return do_aexec(really,mark,sp);
10937     }
10938                                            /* no vfork - act VMSish */
10939     cmd = setup_argstr(aTHX_ really,mark,sp);
10940     exec_sts = vms_do_exec(cmd);
10941     Safefree(cmd);  /* Clean up from setup_argstr() */
10942     return exec_sts;
10943   }
10944
10945   return FALSE;
10946 }  /* end of vms_do_aexec() */
10947 /*}}}*/
10948
10949 /* {{{bool vms_do_exec(char *cmd) */
10950 bool
10951 Perl_vms_do_exec(pTHX_ const char *cmd)
10952 {
10953   struct dsc$descriptor_s *vmscmd;
10954
10955   if (vfork_called) {             /* this follows a vfork - act Unixish */
10956     vfork_called--;
10957     if (vfork_called < 0) {
10958       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10959       vfork_called = 0;
10960     }
10961     else return do_exec(cmd);
10962   }
10963
10964   {                               /* no vfork - act VMSish */
10965     unsigned long int retsts;
10966
10967     TAINT_ENV();
10968     TAINT_PROPER("exec");
10969     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10970       retsts = lib$do_command(vmscmd);
10971
10972     switch (retsts) {
10973       case RMS$_FNF: case RMS$_DNF:
10974         set_errno(ENOENT); break;
10975       case RMS$_DIR:
10976         set_errno(ENOTDIR); break;
10977       case RMS$_DEV:
10978         set_errno(ENODEV); break;
10979       case RMS$_PRV:
10980         set_errno(EACCES); break;
10981       case RMS$_SYN:
10982         set_errno(EINVAL); break;
10983       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10984         set_errno(E2BIG); break;
10985       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10986         _ckvmssts_noperl(retsts); /* fall through */
10987       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10988         set_errno(EVMSERR);
10989     }
10990     set_vaxc_errno(retsts);
10991     if (ckWARN(WARN_EXEC)) {
10992       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10993              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10994     }
10995     vms_execfree(vmscmd);
10996   }
10997
10998   return FALSE;
10999
11000 }  /* end of vms_do_exec() */
11001 /*}}}*/
11002
11003 int do_spawn2(pTHX_ const char *, int);
11004
11005 int
11006 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
11007 {
11008 unsigned long int sts;
11009 char * cmd;
11010 int flags = 0;
11011
11012   if (sp > mark) {
11013
11014     /* We'll copy the (undocumented?) Win32 behavior and allow a
11015      * numeric first argument.  But the only value we'll support
11016      * through do_aspawn is a value of 1, which means spawn without
11017      * waiting for completion -- other values are ignored.
11018      */
11019     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
11020         ++mark;
11021         flags = SvIVx(*mark);
11022     }
11023
11024     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
11025         flags = CLI$M_NOWAIT;
11026     else
11027         flags = 0;
11028
11029     cmd = setup_argstr(aTHX_ really, mark, sp);
11030     sts = do_spawn2(aTHX_ cmd, flags);
11031     /* pp_sys will clean up cmd */
11032     return sts;
11033   }
11034   return SS$_ABORT;
11035 }  /* end of do_aspawn() */
11036 /*}}}*/
11037
11038
11039 /* {{{int do_spawn(char* cmd) */
11040 int
11041 Perl_do_spawn(pTHX_ char* cmd)
11042 {
11043     PERL_ARGS_ASSERT_DO_SPAWN;
11044
11045     return do_spawn2(aTHX_ cmd, 0);
11046 }
11047 /*}}}*/
11048
11049 /* {{{int do_spawn_nowait(char* cmd) */
11050 int
11051 Perl_do_spawn_nowait(pTHX_ char* cmd)
11052 {
11053     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11054
11055     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11056 }
11057 /*}}}*/
11058
11059 /* {{{int do_spawn2(char *cmd) */
11060 int
11061 do_spawn2(pTHX_ const char *cmd, int flags)
11062 {
11063   unsigned long int sts, substs;
11064
11065   /* The caller of this routine expects to Safefree(PL_Cmd) */
11066   Newx(PL_Cmd,10,char);
11067
11068   TAINT_ENV();
11069   TAINT_PROPER("spawn");
11070   if (!cmd || !*cmd) {
11071     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11072     if (!(sts & 1)) {
11073       switch (sts) {
11074         case RMS$_FNF:  case RMS$_DNF:
11075           set_errno(ENOENT); break;
11076         case RMS$_DIR:
11077           set_errno(ENOTDIR); break;
11078         case RMS$_DEV:
11079           set_errno(ENODEV); break;
11080         case RMS$_PRV:
11081           set_errno(EACCES); break;
11082         case RMS$_SYN:
11083           set_errno(EINVAL); break;
11084         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11085           set_errno(E2BIG); break;
11086         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11087           _ckvmssts_noperl(sts); /* fall through */
11088         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11089           set_errno(EVMSERR);
11090       }
11091       set_vaxc_errno(sts);
11092       if (ckWARN(WARN_EXEC)) {
11093         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11094                     Strerror(errno));
11095       }
11096     }
11097     sts = substs;
11098   }
11099   else {
11100     char mode[3];
11101     PerlIO * fp;
11102     if (flags & CLI$M_NOWAIT)
11103         strcpy(mode, "n");
11104     else
11105         strcpy(mode, "nW");
11106
11107     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11108     if (fp != NULL)
11109       my_pclose(fp);
11110     /* sts will be the pid in the nowait case */
11111   }
11112   return sts;
11113 }  /* end of do_spawn2() */
11114 /*}}}*/
11115
11116
11117 static unsigned int *sockflags, sockflagsize;
11118
11119 /*
11120  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11121  * routines found in some versions of the CRTL can't deal with sockets.
11122  * We don't shim the other file open routines since a socket isn't
11123  * likely to be opened by a name.
11124  */
11125 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11126 FILE *my_fdopen(int fd, const char *mode)
11127 {
11128   FILE *fp = fdopen(fd, mode);
11129
11130   if (fp) {
11131     unsigned int fdoff = fd / sizeof(unsigned int);
11132     Stat_t sbuf; /* native stat; we don't need flex_stat */
11133     if (!sockflagsize || fdoff > sockflagsize) {
11134       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11135       else           Newx  (sockflags,fdoff+2,unsigned int);
11136       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11137       sockflagsize = fdoff + 2;
11138     }
11139     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11140       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11141   }
11142   return fp;
11143
11144 }
11145 /*}}}*/
11146
11147
11148 /*
11149  * Clear the corresponding bit when the (possibly) socket stream is closed.
11150  * There still a small hole: we miss an implicit close which might occur
11151  * via freopen().  >> Todo
11152  */
11153 /*{{{ int my_fclose(FILE *fp)*/
11154 int my_fclose(FILE *fp) {
11155   if (fp) {
11156     unsigned int fd = fileno(fp);
11157     unsigned int fdoff = fd / sizeof(unsigned int);
11158
11159     if (sockflagsize && fdoff < sockflagsize)
11160       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11161   }
11162   return fclose(fp);
11163 }
11164 /*}}}*/
11165
11166
11167 /*
11168  * A simple fwrite replacement which outputs itmsz*nitm chars without
11169  * introducing record boundaries every itmsz chars.
11170  * We are using fputs, which depends on a terminating null.  We may
11171  * well be writing binary data, so we need to accommodate not only
11172  * data with nulls sprinkled in the middle but also data with no null
11173  * byte at the end.
11174  */
11175 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11176 int
11177 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11178 {
11179   register char *cp, *end, *cpd, *data;
11180   register unsigned int fd = fileno(dest);
11181   register unsigned int fdoff = fd / sizeof(unsigned int);
11182   int retval;
11183   int bufsize = itmsz * nitm + 1;
11184
11185   if (fdoff < sockflagsize &&
11186       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11187     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11188     return nitm;
11189   }
11190
11191   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11192   memcpy( data, src, itmsz*nitm );
11193   data[itmsz*nitm] = '\0';
11194
11195   end = data + itmsz * nitm;
11196   retval = (int) nitm; /* on success return # items written */
11197
11198   cpd = data;
11199   while (cpd <= end) {
11200     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11201     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11202     if (cp < end)
11203       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11204     cpd = cp + 1;
11205   }
11206
11207   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11208   return retval;
11209
11210 }  /* end of my_fwrite() */
11211 /*}}}*/
11212
11213 /*{{{ int my_flush(FILE *fp)*/
11214 int
11215 Perl_my_flush(pTHX_ FILE *fp)
11216 {
11217     int res;
11218     if ((res = fflush(fp)) == 0 && fp) {
11219 #ifdef VMS_DO_SOCKETS
11220         Stat_t s;
11221         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11222 #endif
11223             res = fsync(fileno(fp));
11224     }
11225 /*
11226  * If the flush succeeded but set end-of-file, we need to clear
11227  * the error because our caller may check ferror().  BTW, this
11228  * probably means we just flushed an empty file.
11229  */
11230     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11231
11232     return res;
11233 }
11234 /*}}}*/
11235
11236 /*
11237  * Here are replacements for the following Unix routines in the VMS environment:
11238  *      getpwuid    Get information for a particular UIC or UID
11239  *      getpwnam    Get information for a named user
11240  *      getpwent    Get information for each user in the rights database
11241  *      setpwent    Reset search to the start of the rights database
11242  *      endpwent    Finish searching for users in the rights database
11243  *
11244  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11245  * (defined in pwd.h), which contains the following fields:-
11246  *      struct passwd {
11247  *              char        *pw_name;    Username (in lower case)
11248  *              char        *pw_passwd;  Hashed password
11249  *              unsigned int pw_uid;     UIC
11250  *              unsigned int pw_gid;     UIC group  number
11251  *              char        *pw_unixdir; Default device/directory (VMS-style)
11252  *              char        *pw_gecos;   Owner name
11253  *              char        *pw_dir;     Default device/directory (Unix-style)
11254  *              char        *pw_shell;   Default CLI name (eg. DCL)
11255  *      };
11256  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11257  *
11258  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11259  * not the UIC member number (eg. what's returned by getuid()),
11260  * getpwuid() can accept either as input (if uid is specified, the caller's
11261  * UIC group is used), though it won't recognise gid=0.
11262  *
11263  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11264  * information about other users in your group or in other groups, respectively.
11265  * If the required privilege is not available, then these routines fill only
11266  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11267  * string).
11268  *
11269  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11270  */
11271
11272 /* sizes of various UAF record fields */
11273 #define UAI$S_USERNAME 12
11274 #define UAI$S_IDENT    31
11275 #define UAI$S_OWNER    31
11276 #define UAI$S_DEFDEV   31
11277 #define UAI$S_DEFDIR   63
11278 #define UAI$S_DEFCLI   31
11279 #define UAI$S_PWD       8
11280
11281 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11282                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11283                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11284
11285 static char __empty[]= "";
11286 static struct passwd __passwd_empty=
11287     {(char *) __empty, (char *) __empty, 0, 0,
11288      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11289 static int contxt= 0;
11290 static struct passwd __pwdcache;
11291 static char __pw_namecache[UAI$S_IDENT+1];
11292
11293 /*
11294  * This routine does most of the work extracting the user information.
11295  */
11296 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11297 {
11298     static struct {
11299         unsigned char length;
11300         char pw_gecos[UAI$S_OWNER+1];
11301     } owner;
11302     static union uicdef uic;
11303     static struct {
11304         unsigned char length;
11305         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11306     } defdev;
11307     static struct {
11308         unsigned char length;
11309         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11310     } defdir;
11311     static struct {
11312         unsigned char length;
11313         char pw_shell[UAI$S_DEFCLI+1];
11314     } defcli;
11315     static char pw_passwd[UAI$S_PWD+1];
11316
11317     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11318     struct dsc$descriptor_s name_desc;
11319     unsigned long int sts;
11320
11321     static struct itmlst_3 itmlst[]= {
11322         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11323         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11324         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11325         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11326         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11327         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11328         {0,                0,           NULL,    NULL}};
11329
11330     name_desc.dsc$w_length=  strlen(name);
11331     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11332     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11333     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11334
11335 /*  Note that sys$getuai returns many fields as counted strings. */
11336     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11337     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11338       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11339     }
11340     else { _ckvmssts(sts); }
11341     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11342
11343     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11344     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11345     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11346     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11347     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11348     owner.pw_gecos[lowner]=            '\0';
11349     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11350     defcli.pw_shell[ldefcli]=          '\0';
11351     if (valid_uic(uic)) {
11352         pwd->pw_uid= uic.uic$l_uic;
11353         pwd->pw_gid= uic.uic$v_group;
11354     }
11355     else
11356       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11357     pwd->pw_passwd=  pw_passwd;
11358     pwd->pw_gecos=   owner.pw_gecos;
11359     pwd->pw_dir=     defdev.pw_dir;
11360     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11361     pwd->pw_shell=   defcli.pw_shell;
11362     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11363         int ldir;
11364         ldir= strlen(pwd->pw_unixdir) - 1;
11365         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11366     }
11367     else
11368         strcpy(pwd->pw_unixdir, pwd->pw_dir);
11369     if (!decc_efs_case_preserve)
11370         __mystrtolower(pwd->pw_unixdir);
11371     return 1;
11372 }
11373
11374 /*
11375  * Get information for a named user.
11376 */
11377 /*{{{struct passwd *getpwnam(char *name)*/
11378 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11379 {
11380     struct dsc$descriptor_s name_desc;
11381     union uicdef uic;
11382     unsigned long int status, sts;
11383
11384     __pwdcache = __passwd_empty;
11385     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11386       /* We still may be able to determine pw_uid and pw_gid */
11387       name_desc.dsc$w_length=  strlen(name);
11388       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11389       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11390       name_desc.dsc$a_pointer= (char *) name;
11391       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11392         __pwdcache.pw_uid= uic.uic$l_uic;
11393         __pwdcache.pw_gid= uic.uic$v_group;
11394       }
11395       else {
11396         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11397           set_vaxc_errno(sts);
11398           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11399           return NULL;
11400         }
11401         else { _ckvmssts(sts); }
11402       }
11403     }
11404     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
11405     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
11406     __pwdcache.pw_name= __pw_namecache;
11407     return &__pwdcache;
11408 }  /* end of my_getpwnam() */
11409 /*}}}*/
11410
11411 /*
11412  * Get information for a particular UIC or UID.
11413  * Called by my_getpwent with uid=-1 to list all users.
11414 */
11415 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11416 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11417 {
11418     const $DESCRIPTOR(name_desc,__pw_namecache);
11419     unsigned short lname;
11420     union uicdef uic;
11421     unsigned long int status;
11422
11423     if (uid == (unsigned int) -1) {
11424       do {
11425         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11426         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11427           set_vaxc_errno(status);
11428           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11429           my_endpwent();
11430           return NULL;
11431         }
11432         else { _ckvmssts(status); }
11433       } while (!valid_uic (uic));
11434     }
11435     else {
11436       uic.uic$l_uic= uid;
11437       if (!uic.uic$v_group)
11438         uic.uic$v_group= PerlProc_getgid();
11439       if (valid_uic(uic))
11440         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11441       else status = SS$_IVIDENT;
11442       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11443           status == RMS$_PRV) {
11444         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11445         return NULL;
11446       }
11447       else { _ckvmssts(status); }
11448     }
11449     __pw_namecache[lname]= '\0';
11450     __mystrtolower(__pw_namecache);
11451
11452     __pwdcache = __passwd_empty;
11453     __pwdcache.pw_name = __pw_namecache;
11454
11455 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11456     The identifier's value is usually the UIC, but it doesn't have to be,
11457     so if we can, we let fillpasswd update this. */
11458     __pwdcache.pw_uid =  uic.uic$l_uic;
11459     __pwdcache.pw_gid =  uic.uic$v_group;
11460
11461     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11462     return &__pwdcache;
11463
11464 }  /* end of my_getpwuid() */
11465 /*}}}*/
11466
11467 /*
11468  * Get information for next user.
11469 */
11470 /*{{{struct passwd *my_getpwent()*/
11471 struct passwd *Perl_my_getpwent(pTHX)
11472 {
11473     return (my_getpwuid((unsigned int) -1));
11474 }
11475 /*}}}*/
11476
11477 /*
11478  * Finish searching rights database for users.
11479 */
11480 /*{{{void my_endpwent()*/
11481 void Perl_my_endpwent(pTHX)
11482 {
11483     if (contxt) {
11484       _ckvmssts(sys$finish_rdb(&contxt));
11485       contxt= 0;
11486     }
11487 }
11488 /*}}}*/
11489
11490 #ifdef HOMEGROWN_POSIX_SIGNALS
11491   /* Signal handling routines, pulled into the core from POSIX.xs.
11492    *
11493    * We need these for threads, so they've been rolled into the core,
11494    * rather than left in POSIX.xs.
11495    *
11496    * (DRS, Oct 23, 1997)
11497    */
11498
11499   /* sigset_t is atomic under VMS, so these routines are easy */
11500 /*{{{int my_sigemptyset(sigset_t *) */
11501 int my_sigemptyset(sigset_t *set) {
11502     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11503     *set = 0; return 0;
11504 }
11505 /*}}}*/
11506
11507
11508 /*{{{int my_sigfillset(sigset_t *)*/
11509 int my_sigfillset(sigset_t *set) {
11510     int i;
11511     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11512     for (i = 0; i < NSIG; i++) *set |= (1 << i);
11513     return 0;
11514 }
11515 /*}}}*/
11516
11517
11518 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
11519 int my_sigaddset(sigset_t *set, int sig) {
11520     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11521     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11522     *set |= (1 << (sig - 1));
11523     return 0;
11524 }
11525 /*}}}*/
11526
11527
11528 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
11529 int my_sigdelset(sigset_t *set, int sig) {
11530     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11531     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11532     *set &= ~(1 << (sig - 1));
11533     return 0;
11534 }
11535 /*}}}*/
11536
11537
11538 /*{{{int my_sigismember(sigset_t *set, int sig)*/
11539 int my_sigismember(sigset_t *set, int sig) {
11540     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11541     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11542     return *set & (1 << (sig - 1));
11543 }
11544 /*}}}*/
11545
11546
11547 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
11548 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
11549     sigset_t tempmask;
11550
11551     /* If set and oset are both null, then things are badly wrong. Bail out. */
11552     if ((oset == NULL) && (set == NULL)) {
11553       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
11554       return -1;
11555     }
11556
11557     /* If set's null, then we're just handling a fetch. */
11558     if (set == NULL) {
11559         tempmask = sigblock(0);
11560     }
11561     else {
11562       switch (how) {
11563       case SIG_SETMASK:
11564         tempmask = sigsetmask(*set);
11565         break;
11566       case SIG_BLOCK:
11567         tempmask = sigblock(*set);
11568         break;
11569       case SIG_UNBLOCK:
11570         tempmask = sigblock(0);
11571         sigsetmask(*oset & ~tempmask);
11572         break;
11573       default:
11574         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11575         return -1;
11576       }
11577     }
11578
11579     /* Did they pass us an oset? If so, stick our holding mask into it */
11580     if (oset)
11581       *oset = tempmask;
11582
11583     return 0;
11584 }
11585 /*}}}*/
11586 #endif  /* HOMEGROWN_POSIX_SIGNALS */
11587
11588
11589 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11590  * my_utime(), and flex_stat(), all of which operate on UTC unless
11591  * VMSISH_TIMES is true.
11592  */
11593 /* method used to handle UTC conversions:
11594  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11595  */
11596 static int gmtime_emulation_type;
11597 /* number of secs to add to UTC POSIX-style time to get local time */
11598 static long int utc_offset_secs;
11599
11600 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11601  * in vmsish.h.  #undef them here so we can call the CRTL routines
11602  * directly.
11603  */
11604 #undef gmtime
11605 #undef localtime
11606 #undef time
11607
11608
11609 /*
11610  * DEC C previous to 6.0 corrupts the behavior of the /prefix
11611  * qualifier with the extern prefix pragma.  This provisional
11612  * hack circumvents this prefix pragma problem in previous
11613  * precompilers.
11614  */
11615 #if defined(__VMS_VER) && __VMS_VER >= 70000000
11616 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11617 #    pragma __extern_prefix save
11618 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
11619 #    define gmtime decc$__utctz_gmtime
11620 #    define localtime decc$__utctz_localtime
11621 #    define time decc$__utc_time
11622 #    pragma __extern_prefix restore
11623
11624      struct tm *gmtime(), *localtime();
11625
11626 #  endif
11627 #endif
11628
11629
11630 static time_t toutc_dst(time_t loc) {
11631   struct tm *rsltmp;
11632
11633   if ((rsltmp = localtime(&loc)) == NULL) return -1;
11634   loc -= utc_offset_secs;
11635   if (rsltmp->tm_isdst) loc -= 3600;
11636   return loc;
11637 }
11638 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11639        ((gmtime_emulation_type || my_time(NULL)), \
11640        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11641        ((secs) - utc_offset_secs))))
11642
11643 static time_t toloc_dst(time_t utc) {
11644   struct tm *rsltmp;
11645
11646   utc += utc_offset_secs;
11647   if ((rsltmp = localtime(&utc)) == NULL) return -1;
11648   if (rsltmp->tm_isdst) utc += 3600;
11649   return utc;
11650 }
11651 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11652        ((gmtime_emulation_type || my_time(NULL)), \
11653        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11654        ((secs) + utc_offset_secs))))
11655
11656 #ifndef RTL_USES_UTC
11657 /*
11658
11659     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
11660         DST starts on 1st sun of april      at 02:00  std time
11661             ends on last sun of october     at 02:00  dst time
11662     see the UCX management command reference, SET CONFIG TIMEZONE
11663     for formatting info.
11664
11665     No, it's not as general as it should be, but then again, NOTHING
11666     will handle UK times in a sensible way.
11667 */
11668
11669
11670 /*
11671     parse the DST start/end info:
11672     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11673 */
11674
11675 static char *
11676 tz_parse_startend(char *s, struct tm *w, int *past)
11677 {
11678     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11679     int ly, dozjd, d, m, n, hour, min, sec, j, k;
11680     time_t g;
11681
11682     if (!s)    return 0;
11683     if (!w) return 0;
11684     if (!past) return 0;
11685
11686     ly = 0;
11687     if (w->tm_year % 4        == 0) ly = 1;
11688     if (w->tm_year % 100      == 0) ly = 0;
11689     if (w->tm_year+1900 % 400 == 0) ly = 1;
11690     if (ly) dinm[1]++;
11691
11692     dozjd = isdigit(*s);
11693     if (*s == 'J' || *s == 'j' || dozjd) {
11694         if (!dozjd && !isdigit(*++s)) return 0;
11695         d = *s++ - '0';
11696         if (isdigit(*s)) {
11697             d = d*10 + *s++ - '0';
11698             if (isdigit(*s)) {
11699                 d = d*10 + *s++ - '0';
11700             }
11701         }
11702         if (d == 0) return 0;
11703         if (d > 366) return 0;
11704         d--;
11705         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
11706         g = d * 86400;
11707         dozjd = 1;
11708     } else if (*s == 'M' || *s == 'm') {
11709         if (!isdigit(*++s)) return 0;
11710         m = *s++ - '0';
11711         if (isdigit(*s)) m = 10*m + *s++ - '0';
11712         if (*s != '.') return 0;
11713         if (!isdigit(*++s)) return 0;
11714         n = *s++ - '0';
11715         if (n < 1 || n > 5) return 0;
11716         if (*s != '.') return 0;
11717         if (!isdigit(*++s)) return 0;
11718         d = *s++ - '0';
11719         if (d > 6) return 0;
11720     }
11721
11722     if (*s == '/') {
11723         if (!isdigit(*++s)) return 0;
11724         hour = *s++ - '0';
11725         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11726         if (*s == ':') {
11727             if (!isdigit(*++s)) return 0;
11728             min = *s++ - '0';
11729             if (isdigit(*s)) min = 10*min + *s++ - '0';
11730             if (*s == ':') {
11731                 if (!isdigit(*++s)) return 0;
11732                 sec = *s++ - '0';
11733                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11734             }
11735         }
11736     } else {
11737         hour = 2;
11738         min = 0;
11739         sec = 0;
11740     }
11741
11742     if (dozjd) {
11743         if (w->tm_yday < d) goto before;
11744         if (w->tm_yday > d) goto after;
11745     } else {
11746         if (w->tm_mon+1 < m) goto before;
11747         if (w->tm_mon+1 > m) goto after;
11748
11749         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
11750         k = d - j; /* mday of first d */
11751         if (k <= 0) k += 7;
11752         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
11753         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11754         if (w->tm_mday < k) goto before;
11755         if (w->tm_mday > k) goto after;
11756     }
11757
11758     if (w->tm_hour < hour) goto before;
11759     if (w->tm_hour > hour) goto after;
11760     if (w->tm_min  < min)  goto before;
11761     if (w->tm_min  > min)  goto after;
11762     if (w->tm_sec  < sec)  goto before;
11763     goto after;
11764
11765 before:
11766     *past = 0;
11767     return s;
11768 after:
11769     *past = 1;
11770     return s;
11771 }
11772
11773
11774
11775
11776 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
11777
11778 static char *
11779 tz_parse_offset(char *s, int *offset)
11780 {
11781     int hour = 0, min = 0, sec = 0;
11782     int neg = 0;
11783     if (!s) return 0;
11784     if (!offset) return 0;
11785
11786     if (*s == '-') {neg++; s++;}
11787     if (*s == '+') s++;
11788     if (!isdigit(*s)) return 0;
11789     hour = *s++ - '0';
11790     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11791     if (hour > 24) return 0;
11792     if (*s == ':') {
11793         if (!isdigit(*++s)) return 0;
11794         min = *s++ - '0';
11795         if (isdigit(*s)) min = min*10 + (*s++ - '0');
11796         if (min > 59) return 0;
11797         if (*s == ':') {
11798             if (!isdigit(*++s)) return 0;
11799             sec = *s++ - '0';
11800             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11801             if (sec > 59) return 0;
11802         }
11803     }
11804
11805     *offset = (hour*60+min)*60 + sec;
11806     if (neg) *offset = -*offset;
11807     return s;
11808 }
11809
11810 /*
11811     input time is w, whatever type of time the CRTL localtime() uses.
11812     sets dst, the zone, and the gmtoff (seconds)
11813
11814     caches the value of TZ and UCX$TZ env variables; note that
11815     my_setenv looks for these and sets a flag if they're changed
11816     for efficiency.
11817
11818     We have to watch out for the "australian" case (dst starts in
11819     october, ends in april)...flagged by "reverse" and checked by
11820     scanning through the months of the previous year.
11821
11822 */
11823
11824 static int
11825 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11826 {
11827     time_t when;
11828     struct tm *w2;
11829     char *s,*s2;
11830     char *dstzone, *tz, *s_start, *s_end;
11831     int std_off, dst_off, isdst;
11832     int y, dststart, dstend;
11833     static char envtz[1025];  /* longer than any logical, symbol, ... */
11834     static char ucxtz[1025];
11835     static char reversed = 0;
11836
11837     if (!w) return 0;
11838
11839     if (tz_updated) {
11840         tz_updated = 0;
11841         reversed = -1;  /* flag need to check  */
11842         envtz[0] = ucxtz[0] = '\0';
11843         tz = my_getenv("TZ",0);
11844         if (tz) strcpy(envtz, tz);
11845         tz = my_getenv("UCX$TZ",0);
11846         if (tz) strcpy(ucxtz, tz);
11847         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
11848     }
11849     tz = envtz;
11850     if (!*tz) tz = ucxtz;
11851
11852     s = tz;
11853     while (isalpha(*s)) s++;
11854     s = tz_parse_offset(s, &std_off);
11855     if (!s) return 0;
11856     if (!*s) {                  /* no DST, hurray we're done! */
11857         isdst = 0;
11858         goto done;
11859     }
11860
11861     dstzone = s;
11862     while (isalpha(*s)) s++;
11863     s2 = tz_parse_offset(s, &dst_off);
11864     if (s2) {
11865         s = s2;
11866     } else {
11867         dst_off = std_off - 3600;
11868     }
11869
11870     if (!*s) {      /* default dst start/end?? */
11871         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
11872             s = strchr(ucxtz,',');
11873         }
11874         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
11875     }
11876     if (*s != ',') return 0;
11877
11878     when = *w;
11879     when = _toutc(when);      /* convert to utc */
11880     when = when - std_off;    /* convert to pseudolocal time*/
11881
11882     w2 = localtime(&when);
11883     y = w2->tm_year;
11884     s_start = s+1;
11885     s = tz_parse_startend(s_start,w2,&dststart);
11886     if (!s) return 0;
11887     if (*s != ',') return 0;
11888
11889     when = *w;
11890     when = _toutc(when);      /* convert to utc */
11891     when = when - dst_off;    /* convert to pseudolocal time*/
11892     w2 = localtime(&when);
11893     if (w2->tm_year != y) {   /* spans a year, just check one time */
11894         when += dst_off - std_off;
11895         w2 = localtime(&when);
11896     }
11897     s_end = s+1;
11898     s = tz_parse_startend(s_end,w2,&dstend);
11899     if (!s) return 0;
11900
11901     if (reversed == -1) {  /* need to check if start later than end */
11902         int j, ds, de;
11903
11904         when = *w;
11905         if (when < 2*365*86400) {
11906             when += 2*365*86400;
11907         } else {
11908             when -= 365*86400;
11909         }
11910         w2 =localtime(&when);
11911         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
11912
11913         for (j = 0; j < 12; j++) {
11914             w2 =localtime(&when);
11915             tz_parse_startend(s_start,w2,&ds);
11916             tz_parse_startend(s_end,w2,&de);
11917             if (ds != de) break;
11918             when += 30*86400;
11919         }
11920         reversed = 0;
11921         if (de && !ds) reversed = 1;
11922     }
11923
11924     isdst = dststart && !dstend;
11925     if (reversed) isdst = dststart  || !dstend;
11926
11927 done:
11928     if (dst)    *dst = isdst;
11929     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11930     if (isdst)  tz = dstzone;
11931     if (zone) {
11932         while(isalpha(*tz))  *zone++ = *tz++;
11933         *zone = '\0';
11934     }
11935     return 1;
11936 }
11937
11938 #endif /* !RTL_USES_UTC */
11939
11940 /* my_time(), my_localtime(), my_gmtime()
11941  * By default traffic in UTC time values, using CRTL gmtime() or
11942  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11943  * Note: We need to use these functions even when the CRTL has working
11944  * UTC support, since they also handle C<use vmsish qw(times);>
11945  *
11946  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11947  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11948  */
11949
11950 /*{{{time_t my_time(time_t *timep)*/
11951 time_t Perl_my_time(pTHX_ time_t *timep)
11952 {
11953   time_t when;
11954   struct tm *tm_p;
11955
11956   if (gmtime_emulation_type == 0) {
11957     int dstnow;
11958     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11959                               /* results of calls to gmtime() and localtime() */
11960                               /* for same &base */
11961
11962     gmtime_emulation_type++;
11963     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11964       char off[LNM$C_NAMLENGTH+1];;
11965
11966       gmtime_emulation_type++;
11967       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11968         gmtime_emulation_type++;
11969         utc_offset_secs = 0;
11970         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11971       }
11972       else { utc_offset_secs = atol(off); }
11973     }
11974     else { /* We've got a working gmtime() */
11975       struct tm gmt, local;
11976
11977       gmt = *tm_p;
11978       tm_p = localtime(&base);
11979       local = *tm_p;
11980       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11981       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11982       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11983       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11984     }
11985   }
11986
11987   when = time(NULL);
11988 # ifdef VMSISH_TIME
11989 # ifdef RTL_USES_UTC
11990   if (VMSISH_TIME) when = _toloc(when);
11991 # else
11992   if (!VMSISH_TIME) when = _toutc(when);
11993 # endif
11994 # endif
11995   if (timep != NULL) *timep = when;
11996   return when;
11997
11998 }  /* end of my_time() */
11999 /*}}}*/
12000
12001
12002 /*{{{struct tm *my_gmtime(const time_t *timep)*/
12003 struct tm *
12004 Perl_my_gmtime(pTHX_ const time_t *timep)
12005 {
12006   char *p;
12007   time_t when;
12008   struct tm *rsltmp;
12009
12010   if (timep == NULL) {
12011     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12012     return NULL;
12013   }
12014   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
12015
12016   when = *timep;
12017 # ifdef VMSISH_TIME
12018   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
12019 #  endif
12020 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
12021   return gmtime(&when);
12022 # else
12023   /* CRTL localtime() wants local time as input, so does no tz correction */
12024   rsltmp = localtime(&when);
12025   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
12026   return rsltmp;
12027 #endif
12028 }  /* end of my_gmtime() */
12029 /*}}}*/
12030
12031
12032 /*{{{struct tm *my_localtime(const time_t *timep)*/
12033 struct tm *
12034 Perl_my_localtime(pTHX_ const time_t *timep)
12035 {
12036   time_t when, whenutc;
12037   struct tm *rsltmp;
12038   int dst, offset;
12039
12040   if (timep == NULL) {
12041     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12042     return NULL;
12043   }
12044   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
12045   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
12046
12047   when = *timep;
12048 # ifdef RTL_USES_UTC
12049 # ifdef VMSISH_TIME
12050   if (VMSISH_TIME) when = _toutc(when);
12051 # endif
12052   /* CRTL localtime() wants UTC as input, does tz correction itself */
12053   return localtime(&when);
12054
12055 # else /* !RTL_USES_UTC */
12056   whenutc = when;
12057 # ifdef VMSISH_TIME
12058   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
12059   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
12060 # endif
12061   dst = -1;
12062 #ifndef RTL_USES_UTC
12063   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
12064       when = whenutc - offset;                   /* pseudolocal time*/
12065   }
12066 # endif
12067   /* CRTL localtime() wants local time as input, so does no tz correction */
12068   rsltmp = localtime(&when);
12069   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
12070   return rsltmp;
12071 # endif
12072
12073 } /*  end of my_localtime() */
12074 /*}}}*/
12075
12076 /* Reset definitions for later calls */
12077 #define gmtime(t)    my_gmtime(t)
12078 #define localtime(t) my_localtime(t)
12079 #define time(t)      my_time(t)
12080
12081
12082 /* my_utime - update modification/access time of a file
12083  *
12084  * VMS 7.3 and later implementation
12085  * Only the UTC translation is home-grown. The rest is handled by the
12086  * CRTL utime(), which will take into account the relevant feature
12087  * logicals and ODS-5 volume characteristics for true access times.
12088  *
12089  * pre VMS 7.3 implementation:
12090  * The calling sequence is identical to POSIX utime(), but under
12091  * VMS with ODS-2, only the modification time is changed; ODS-2 does
12092  * not maintain access times.  Restrictions differ from the POSIX
12093  * definition in that the time can be changed as long as the
12094  * caller has permission to execute the necessary IO$_MODIFY $QIO;
12095  * no separate checks are made to insure that the caller is the
12096  * owner of the file or has special privs enabled.
12097  * Code here is based on Joe Meadows' FILE utility.
12098  *
12099  */
12100
12101 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
12102  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
12103  * in 100 ns intervals.
12104  */
12105 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
12106
12107 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
12108 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
12109 {
12110 #if __CRTL_VER >= 70300000
12111   struct utimbuf utc_utimes, *utc_utimesp;
12112
12113   if (utimes != NULL) {
12114     utc_utimes.actime = utimes->actime;
12115     utc_utimes.modtime = utimes->modtime;
12116 # ifdef VMSISH_TIME
12117     /* If input was local; convert to UTC for sys svc */
12118     if (VMSISH_TIME) {
12119       utc_utimes.actime = _toutc(utimes->actime);
12120       utc_utimes.modtime = _toutc(utimes->modtime);
12121     }
12122 # endif
12123     utc_utimesp = &utc_utimes;
12124   }
12125   else {
12126     utc_utimesp = NULL;
12127   }
12128
12129   return utime(file, utc_utimesp);
12130
12131 #else /* __CRTL_VER < 70300000 */
12132
12133   register int i;
12134   int sts;
12135   long int bintime[2], len = 2, lowbit, unixtime,
12136            secscale = 10000000; /* seconds --> 100 ns intervals */
12137   unsigned long int chan, iosb[2], retsts;
12138   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
12139   struct FAB myfab = cc$rms_fab;
12140   struct NAM mynam = cc$rms_nam;
12141 #if defined (__DECC) && defined (__VAX)
12142   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
12143    * at least through VMS V6.1, which causes a type-conversion warning.
12144    */
12145 #  pragma message save
12146 #  pragma message disable cvtdiftypes
12147 #endif
12148   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
12149   struct fibdef myfib;
12150 #if defined (__DECC) && defined (__VAX)
12151   /* This should be right after the declaration of myatr, but due
12152    * to a bug in VAX DEC C, this takes effect a statement early.
12153    */
12154 #  pragma message restore
12155 #endif
12156   /* cast ok for read only parameter */
12157   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
12158                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
12159                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
12160
12161   if (file == NULL || *file == '\0') {
12162     SETERRNO(ENOENT, LIB$_INVARG);
12163     return -1;
12164   }
12165
12166   /* Convert to VMS format ensuring that it will fit in 255 characters */
12167   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
12168       SETERRNO(ENOENT, LIB$_INVARG);
12169       return -1;
12170   }
12171   if (utimes != NULL) {
12172     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
12173      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
12174      * Since time_t is unsigned long int, and lib$emul takes a signed long int
12175      * as input, we force the sign bit to be clear by shifting unixtime right
12176      * one bit, then multiplying by an extra factor of 2 in lib$emul().
12177      */
12178     lowbit = (utimes->modtime & 1) ? secscale : 0;
12179     unixtime = (long int) utimes->modtime;
12180 #   ifdef VMSISH_TIME
12181     /* If input was UTC; convert to local for sys svc */
12182     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
12183 #   endif
12184     unixtime >>= 1;  secscale <<= 1;
12185     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
12186     if (!(retsts & 1)) {
12187       SETERRNO(EVMSERR, retsts);
12188       return -1;
12189     }
12190     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
12191     if (!(retsts & 1)) {
12192       SETERRNO(EVMSERR, retsts);
12193       return -1;
12194     }
12195   }
12196   else {
12197     /* Just get the current time in VMS format directly */
12198     retsts = sys$gettim(bintime);
12199     if (!(retsts & 1)) {
12200       SETERRNO(EVMSERR, retsts);
12201       return -1;
12202     }
12203   }
12204
12205   myfab.fab$l_fna = vmsspec;
12206   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
12207   myfab.fab$l_nam = &mynam;
12208   mynam.nam$l_esa = esa;
12209   mynam.nam$b_ess = (unsigned char) sizeof esa;
12210   mynam.nam$l_rsa = rsa;
12211   mynam.nam$b_rss = (unsigned char) sizeof rsa;
12212   if (decc_efs_case_preserve)
12213       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
12214
12215   /* Look for the file to be affected, letting RMS parse the file
12216    * specification for us as well.  I have set errno using only
12217    * values documented in the utime() man page for VMS POSIX.
12218    */
12219   retsts = sys$parse(&myfab,0,0);
12220   if (!(retsts & 1)) {
12221     set_vaxc_errno(retsts);
12222     if      (retsts == RMS$_PRV) set_errno(EACCES);
12223     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
12224     else                         set_errno(EVMSERR);
12225     return -1;
12226   }
12227   retsts = sys$search(&myfab,0,0);
12228   if (!(retsts & 1)) {
12229     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12230     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12231     set_vaxc_errno(retsts);
12232     if      (retsts == RMS$_PRV) set_errno(EACCES);
12233     else if (retsts == RMS$_FNF) set_errno(ENOENT);
12234     else                         set_errno(EVMSERR);
12235     return -1;
12236   }
12237
12238   devdsc.dsc$w_length = mynam.nam$b_dev;
12239   /* cast ok for read only parameter */
12240   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
12241
12242   retsts = sys$assign(&devdsc,&chan,0,0);
12243   if (!(retsts & 1)) {
12244     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12245     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12246     set_vaxc_errno(retsts);
12247     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
12248     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
12249     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
12250     else                               set_errno(EVMSERR);
12251     return -1;
12252   }
12253
12254   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
12255   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
12256
12257   memset((void *) &myfib, 0, sizeof myfib);
12258 #if defined(__DECC) || defined(__DECCXX)
12259   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
12260   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
12261   /* This prevents the revision time of the file being reset to the current
12262    * time as a result of our IO$_MODIFY $QIO. */
12263   myfib.fib$l_acctl = FIB$M_NORECORD;
12264 #else
12265   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
12266   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
12267   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
12268 #endif
12269   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
12270   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12271   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12272   _ckvmssts(sys$dassgn(chan));
12273   if (retsts & 1) retsts = iosb[0];
12274   if (!(retsts & 1)) {
12275     set_vaxc_errno(retsts);
12276     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12277     else                      set_errno(EVMSERR);
12278     return -1;
12279   }
12280
12281   return 0;
12282
12283 #endif /* #if __CRTL_VER >= 70300000 */
12284
12285 }  /* end of my_utime() */
12286 /*}}}*/
12287
12288 /*
12289  * flex_stat, flex_lstat, flex_fstat
12290  * basic stat, but gets it right when asked to stat
12291  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
12292  */
12293
12294 #ifndef _USE_STD_STAT
12295 /* encode_dev packs a VMS device name string into an integer to allow
12296  * simple comparisons. This can be used, for example, to check whether two
12297  * files are located on the same device, by comparing their encoded device
12298  * names. Even a string comparison would not do, because stat() reuses the
12299  * device name buffer for each call; so without encode_dev, it would be
12300  * necessary to save the buffer and use strcmp (this would mean a number of
12301  * changes to the standard Perl code, to say nothing of what a Perl script
12302  * would have to do.
12303  *
12304  * The device lock id, if it exists, should be unique (unless perhaps compared
12305  * with lock ids transferred from other nodes). We have a lock id if the disk is
12306  * mounted cluster-wide, which is when we tend to get long (host-qualified)
12307  * device names. Thus we use the lock id in preference, and only if that isn't
12308  * available, do we try to pack the device name into an integer (flagged by
12309  * the sign bit (LOCKID_MASK) being set).
12310  *
12311  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
12312  * name and its encoded form, but it seems very unlikely that we will find
12313  * two files on different disks that share the same encoded device names,
12314  * and even more remote that they will share the same file id (if the test
12315  * is to check for the same file).
12316  *
12317  * A better method might be to use sys$device_scan on the first call, and to
12318  * search for the device, returning an index into the cached array.
12319  * The number returned would be more intelligible.
12320  * This is probably not worth it, and anyway would take quite a bit longer
12321  * on the first call.
12322  */
12323 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
12324 static mydev_t encode_dev (pTHX_ const char *dev)
12325 {
12326   int i;
12327   unsigned long int f;
12328   mydev_t enc;
12329   char c;
12330   const char *q;
12331
12332   if (!dev || !dev[0]) return 0;
12333
12334 #if LOCKID_MASK
12335   {
12336     struct dsc$descriptor_s dev_desc;
12337     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
12338
12339     /* For cluster-mounted disks, the disk lock identifier is unique, so we
12340        can try that first. */
12341     dev_desc.dsc$w_length =  strlen (dev);
12342     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
12343     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
12344     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
12345     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
12346     if (!$VMS_STATUS_SUCCESS(status)) {
12347       switch (status) {
12348         case SS$_NOSUCHDEV:
12349           SETERRNO(ENODEV, status);
12350           return 0;
12351         default:
12352           _ckvmssts(status);
12353       }
12354     }
12355     if (lockid) return (lockid & ~LOCKID_MASK);
12356   }
12357 #endif
12358
12359   /* Otherwise we try to encode the device name */
12360   enc = 0;
12361   f = 1;
12362   i = 0;
12363   for (q = dev + strlen(dev); q--; q >= dev) {
12364     if (*q == ':')
12365         break;
12366     if (isdigit (*q))
12367       c= (*q) - '0';
12368     else if (isalpha (toupper (*q)))
12369       c= toupper (*q) - 'A' + (char)10;
12370     else
12371       continue; /* Skip '$'s */
12372     i++;
12373     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
12374     if (i>1) f *= 36;
12375     enc += f * (unsigned long int) c;
12376   }
12377   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
12378
12379 }  /* end of encode_dev() */
12380 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12381         device_no = encode_dev(aTHX_ devname)
12382 #else
12383 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12384         device_no = new_dev_no
12385 #endif
12386
12387 static int
12388 is_null_device(name)
12389     const char *name;
12390 {
12391   if (decc_bug_devnull != 0) {
12392     if (strncmp("/dev/null", name, 9) == 0)
12393       return 1;
12394   }
12395     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
12396        The underscore prefix, controller letter, and unit number are
12397        independently optional; for our purposes, the colon punctuation
12398        is not.  The colon can be trailed by optional directory and/or
12399        filename, but two consecutive colons indicates a nodename rather
12400        than a device.  [pr]  */
12401   if (*name == '_') ++name;
12402   if (tolower(*name++) != 'n') return 0;
12403   if (tolower(*name++) != 'l') return 0;
12404   if (tolower(*name) == 'a') ++name;
12405   if (*name == '0') ++name;
12406   return (*name++ == ':') && (*name != ':');
12407 }
12408
12409 static int
12410 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
12411
12412 static I32
12413 Perl_cando_by_name_int
12414    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
12415 {
12416   char usrname[L_cuserid];
12417   struct dsc$descriptor_s usrdsc =
12418          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
12419   char *vmsname = NULL, *fileified = NULL;
12420   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
12421   unsigned short int retlen, trnlnm_iter_count;
12422   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12423   union prvdef curprv;
12424   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
12425          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
12426          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
12427   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
12428          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
12429          {0,0,0,0}};
12430   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
12431          {0,0,0,0}};
12432   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12433   Stat_t st;
12434   static int profile_context = -1;
12435
12436   if (!fname || !*fname) return FALSE;
12437
12438   /* Make sure we expand logical names, since sys$check_access doesn't */
12439   fileified = PerlMem_malloc(VMS_MAXRSS);
12440   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12441   if (!strpbrk(fname,"/]>:")) {
12442       strcpy(fileified,fname);
12443       trnlnm_iter_count = 0;
12444       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
12445         trnlnm_iter_count++;
12446         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
12447       }
12448       fname = fileified;
12449   }
12450
12451   vmsname = PerlMem_malloc(VMS_MAXRSS);
12452   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12453   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
12454     /* Don't know if already in VMS format, so make sure */
12455     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
12456       PerlMem_free(fileified);
12457       PerlMem_free(vmsname);
12458       return FALSE;
12459     }
12460   }
12461   else {
12462     strcpy(vmsname,fname);
12463   }
12464
12465   /* sys$check_access needs a file spec, not a directory spec.
12466    * flex_stat now will handle a null thread context during startup.
12467    */
12468
12469   retlen = namdsc.dsc$w_length = strlen(vmsname);
12470   if (vmsname[retlen-1] == ']'
12471       || vmsname[retlen-1] == '>'
12472       || vmsname[retlen-1] == ':'
12473       || (!Perl_flex_stat_int(NULL, vmsname, &st, 1) &&
12474           S_ISDIR(st.st_mode))) {
12475
12476       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
12477         PerlMem_free(fileified);
12478         PerlMem_free(vmsname);
12479         return FALSE;
12480       }
12481       fname = fileified;
12482   }
12483   else {
12484       fname = vmsname;
12485   }
12486
12487   retlen = namdsc.dsc$w_length = strlen(fname);
12488   namdsc.dsc$a_pointer = (char *)fname;
12489
12490   switch (bit) {
12491     case S_IXUSR: case S_IXGRP: case S_IXOTH:
12492       access = ARM$M_EXECUTE;
12493       flags = CHP$M_READ;
12494       break;
12495     case S_IRUSR: case S_IRGRP: case S_IROTH:
12496       access = ARM$M_READ;
12497       flags = CHP$M_READ | CHP$M_USEREADALL;
12498       break;
12499     case S_IWUSR: case S_IWGRP: case S_IWOTH:
12500       access = ARM$M_WRITE;
12501       flags = CHP$M_READ | CHP$M_WRITE;
12502       break;
12503     case S_IDUSR: case S_IDGRP: case S_IDOTH:
12504       access = ARM$M_DELETE;
12505       flags = CHP$M_READ | CHP$M_WRITE;
12506       break;
12507     default:
12508       if (fileified != NULL)
12509         PerlMem_free(fileified);
12510       if (vmsname != NULL)
12511         PerlMem_free(vmsname);
12512       return FALSE;
12513   }
12514
12515   /* Before we call $check_access, create a user profile with the current
12516    * process privs since otherwise it just uses the default privs from the
12517    * UAF and might give false positives or negatives.  This only works on
12518    * VMS versions v6.0 and later since that's when sys$create_user_profile
12519    * became available.
12520    */
12521
12522   /* get current process privs and username */
12523   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12524   _ckvmssts_noperl(iosb[0]);
12525
12526 #if defined(__VMS_VER) && __VMS_VER >= 60000000
12527
12528   /* find out the space required for the profile */
12529   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12530                                     &usrprodsc.dsc$w_length,&profile_context));
12531
12532   /* allocate space for the profile and get it filled in */
12533   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
12534   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12535   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12536                                     &usrprodsc.dsc$w_length,&profile_context));
12537
12538   /* use the profile to check access to the file; free profile & analyze results */
12539   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12540   PerlMem_free(usrprodsc.dsc$a_pointer);
12541   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12542
12543 #else
12544
12545   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
12546
12547 #endif
12548
12549   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12550       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12551       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12552     set_vaxc_errno(retsts);
12553     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12554     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12555     else set_errno(ENOENT);
12556     if (fileified != NULL)
12557       PerlMem_free(fileified);
12558     if (vmsname != NULL)
12559       PerlMem_free(vmsname);
12560     return FALSE;
12561   }
12562   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12563     if (fileified != NULL)
12564       PerlMem_free(fileified);
12565     if (vmsname != NULL)
12566       PerlMem_free(vmsname);
12567     return TRUE;
12568   }
12569   _ckvmssts_noperl(retsts);
12570
12571   if (fileified != NULL)
12572     PerlMem_free(fileified);
12573   if (vmsname != NULL)
12574     PerlMem_free(vmsname);
12575   return FALSE;  /* Should never get here */
12576
12577 }
12578
12579 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12580 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12581  * subset of the applicable information.
12582  */
12583 bool
12584 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12585 {
12586   return cando_by_name_int
12587         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12588 }  /* end of cando() */
12589 /*}}}*/
12590
12591
12592 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12593 I32
12594 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12595 {
12596    return cando_by_name_int(bit, effective, fname, 0);
12597
12598 }  /* end of cando_by_name() */
12599 /*}}}*/
12600
12601
12602 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12603 int
12604 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12605 {
12606   if (!fstat(fd, &statbufp->crtl_stat)) {
12607     char *cptr;
12608     char *vms_filename;
12609     vms_filename = PerlMem_malloc(VMS_MAXRSS);
12610     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12611
12612     /* Save name for cando by name in VMS format */
12613     cptr = getname(fd, vms_filename, 1);
12614
12615     /* This should not happen, but just in case */
12616     if (cptr == NULL) {
12617         statbufp->st_devnam[0] = 0;
12618     }
12619     else {
12620         /* Make sure that the saved name fits in 255 characters */
12621         cptr = int_rmsexpand_vms
12622                        (vms_filename,
12623                         statbufp->st_devnam,
12624                         0);
12625         if (cptr == NULL)
12626             statbufp->st_devnam[0] = 0;
12627     }
12628     PerlMem_free(vms_filename);
12629
12630     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12631     VMS_DEVICE_ENCODE
12632         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12633
12634 #   ifdef RTL_USES_UTC
12635 #   ifdef VMSISH_TIME
12636     if (VMSISH_TIME) {
12637       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12638       statbufp->st_atime = _toloc(statbufp->st_atime);
12639       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12640     }
12641 #   endif
12642 #   else
12643 #   ifdef VMSISH_TIME
12644     if (!VMSISH_TIME) { /* Return UTC instead of local time */
12645 #   else
12646     if (1) {
12647 #   endif
12648       statbufp->st_mtime = _toutc(statbufp->st_mtime);
12649       statbufp->st_atime = _toutc(statbufp->st_atime);
12650       statbufp->st_ctime = _toutc(statbufp->st_ctime);
12651     }
12652 #endif
12653     return 0;
12654   }
12655   return -1;
12656
12657 }  /* end of flex_fstat() */
12658 /*}}}*/
12659
12660 #if !defined(__VAX) && __CRTL_VER >= 80200000
12661 #ifdef lstat
12662 #undef lstat
12663 #endif
12664 #else
12665 #ifdef lstat
12666 #undef lstat
12667 #endif
12668 #define lstat(_x, _y) stat(_x, _y)
12669 #endif
12670
12671 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
12672
12673 static int
12674 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12675 {
12676     char *fileified;
12677     char *temp_fspec;
12678     const char *save_spec;
12679     char *ret_spec;
12680     int retval = -1;
12681     int efs_hack = 0;
12682     dSAVEDERRNO;
12683
12684     if (!fspec) {
12685         errno = EINVAL;
12686         return retval;
12687     }
12688
12689     if (decc_bug_devnull != 0) {
12690       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12691         memset(statbufp,0,sizeof *statbufp);
12692         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12693         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12694         statbufp->st_uid = 0x00010001;
12695         statbufp->st_gid = 0x0001;
12696         time((time_t *)&statbufp->st_mtime);
12697         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12698         return 0;
12699       }
12700     }
12701
12702     /* Try for a directory name first.  If fspec contains a filename without
12703      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12704      * and sea:[wine.dark]water. exist, we prefer the directory here.
12705      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12706      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12707      * the file with null type, specify this by calling flex_stat() with
12708      * a '.' at the end of fspec.
12709      *
12710      * If we are in Posix filespec mode, accept the filename as is.
12711      */
12712
12713
12714     fileified = PerlMem_malloc(VMS_MAXRSS);
12715     if (fileified == NULL)
12716         _ckvmssts_noperl(SS$_INSFMEM);
12717
12718     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
12719     if (temp_fspec == NULL)
12720         _ckvmssts_noperl(SS$_INSFMEM);
12721
12722     strcpy(temp_fspec, fspec);
12723
12724     SAVE_ERRNO;
12725
12726 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12727   if (decc_posix_compliant_pathnames == 0) {
12728 #endif
12729
12730     /* We may be able to optimize this, but in order for fileify_dirspec to
12731      * always return a usuable answer, we have to call vmspath first to
12732      * make sure that it is in VMS directory format, as stat/lstat on 8.3
12733      * can not handle directories in unix format that it does not have read
12734      * access to.  Vmspath handles the case where a bare name which could be
12735      * a logical name gets passed.
12736      */
12737     ret_spec = int_tovmspath(fspec, temp_fspec, NULL);
12738     if (ret_spec != NULL) {
12739         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
12740         if (ret_spec != NULL) {
12741             if (lstat_flag == 0)
12742                 retval = stat(fileified, &statbufp->crtl_stat);
12743             else
12744                 retval = lstat(fileified, &statbufp->crtl_stat);
12745             save_spec = fileified;
12746         }
12747     }
12748
12749     if (retval && vms_bug_stat_filename) {
12750
12751         /* We should try again as a vmsified file specification */
12752         /* However Perl traditionally has not done this, which  */
12753         /* causes problems with existing tests */
12754
12755         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12756         if (ret_spec != NULL) {
12757             if (lstat_flag == 0)
12758                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12759             else
12760                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12761             save_spec = temp_fspec;
12762         }
12763     }
12764
12765     if (retval) {
12766         /* Last chance - allow multiple dots with out EFS CHARSET */
12767         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12768          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12769          * enable it if it isn't already.
12770          */
12771 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12772         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12773             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12774 #endif
12775         if (lstat_flag == 0)
12776             retval = stat(fspec, &statbufp->crtl_stat);
12777         else
12778             retval = lstat(fspec, &statbufp->crtl_stat);
12779         save_spec = fspec;
12780 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12781         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12782             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12783             efs_hack = 1;
12784         }
12785 #endif
12786     }
12787
12788 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12789   } else {
12790     if (lstat_flag == 0)
12791       retval = stat(temp_fspec, &statbufp->crtl_stat);
12792     else
12793       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12794       save_spec = temp_fspec;
12795   }
12796 #endif
12797
12798 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12799   /* As you were... */
12800   if (!decc_efs_charset)
12801     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12802 #endif
12803
12804     if (!retval) {
12805     char * cptr;
12806     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12807
12808       /* If this is an lstat, do not follow the link */
12809       if (lstat_flag)
12810         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12811
12812 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12813       /* If we used the efs_hack above, we must also use it here for */
12814       /* perl_cando to work */
12815       if (efs_hack && (decc_efs_charset_index > 0)) {
12816           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12817       }
12818 #endif
12819       cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags);
12820 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12821       if (efs_hack && (decc_efs_charset_index > 0)) {
12822           decc$feature_set_value(decc_efs_charset, 1, 0);
12823       }
12824 #endif
12825
12826       /* Fix me: If this is NULL then stat found a file, and we could */
12827       /* not convert the specification to VMS - Should never happen */
12828       if (cptr == NULL)
12829         statbufp->st_devnam[0] = 0;
12830
12831       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12832       VMS_DEVICE_ENCODE
12833         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12834 #     ifdef RTL_USES_UTC
12835 #     ifdef VMSISH_TIME
12836       if (VMSISH_TIME) {
12837         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12838         statbufp->st_atime = _toloc(statbufp->st_atime);
12839         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12840       }
12841 #     endif
12842 #     else
12843 #     ifdef VMSISH_TIME
12844       if (!VMSISH_TIME) { /* Return UTC instead of local time */
12845 #     else
12846       if (1) {
12847 #     endif
12848         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12849         statbufp->st_atime = _toutc(statbufp->st_atime);
12850         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12851       }
12852 #     endif
12853     }
12854     /* If we were successful, leave errno where we found it */
12855     if (retval == 0) RESTORE_ERRNO;
12856     return retval;
12857
12858 }  /* end of flex_stat_int() */
12859
12860
12861 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12862 int
12863 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12864 {
12865    return flex_stat_int(fspec, statbufp, 0);
12866 }
12867 /*}}}*/
12868
12869 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12870 int
12871 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12872 {
12873    return flex_stat_int(fspec, statbufp, 1);
12874 }
12875 /*}}}*/
12876
12877
12878 /*{{{char *my_getlogin()*/
12879 /* VMS cuserid == Unix getlogin, except calling sequence */
12880 char *
12881 my_getlogin(void)
12882 {
12883     static char user[L_cuserid];
12884     return cuserid(user);
12885 }
12886 /*}}}*/
12887
12888
12889 /*  rmscopy - copy a file using VMS RMS routines
12890  *
12891  *  Copies contents and attributes of spec_in to spec_out, except owner
12892  *  and protection information.  Name and type of spec_in are used as
12893  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12894  *  should try to propagate timestamps from the input file to the output file.
12895  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12896  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12897  *  propagated to the output file at creation iff the output file specification
12898  *  did not contain an explicit name or type, and the revision date is always
12899  *  updated at the end of the copy operation.  If it is greater than 0, then
12900  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12901  *  other than the revision date should be propagated, and bit 1 indicates
12902  *  that the revision date should be propagated.
12903  *
12904  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12905  *
12906  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12907  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12908  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12909  * as part of the Perl standard distribution under the terms of the
12910  * GNU General Public License or the Perl Artistic License.  Copies
12911  * of each may be found in the Perl standard distribution.
12912  */ /* FIXME */
12913 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12914 int
12915 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12916 {
12917     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12918          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12919     unsigned long int i, sts, sts2;
12920     int dna_len;
12921     struct FAB fab_in, fab_out;
12922     struct RAB rab_in, rab_out;
12923     rms_setup_nam(nam);
12924     rms_setup_nam(nam_out);
12925     struct XABDAT xabdat;
12926     struct XABFHC xabfhc;
12927     struct XABRDT xabrdt;
12928     struct XABSUM xabsum;
12929
12930     vmsin = PerlMem_malloc(VMS_MAXRSS);
12931     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12932     vmsout = PerlMem_malloc(VMS_MAXRSS);
12933     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12934     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12935         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12936       PerlMem_free(vmsin);
12937       PerlMem_free(vmsout);
12938       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12939       return 0;
12940     }
12941
12942     esa = PerlMem_malloc(VMS_MAXRSS);
12943     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12944     esal = NULL;
12945 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12946     esal = PerlMem_malloc(VMS_MAXRSS);
12947     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12948 #endif
12949     fab_in = cc$rms_fab;
12950     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12951     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12952     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12953     fab_in.fab$l_fop = FAB$M_SQO;
12954     rms_bind_fab_nam(fab_in, nam);
12955     fab_in.fab$l_xab = (void *) &xabdat;
12956
12957     rsa = PerlMem_malloc(VMS_MAXRSS);
12958     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12959     rsal = NULL;
12960 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12961     rsal = PerlMem_malloc(VMS_MAXRSS);
12962     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12963 #endif
12964     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12965     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12966     rms_nam_esl(nam) = 0;
12967     rms_nam_rsl(nam) = 0;
12968     rms_nam_esll(nam) = 0;
12969     rms_nam_rsll(nam) = 0;
12970 #ifdef NAM$M_NO_SHORT_UPCASE
12971     if (decc_efs_case_preserve)
12972         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12973 #endif
12974
12975     xabdat = cc$rms_xabdat;        /* To get creation date */
12976     xabdat.xab$l_nxt = (void *) &xabfhc;
12977
12978     xabfhc = cc$rms_xabfhc;        /* To get record length */
12979     xabfhc.xab$l_nxt = (void *) &xabsum;
12980
12981     xabsum = cc$rms_xabsum;        /* To get key and area information */
12982
12983     if (!((sts = sys$open(&fab_in)) & 1)) {
12984       PerlMem_free(vmsin);
12985       PerlMem_free(vmsout);
12986       PerlMem_free(esa);
12987       if (esal != NULL)
12988         PerlMem_free(esal);
12989       PerlMem_free(rsa);
12990       if (rsal != NULL)
12991         PerlMem_free(rsal);
12992       set_vaxc_errno(sts);
12993       switch (sts) {
12994         case RMS$_FNF: case RMS$_DNF:
12995           set_errno(ENOENT); break;
12996         case RMS$_DIR:
12997           set_errno(ENOTDIR); break;
12998         case RMS$_DEV:
12999           set_errno(ENODEV); break;
13000         case RMS$_SYN:
13001           set_errno(EINVAL); break;
13002         case RMS$_PRV:
13003           set_errno(EACCES); break;
13004         default:
13005           set_errno(EVMSERR);
13006       }
13007       return 0;
13008     }
13009
13010     nam_out = nam;
13011     fab_out = fab_in;
13012     fab_out.fab$w_ifi = 0;
13013     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
13014     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
13015     fab_out.fab$l_fop = FAB$M_SQO;
13016     rms_bind_fab_nam(fab_out, nam_out);
13017     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
13018     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
13019     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
13020     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13021     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13022     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13023     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13024     esal_out = NULL;
13025     rsal_out = NULL;
13026 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13027     esal_out = PerlMem_malloc(VMS_MAXRSS);
13028     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13029     rsal_out = PerlMem_malloc(VMS_MAXRSS);
13030     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13031 #endif
13032     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
13033     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
13034
13035     if (preserve_dates == 0) {  /* Act like DCL COPY */
13036       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
13037       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
13038       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
13039         PerlMem_free(vmsin);
13040         PerlMem_free(vmsout);
13041         PerlMem_free(esa);
13042         if (esal != NULL)
13043             PerlMem_free(esal);
13044         PerlMem_free(rsa);
13045         if (rsal != NULL)
13046             PerlMem_free(rsal);
13047         PerlMem_free(esa_out);
13048         if (esal_out != NULL)
13049             PerlMem_free(esal_out);
13050         PerlMem_free(rsa_out);
13051         if (rsal_out != NULL)
13052             PerlMem_free(rsal_out);
13053         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
13054         set_vaxc_errno(sts);
13055         return 0;
13056       }
13057       fab_out.fab$l_xab = (void *) &xabdat;
13058       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
13059         preserve_dates = 1;
13060     }
13061     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
13062       preserve_dates =0;      /* bitmask from this point forward   */
13063
13064     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
13065     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
13066       PerlMem_free(vmsin);
13067       PerlMem_free(vmsout);
13068       PerlMem_free(esa);
13069       if (esal != NULL)
13070           PerlMem_free(esal);
13071       PerlMem_free(rsa);
13072       if (rsal != NULL)
13073           PerlMem_free(rsal);
13074       PerlMem_free(esa_out);
13075       if (esal_out != NULL)
13076           PerlMem_free(esal_out);
13077       PerlMem_free(rsa_out);
13078       if (rsal_out != NULL)
13079           PerlMem_free(rsal_out);
13080       set_vaxc_errno(sts);
13081       switch (sts) {
13082         case RMS$_DNF:
13083           set_errno(ENOENT); break;
13084         case RMS$_DIR:
13085           set_errno(ENOTDIR); break;
13086         case RMS$_DEV:
13087           set_errno(ENODEV); break;
13088         case RMS$_SYN:
13089           set_errno(EINVAL); break;
13090         case RMS$_PRV:
13091           set_errno(EACCES); break;
13092         default:
13093           set_errno(EVMSERR);
13094       }
13095       return 0;
13096     }
13097     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
13098     if (preserve_dates & 2) {
13099       /* sys$close() will process xabrdt, not xabdat */
13100       xabrdt = cc$rms_xabrdt;
13101 #ifndef __GNUC__
13102       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
13103 #else
13104       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
13105        * is unsigned long[2], while DECC & VAXC use a struct */
13106       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
13107 #endif
13108       fab_out.fab$l_xab = (void *) &xabrdt;
13109     }
13110
13111     ubf = PerlMem_malloc(32256);
13112     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13113     rab_in = cc$rms_rab;
13114     rab_in.rab$l_fab = &fab_in;
13115     rab_in.rab$l_rop = RAB$M_BIO;
13116     rab_in.rab$l_ubf = ubf;
13117     rab_in.rab$w_usz = 32256;
13118     if (!((sts = sys$connect(&rab_in)) & 1)) {
13119       sys$close(&fab_in); sys$close(&fab_out);
13120       PerlMem_free(vmsin);
13121       PerlMem_free(vmsout);
13122       PerlMem_free(ubf);
13123       PerlMem_free(esa);
13124       if (esal != NULL)
13125           PerlMem_free(esal);
13126       PerlMem_free(rsa);
13127       if (rsal != NULL)
13128           PerlMem_free(rsal);
13129       PerlMem_free(esa_out);
13130       if (esal_out != NULL)
13131           PerlMem_free(esal_out);
13132       PerlMem_free(rsa_out);
13133       if (rsal_out != NULL)
13134           PerlMem_free(rsal_out);
13135       set_errno(EVMSERR); set_vaxc_errno(sts);
13136       return 0;
13137     }
13138
13139     rab_out = cc$rms_rab;
13140     rab_out.rab$l_fab = &fab_out;
13141     rab_out.rab$l_rbf = ubf;
13142     if (!((sts = sys$connect(&rab_out)) & 1)) {
13143       sys$close(&fab_in); sys$close(&fab_out);
13144       PerlMem_free(vmsin);
13145       PerlMem_free(vmsout);
13146       PerlMem_free(ubf);
13147       PerlMem_free(esa);
13148       if (esal != NULL)
13149           PerlMem_free(esal);
13150       PerlMem_free(rsa);
13151       if (rsal != NULL)
13152           PerlMem_free(rsal);
13153       PerlMem_free(esa_out);
13154       if (esal_out != NULL)
13155           PerlMem_free(esal_out);
13156       PerlMem_free(rsa_out);
13157       if (rsal_out != NULL)
13158           PerlMem_free(rsal_out);
13159       set_errno(EVMSERR); set_vaxc_errno(sts);
13160       return 0;
13161     }
13162
13163     while ((sts = sys$read(&rab_in))) {  /* always true  */
13164       if (sts == RMS$_EOF) break;
13165       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
13166       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
13167         sys$close(&fab_in); sys$close(&fab_out);
13168         PerlMem_free(vmsin);
13169         PerlMem_free(vmsout);
13170         PerlMem_free(ubf);
13171         PerlMem_free(esa);
13172         if (esal != NULL)
13173             PerlMem_free(esal);
13174         PerlMem_free(rsa);
13175         if (rsal != NULL)
13176             PerlMem_free(rsal);
13177         PerlMem_free(esa_out);
13178         if (esal_out != NULL)
13179             PerlMem_free(esal_out);
13180         PerlMem_free(rsa_out);
13181         if (rsal_out != NULL)
13182             PerlMem_free(rsal_out);
13183         set_errno(EVMSERR); set_vaxc_errno(sts);
13184         return 0;
13185       }
13186     }
13187
13188
13189     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
13190     sys$close(&fab_in);  sys$close(&fab_out);
13191     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
13192
13193     PerlMem_free(vmsin);
13194     PerlMem_free(vmsout);
13195     PerlMem_free(ubf);
13196     PerlMem_free(esa);
13197     if (esal != NULL)
13198         PerlMem_free(esal);
13199     PerlMem_free(rsa);
13200     if (rsal != NULL)
13201         PerlMem_free(rsal);
13202     PerlMem_free(esa_out);
13203     if (esal_out != NULL)
13204         PerlMem_free(esal_out);
13205     PerlMem_free(rsa_out);
13206     if (rsal_out != NULL)
13207         PerlMem_free(rsal_out);
13208
13209     if (!(sts & 1)) {
13210       set_errno(EVMSERR); set_vaxc_errno(sts);
13211       return 0;
13212     }
13213
13214     return 1;
13215
13216 }  /* end of rmscopy() */
13217 /*}}}*/
13218
13219
13220 /***  The following glue provides 'hooks' to make some of the routines
13221  * from this file available from Perl.  These routines are sufficiently
13222  * basic, and are required sufficiently early in the build process,
13223  * that's it's nice to have them available to miniperl as well as the
13224  * full Perl, so they're set up here instead of in an extension.  The
13225  * Perl code which handles importation of these names into a given
13226  * package lives in [.VMS]Filespec.pm in @INC.
13227  */
13228
13229 void
13230 rmsexpand_fromperl(pTHX_ CV *cv)
13231 {
13232   dXSARGS;
13233   char *fspec, *defspec = NULL, *rslt;
13234   STRLEN n_a;
13235   int fs_utf8, dfs_utf8;
13236
13237   fs_utf8 = 0;
13238   dfs_utf8 = 0;
13239   if (!items || items > 2)
13240     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
13241   fspec = SvPV(ST(0),n_a);
13242   fs_utf8 = SvUTF8(ST(0));
13243   if (!fspec || !*fspec) XSRETURN_UNDEF;
13244   if (items == 2) {
13245     defspec = SvPV(ST(1),n_a);
13246     dfs_utf8 = SvUTF8(ST(1));
13247   }
13248   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
13249   ST(0) = sv_newmortal();
13250   if (rslt != NULL) {
13251     sv_usepvn(ST(0),rslt,strlen(rslt));
13252     if (fs_utf8) {
13253         SvUTF8_on(ST(0));
13254     }
13255   }
13256   XSRETURN(1);
13257 }
13258
13259 void
13260 vmsify_fromperl(pTHX_ CV *cv)
13261 {
13262   dXSARGS;
13263   char *vmsified;
13264   STRLEN n_a;
13265   int utf8_fl;
13266
13267   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
13268   utf8_fl = SvUTF8(ST(0));
13269   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13270   ST(0) = sv_newmortal();
13271   if (vmsified != NULL) {
13272     sv_usepvn(ST(0),vmsified,strlen(vmsified));
13273     if (utf8_fl) {
13274         SvUTF8_on(ST(0));
13275     }
13276   }
13277   XSRETURN(1);
13278 }
13279
13280 void
13281 unixify_fromperl(pTHX_ CV *cv)
13282 {
13283   dXSARGS;
13284   char *unixified;
13285   STRLEN n_a;
13286   int utf8_fl;
13287
13288   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
13289   utf8_fl = SvUTF8(ST(0));
13290   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13291   ST(0) = sv_newmortal();
13292   if (unixified != NULL) {
13293     sv_usepvn(ST(0),unixified,strlen(unixified));
13294     if (utf8_fl) {
13295         SvUTF8_on(ST(0));
13296     }
13297   }
13298   XSRETURN(1);
13299 }
13300
13301 void
13302 fileify_fromperl(pTHX_ CV *cv)
13303 {
13304   dXSARGS;
13305   char *fileified;
13306   STRLEN n_a;
13307   int utf8_fl;
13308
13309   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
13310   utf8_fl = SvUTF8(ST(0));
13311   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13312   ST(0) = sv_newmortal();
13313   if (fileified != NULL) {
13314     sv_usepvn(ST(0),fileified,strlen(fileified));
13315     if (utf8_fl) {
13316         SvUTF8_on(ST(0));
13317     }
13318   }
13319   XSRETURN(1);
13320 }
13321
13322 void
13323 pathify_fromperl(pTHX_ CV *cv)
13324 {
13325   dXSARGS;
13326   char *pathified;
13327   STRLEN n_a;
13328   int utf8_fl;
13329
13330   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
13331   utf8_fl = SvUTF8(ST(0));
13332   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13333   ST(0) = sv_newmortal();
13334   if (pathified != NULL) {
13335     sv_usepvn(ST(0),pathified,strlen(pathified));
13336     if (utf8_fl) {
13337         SvUTF8_on(ST(0));
13338     }
13339   }
13340   XSRETURN(1);
13341 }
13342
13343 void
13344 vmspath_fromperl(pTHX_ CV *cv)
13345 {
13346   dXSARGS;
13347   char *vmspath;
13348   STRLEN n_a;
13349   int utf8_fl;
13350
13351   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
13352   utf8_fl = SvUTF8(ST(0));
13353   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13354   ST(0) = sv_newmortal();
13355   if (vmspath != NULL) {
13356     sv_usepvn(ST(0),vmspath,strlen(vmspath));
13357     if (utf8_fl) {
13358         SvUTF8_on(ST(0));
13359     }
13360   }
13361   XSRETURN(1);
13362 }
13363
13364 void
13365 unixpath_fromperl(pTHX_ CV *cv)
13366 {
13367   dXSARGS;
13368   char *unixpath;
13369   STRLEN n_a;
13370   int utf8_fl;
13371
13372   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
13373   utf8_fl = SvUTF8(ST(0));
13374   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13375   ST(0) = sv_newmortal();
13376   if (unixpath != NULL) {
13377     sv_usepvn(ST(0),unixpath,strlen(unixpath));
13378     if (utf8_fl) {
13379         SvUTF8_on(ST(0));
13380     }
13381   }
13382   XSRETURN(1);
13383 }
13384
13385 void
13386 candelete_fromperl(pTHX_ CV *cv)
13387 {
13388   dXSARGS;
13389   char *fspec, *fsp;
13390   SV *mysv;
13391   IO *io;
13392   STRLEN n_a;
13393
13394   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
13395
13396   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13397   Newx(fspec, VMS_MAXRSS, char);
13398   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
13399   if (SvTYPE(mysv) == SVt_PVGV) {
13400     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
13401       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13402       ST(0) = &PL_sv_no;
13403       Safefree(fspec);
13404       XSRETURN(1);
13405     }
13406     fsp = fspec;
13407   }
13408   else {
13409     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
13410       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13411       ST(0) = &PL_sv_no;
13412       Safefree(fspec);
13413       XSRETURN(1);
13414     }
13415   }
13416
13417   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
13418   Safefree(fspec);
13419   XSRETURN(1);
13420 }
13421
13422 void
13423 rmscopy_fromperl(pTHX_ CV *cv)
13424 {
13425   dXSARGS;
13426   char *inspec, *outspec, *inp, *outp;
13427   int date_flag;
13428   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
13429                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13430   unsigned long int sts;
13431   SV *mysv;
13432   IO *io;
13433   STRLEN n_a;
13434
13435   if (items < 2 || items > 3)
13436     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
13437
13438   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13439   Newx(inspec, VMS_MAXRSS, char);
13440   if (SvTYPE(mysv) == SVt_PVGV) {
13441     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
13442       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13443       ST(0) = &PL_sv_no;
13444       Safefree(inspec);
13445       XSRETURN(1);
13446     }
13447     inp = inspec;
13448   }
13449   else {
13450     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
13451       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13452       ST(0) = &PL_sv_no;
13453       Safefree(inspec);
13454       XSRETURN(1);
13455     }
13456   }
13457   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
13458   Newx(outspec, VMS_MAXRSS, char);
13459   if (SvTYPE(mysv) == SVt_PVGV) {
13460     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
13461       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13462       ST(0) = &PL_sv_no;
13463       Safefree(inspec);
13464       Safefree(outspec);
13465       XSRETURN(1);
13466     }
13467     outp = outspec;
13468   }
13469   else {
13470     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
13471       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13472       ST(0) = &PL_sv_no;
13473       Safefree(inspec);
13474       Safefree(outspec);
13475       XSRETURN(1);
13476     }
13477   }
13478   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
13479
13480   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
13481   Safefree(inspec);
13482   Safefree(outspec);
13483   XSRETURN(1);
13484 }
13485
13486 /* The mod2fname is limited to shorter filenames by design, so it should
13487  * not be modified to support longer EFS pathnames
13488  */
13489 void
13490 mod2fname(pTHX_ CV *cv)
13491 {
13492   dXSARGS;
13493   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13494        workbuff[NAM$C_MAXRSS*1 + 1];
13495   int total_namelen = 3, counter, num_entries;
13496   /* ODS-5 ups this, but we want to be consistent, so... */
13497   int max_name_len = 39;
13498   AV *in_array = (AV *)SvRV(ST(0));
13499
13500   num_entries = av_len(in_array);
13501
13502   /* All the names start with PL_. */
13503   strcpy(ultimate_name, "PL_");
13504
13505   /* Clean up our working buffer */
13506   Zero(work_name, sizeof(work_name), char);
13507
13508   /* Run through the entries and build up a working name */
13509   for(counter = 0; counter <= num_entries; counter++) {
13510     /* If it's not the first name then tack on a __ */
13511     if (counter) {
13512       strcat(work_name, "__");
13513     }
13514     strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
13515   }
13516
13517   /* Check to see if we actually have to bother...*/
13518   if (strlen(work_name) + 3 <= max_name_len) {
13519     strcat(ultimate_name, work_name);
13520   } else {
13521     /* It's too darned big, so we need to go strip. We use the same */
13522     /* algorithm as xsubpp does. First, strip out doubled __ */
13523     char *source, *dest, last;
13524     dest = workbuff;
13525     last = 0;
13526     for (source = work_name; *source; source++) {
13527       if (last == *source && last == '_') {
13528         continue;
13529       }
13530       *dest++ = *source;
13531       last = *source;
13532     }
13533     /* Go put it back */
13534     strcpy(work_name, workbuff);
13535     /* Is it still too big? */
13536     if (strlen(work_name) + 3 > max_name_len) {
13537       /* Strip duplicate letters */
13538       last = 0;
13539       dest = workbuff;
13540       for (source = work_name; *source; source++) {
13541         if (last == toupper(*source)) {
13542         continue;
13543         }
13544         *dest++ = *source;
13545         last = toupper(*source);
13546       }
13547       strcpy(work_name, workbuff);
13548     }
13549
13550     /* Is it *still* too big? */
13551     if (strlen(work_name) + 3 > max_name_len) {
13552       /* Too bad, we truncate */
13553       work_name[max_name_len - 2] = 0;
13554     }
13555     strcat(ultimate_name, work_name);
13556   }
13557
13558   /* Okay, return it */
13559   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13560   XSRETURN(1);
13561 }
13562
13563 void
13564 hushexit_fromperl(pTHX_ CV *cv)
13565 {
13566     dXSARGS;
13567
13568     if (items > 0) {
13569         VMSISH_HUSHED = SvTRUE(ST(0));
13570     }
13571     ST(0) = boolSV(VMSISH_HUSHED);
13572     XSRETURN(1);
13573 }
13574
13575
13576 PerlIO *
13577 Perl_vms_start_glob
13578    (pTHX_ SV *tmpglob,
13579     IO *io)
13580 {
13581     PerlIO *fp;
13582     struct vs_str_st *rslt;
13583     char *vmsspec;
13584     char *rstr;
13585     char *begin, *cp;
13586     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13587     PerlIO *tmpfp;
13588     STRLEN i;
13589     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13590     struct dsc$descriptor_vs rsdsc;
13591     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13592     unsigned long hasver = 0, isunix = 0;
13593     unsigned long int lff_flags = 0;
13594     int rms_sts;
13595     int vms_old_glob = 1;
13596
13597     if (!SvOK(tmpglob)) {
13598         SETERRNO(ENOENT,RMS$_FNF);
13599         return NULL;
13600     }
13601
13602     vms_old_glob = !decc_filename_unix_report;
13603
13604 #ifdef VMS_LONGNAME_SUPPORT
13605     lff_flags = LIB$M_FIL_LONG_NAMES;
13606 #endif
13607     /* The Newx macro will not allow me to assign a smaller array
13608      * to the rslt pointer, so we will assign it to the begin char pointer
13609      * and then copy the value into the rslt pointer.
13610      */
13611     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13612     rslt = (struct vs_str_st *)begin;
13613     rslt->length = 0;
13614     rstr = &rslt->str[0];
13615     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13616     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13617     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13618     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13619
13620     Newx(vmsspec, VMS_MAXRSS, char);
13621
13622         /* We could find out if there's an explicit dev/dir or version
13623            by peeking into lib$find_file's internal context at
13624            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13625            but that's unsupported, so I don't want to do it now and
13626            have it bite someone in the future. */
13627         /* Fix-me: vms_split_path() is the only way to do this, the
13628            existing method will fail with many legal EFS or UNIX specifications
13629          */
13630
13631     cp = SvPV(tmpglob,i);
13632
13633     for (; i; i--) {
13634         if (cp[i] == ';') hasver = 1;
13635         if (cp[i] == '.') {
13636             if (sts) hasver = 1;
13637             else sts = 1;
13638         }
13639         if (cp[i] == '/') {
13640             hasdir = isunix = 1;
13641             break;
13642         }
13643         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13644             hasdir = 1;
13645             break;
13646         }
13647     }
13648
13649     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13650     if ((hasdir == 0) && decc_filename_unix_report) {
13651         isunix = 1;
13652     }
13653
13654     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13655         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13656         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13657         int wildstar = 0;
13658         int wildquery = 0;
13659         int found = 0;
13660         Stat_t st;
13661         int stat_sts;
13662         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13663         if (!stat_sts && S_ISDIR(st.st_mode)) {
13664             char * vms_dir;
13665             const char * fname;
13666             STRLEN fname_len;
13667
13668             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13669             /* path delimiter of ':>]', if so, then the old behavior has */
13670             /* obviously been specificially requested */
13671
13672             fname = SvPVX_const(tmpglob);
13673             fname_len = strlen(fname);
13674             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13675             if (vms_old_glob || (vms_dir != NULL)) {
13676                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13677                                             SvPVX(tmpglob),vmsspec,NULL);
13678                 ok = (wilddsc.dsc$a_pointer != NULL);
13679                 /* maybe passed 'foo' rather than '[.foo]', thus not
13680                    detected above */
13681                 hasdir = 1;
13682             } else {
13683                 /* Operate just on the directory, the special stat/fstat for */
13684                 /* leaves the fileified  specification in the st_devnam */
13685                 /* member. */
13686                 wilddsc.dsc$a_pointer = st.st_devnam;
13687                 ok = 1;
13688             }
13689         }
13690         else {
13691             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13692             ok = (wilddsc.dsc$a_pointer != NULL);
13693         }
13694         if (ok)
13695             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13696
13697         /* If not extended character set, replace ? with % */
13698         /* With extended character set, ? is a wildcard single character */
13699         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13700             if (*cp == '?') {
13701                 wildquery = 1;
13702                 if (!decc_efs_case_preserve)
13703                     *cp = '%';
13704             } else if (*cp == '%') {
13705                 wildquery = 1;
13706             } else if (*cp == '*') {
13707                 wildstar = 1;
13708             }
13709         }
13710
13711         if (ok) {
13712             wv_sts = vms_split_path(
13713                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13714                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13715                 &wvs_spec, &wvs_len);
13716         } else {
13717             wn_spec = NULL;
13718             wn_len = 0;
13719             we_spec = NULL;
13720             we_len = 0;
13721         }
13722
13723         sts = SS$_NORMAL;
13724         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13725          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13726          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13727          int valid_find;
13728
13729             valid_find = 0;
13730             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13731                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13732             if (!$VMS_STATUS_SUCCESS(sts))
13733                 break;
13734
13735             /* with varying string, 1st word of buffer contains result length */
13736             rstr[rslt->length] = '\0';
13737
13738              /* Find where all the components are */
13739              v_sts = vms_split_path
13740                        (rstr,
13741                         &v_spec,
13742                         &v_len,
13743                         &r_spec,
13744                         &r_len,
13745                         &d_spec,
13746                         &d_len,
13747                         &n_spec,
13748                         &n_len,
13749                         &e_spec,
13750                         &e_len,
13751                         &vs_spec,
13752                         &vs_len);
13753
13754             /* If no version on input, truncate the version on output */
13755             if (!hasver && (vs_len > 0)) {
13756                 *vs_spec = '\0';
13757                 vs_len = 0;
13758             }
13759
13760             if (isunix) {
13761
13762                 /* In Unix report mode, remove the ".dir;1" from the name */
13763                 /* if it is a real directory */
13764                 if (decc_filename_unix_report || decc_efs_charset) {
13765                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13766                         Stat_t statbuf;
13767                         int ret_sts;
13768
13769                         ret_sts = flex_lstat(rstr, &statbuf);
13770                         if ((ret_sts == 0) &&
13771                             S_ISDIR(statbuf.st_mode)) {
13772                             e_len = 0;
13773                             e_spec[0] = 0;
13774                         }
13775                     }
13776                 }
13777
13778                 /* No version & a null extension on UNIX handling */
13779                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13780                     e_len = 0;
13781                     *e_spec = '\0';
13782                 }
13783             }
13784
13785             if (!decc_efs_case_preserve) {
13786                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13787             }
13788
13789             /* Find File treats a Null extension as return all extensions */
13790             /* This is contrary to Perl expectations */
13791
13792             if (wildstar || wildquery || vms_old_glob) {
13793                 /* really need to see if the returned file name matched */
13794                 /* but for now will assume that it matches */
13795                 valid_find = 1;
13796             } else {
13797                 /* Exact Match requested */
13798                 /* How are directories handled? - like a file */
13799                 if ((e_len == we_len) && (n_len == wn_len)) {
13800                     int t1;
13801                     t1 = e_len;
13802                     if (t1 > 0)
13803                         t1 = strncmp(e_spec, we_spec, e_len);
13804                     if (t1 == 0) {
13805                        t1 = n_len;
13806                        if (t1 > 0)
13807                            t1 = strncmp(n_spec, we_spec, n_len);
13808                        if (t1 == 0)
13809                            valid_find = 1;
13810                     }
13811                 }
13812             }
13813
13814             if (valid_find) {
13815                 found++;
13816
13817                 if (hasdir) {
13818                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13819                     begin = rstr;
13820                 }
13821                 else {
13822                     /* Start with the name */
13823                     begin = n_spec;
13824                 }
13825                 strcat(begin,"\n");
13826                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13827             }
13828         }
13829         if (cxt) (void)lib$find_file_end(&cxt);
13830
13831         if (!found) {
13832             /* Be POSIXish: return the input pattern when no matches */
13833             strcpy(rstr,SvPVX(tmpglob));
13834             strcat(rstr,"\n");
13835             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13836         }
13837
13838         if (ok && sts != RMS$_NMF &&
13839             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13840         if (!ok) {
13841             if (!(sts & 1)) {
13842                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13843             }
13844             PerlIO_close(tmpfp);
13845             fp = NULL;
13846         }
13847         else {
13848             PerlIO_rewind(tmpfp);
13849             IoTYPE(io) = IoTYPE_RDONLY;
13850             IoIFP(io) = fp = tmpfp;
13851             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13852         }
13853     }
13854     Safefree(vmsspec);
13855     Safefree(rslt);
13856     return fp;
13857 }
13858
13859
13860 static char *
13861 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13862                    int *utf8_fl);
13863
13864 void
13865 unixrealpath_fromperl(pTHX_ CV *cv)
13866 {
13867     dXSARGS;
13868     char *fspec, *rslt_spec, *rslt;
13869     STRLEN n_a;
13870
13871     if (!items || items != 1)
13872         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13873
13874     fspec = SvPV(ST(0),n_a);
13875     if (!fspec || !*fspec) XSRETURN_UNDEF;
13876
13877     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13878     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13879
13880     ST(0) = sv_newmortal();
13881     if (rslt != NULL)
13882         sv_usepvn(ST(0),rslt,strlen(rslt));
13883     else
13884         Safefree(rslt_spec);
13885         XSRETURN(1);
13886 }
13887
13888 static char *
13889 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13890                    int *utf8_fl);
13891
13892 void
13893 vmsrealpath_fromperl(pTHX_ CV *cv)
13894 {
13895     dXSARGS;
13896     char *fspec, *rslt_spec, *rslt;
13897     STRLEN n_a;
13898
13899     if (!items || items != 1)
13900         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13901
13902     fspec = SvPV(ST(0),n_a);
13903     if (!fspec || !*fspec) XSRETURN_UNDEF;
13904
13905     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13906     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13907
13908     ST(0) = sv_newmortal();
13909     if (rslt != NULL)
13910         sv_usepvn(ST(0),rslt,strlen(rslt));
13911     else
13912         Safefree(rslt_spec);
13913         XSRETURN(1);
13914 }
13915
13916 #ifdef HAS_SYMLINK
13917 /*
13918  * A thin wrapper around decc$symlink to make sure we follow the
13919  * standard and do not create a symlink with a zero-length name.
13920  *
13921  * Also in ODS-2 mode, existing tests assume that the link target
13922  * will be converted to UNIX format.
13923  */
13924 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13925 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
13926   if (!link_name || !*link_name) {
13927     SETERRNO(ENOENT, SS$_NOSUCHFILE);
13928     return -1;
13929   }
13930
13931   if (decc_efs_charset) {
13932       return symlink(contents, link_name);
13933   } else {
13934       int sts;
13935       char * utarget;
13936
13937       /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
13938       /* because in order to work, the symlink target must be in UNIX format */
13939
13940       /* As symbolic links can hold things other than files, we will only do */
13941       /* the conversion in in ODS-2 mode */
13942
13943       Newx(utarget, VMS_MAXRSS + 1, char);
13944       if (int_tounixspec(contents, utarget, NULL) == NULL) {
13945
13946           /* This should not fail, as an untranslatable filename */
13947           /* should be passed through */
13948           utarget = (char *)contents;
13949       }
13950       sts = symlink(utarget, link_name);
13951       Safefree(utarget);
13952       return sts;
13953   }
13954
13955 }
13956 /*}}}*/
13957
13958 #endif /* HAS_SYMLINK */
13959
13960 int do_vms_case_tolerant(void);
13961
13962 void
13963 case_tolerant_process_fromperl(pTHX_ CV *cv)
13964 {
13965   dXSARGS;
13966   ST(0) = boolSV(do_vms_case_tolerant());
13967   XSRETURN(1);
13968 }
13969
13970 #ifdef USE_ITHREADS
13971
13972 void
13973 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13974                           struct interp_intern *dst)
13975 {
13976     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13977
13978     memcpy(dst,src,sizeof(struct interp_intern));
13979 }
13980
13981 #endif
13982
13983 void
13984 Perl_sys_intern_clear(pTHX)
13985 {
13986 }
13987
13988 void
13989 Perl_sys_intern_init(pTHX)
13990 {
13991     unsigned int ix = RAND_MAX;
13992     double x;
13993
13994     VMSISH_HUSHED = 0;
13995
13996     MY_POSIX_EXIT = vms_posix_exit;
13997
13998     x = (float)ix;
13999     MY_INV_RAND_MAX = 1./x;
14000 }
14001
14002 void
14003 init_os_extras(void)
14004 {
14005   dTHX;
14006   char* file = __FILE__;
14007   if (decc_disable_to_vms_logname_translation) {
14008     no_translate_barewords = TRUE;
14009   } else {
14010     no_translate_barewords = FALSE;
14011   }
14012
14013   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
14014   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
14015   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
14016   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
14017   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
14018   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
14019   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
14020   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
14021   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
14022   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
14023   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
14024   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
14025   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
14026   newXSproto("VMS::Filespec::case_tolerant_process",
14027       case_tolerant_process_fromperl,file,"");
14028
14029   store_pipelocs(aTHX);         /* will redo any earlier attempts */
14030
14031   return;
14032 }
14033
14034 #if __CRTL_VER == 80200000
14035 /* This missed getting in to the DECC SDK for 8.2 */
14036 char *realpath(const char *file_name, char * resolved_name, ...);
14037 #endif
14038
14039 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
14040 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
14041  * The perl fallback routine to provide realpath() is not as efficient
14042  * on OpenVMS.
14043  */
14044
14045 /* Hack, use old stat() as fastest way of getting ino_t and device */
14046 int decc$stat(const char *name, void * statbuf);
14047 #if !defined(__VAX) && __CRTL_VER >= 80200000
14048 int decc$lstat(const char *name, void * statbuf);
14049 #else
14050 #define decc$lstat decc$stat
14051 #endif
14052
14053
14054 /* Realpath is fragile.  In 8.3 it does not work if the feature
14055  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
14056  * links are implemented in RMS, not the CRTL. It also can fail if the
14057  * user does not have read/execute access to some of the directories.
14058  * So in order for Do What I Mean mode to work, if realpath() fails,
14059  * fall back to looking up the filename by the device name and FID.
14060  */
14061
14062 int vms_fid_to_name(char * outname, int outlen,
14063                     const char * name, int lstat_flag, mode_t * mode)
14064 {
14065 #pragma message save
14066 #pragma message disable MISALGNDSTRCT
14067 #pragma message disable MISALGNDMEM
14068 #pragma member_alignment save
14069 #pragma nomember_alignment
14070 struct statbuf_t {
14071     char           * st_dev;
14072     unsigned short st_ino[3];
14073     unsigned short old_st_mode;
14074     unsigned long  padl[30];  /* plenty of room */
14075 } statbuf;
14076 #pragma message restore
14077 #pragma member_alignment restore
14078
14079     int sts;
14080     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14081     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14082     char *fileified;
14083     char *temp_fspec;
14084     char *ret_spec;
14085
14086     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
14087      * unexpected answers
14088      */
14089
14090     fileified = PerlMem_malloc(VMS_MAXRSS);
14091     if (fileified == NULL)
14092         _ckvmssts_noperl(SS$_INSFMEM);
14093
14094     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
14095     if (temp_fspec == NULL)
14096         _ckvmssts_noperl(SS$_INSFMEM);
14097
14098     sts = -1;
14099     /* First need to try as a directory */
14100     ret_spec = int_tovmspath(name, temp_fspec, NULL);
14101     if (ret_spec != NULL) {
14102         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
14103         if (ret_spec != NULL) {
14104             if (lstat_flag == 0)
14105                 sts = decc$stat(fileified, &statbuf);
14106             else
14107                 sts = decc$lstat(fileified, &statbuf);
14108         }
14109     }
14110
14111     /* Then as a VMS file spec */
14112     if (sts != 0) {
14113         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
14114         if (ret_spec != NULL) {
14115             if (lstat_flag == 0) {
14116                 sts = decc$stat(temp_fspec, &statbuf);
14117             } else {
14118                 sts = decc$lstat(temp_fspec, &statbuf);
14119             }
14120         }
14121     }
14122
14123     if (sts) {
14124         /* Next try - allow multiple dots with out EFS CHARSET */
14125         /* The CRTL stat() falls down hard on multi-dot filenames in unix
14126          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
14127          * enable it if it isn't already.
14128          */
14129 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14130         if (!decc_efs_charset && (decc_efs_charset_index > 0))
14131             decc$feature_set_value(decc_efs_charset_index, 1, 1);
14132 #endif
14133         ret_spec = int_tovmspath(name, temp_fspec, NULL);
14134         if (lstat_flag == 0) {
14135             sts = decc$stat(name, &statbuf);
14136         } else {
14137             sts = decc$lstat(name, &statbuf);
14138         }
14139 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14140         if (!decc_efs_charset && (decc_efs_charset_index > 0))
14141             decc$feature_set_value(decc_efs_charset_index, 1, 0);
14142 #endif
14143     }
14144
14145
14146     /* and then because the Perl Unix to VMS conversion is not perfect */
14147     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
14148     /* characters from filenames so we need to try it as-is */
14149     if (sts) {
14150         if (lstat_flag == 0) {
14151             sts = decc$stat(name, &statbuf);
14152         } else {
14153             sts = decc$lstat(name, &statbuf);
14154         }
14155     }
14156
14157     if (sts == 0) {
14158         int vms_sts;
14159
14160         dvidsc.dsc$a_pointer=statbuf.st_dev;
14161        dvidsc.dsc$w_length=strlen(statbuf.st_dev);
14162
14163         specdsc.dsc$a_pointer = outname;
14164         specdsc.dsc$w_length = outlen-1;
14165
14166        vms_sts = lib$fid_to_name
14167             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
14168        if ($VMS_STATUS_SUCCESS(vms_sts)) {
14169             outname[specdsc.dsc$w_length] = 0;
14170
14171             /* Return the mode */
14172             if (mode) {
14173                 *mode = statbuf.old_st_mode;
14174             }
14175             return 0;
14176         }
14177     }
14178     return sts;
14179 }
14180
14181
14182
14183 static char *
14184 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
14185                    int *utf8_fl)
14186 {
14187     char * rslt = NULL;
14188
14189 #ifdef HAS_SYMLINK
14190     if (decc_posix_compliant_pathnames > 0 ) {
14191         /* realpath currently only works if posix compliant pathnames are
14192          * enabled.  It may start working when they are not, but in that
14193          * case we still want the fallback behavior for backwards compatibility
14194          */
14195         rslt = realpath(filespec, outbuf);
14196     }
14197 #endif
14198
14199     if (rslt == NULL) {
14200         char * vms_spec;
14201         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14202         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14203         int file_len;
14204         mode_t my_mode;
14205
14206         /* Fall back to fid_to_name */
14207
14208         Newx(vms_spec, VMS_MAXRSS + 1, char);
14209
14210         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
14211         if (sts == 0) {
14212
14213
14214             /* Now need to trim the version off */
14215             sts = vms_split_path
14216                   (vms_spec,
14217                    &v_spec,
14218                    &v_len,
14219                    &r_spec,
14220                    &r_len,
14221                    &d_spec,
14222                    &d_len,
14223                    &n_spec,
14224                    &n_len,
14225                    &e_spec,
14226                    &e_len,
14227                    &vs_spec,
14228                    &vs_len);
14229
14230
14231                 if (sts == 0) {
14232                     int haslower = 0;
14233                     const char *cp;
14234
14235                     /* Trim off the version */
14236                     int file_len = v_len + r_len + d_len + n_len + e_len;
14237                     vms_spec[file_len] = 0;
14238
14239                     /* The result is expected to be in UNIX format */
14240                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
14241
14242                     /* Downcase if input had any lower case letters and
14243                      * case preservation is not in effect.
14244                      */
14245                     if (!decc_efs_case_preserve) {
14246                         for (cp = filespec; *cp; cp++)
14247                             if (islower(*cp)) { haslower = 1; break; }
14248
14249                         if (haslower) __mystrtolower(rslt);
14250                     }
14251                 }
14252         } else {
14253
14254             /* Now for some hacks to deal with backwards and forward */
14255             /* compatibilty */
14256             if (!decc_efs_charset) {
14257
14258                 /* 1. ODS-2 mode wants to do a syntax only translation */
14259                 rslt = int_rmsexpand(filespec, outbuf,
14260                                     NULL, 0, NULL, utf8_fl);
14261
14262             } else {
14263                 if (decc_filename_unix_report) {
14264                     char * dir_name;
14265                     char * vms_dir_name;
14266                     char * file_name;
14267
14268                     /* 2. ODS-5 / UNIX report mode should return a failure */
14269                     /*    if the parent directory also does not exist */
14270                     /*    Otherwise, get the real path for the parent */
14271                     /*    and add the child to it.
14272
14273                     /* basename / dirname only available for VMS 7.0+ */
14274                     /* So we may need to implement them as common routines */
14275
14276                     Newx(dir_name, VMS_MAXRSS + 1, char);
14277                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
14278                     dir_name[0] = '\0';
14279                     file_name = NULL;
14280
14281                     /* First try a VMS parse */
14282                     sts = vms_split_path
14283                           (filespec,
14284                            &v_spec,
14285                            &v_len,
14286                            &r_spec,
14287                            &r_len,
14288                            &d_spec,
14289                            &d_len,
14290                            &n_spec,
14291                            &n_len,
14292                            &e_spec,
14293                            &e_len,
14294                            &vs_spec,
14295                            &vs_len);
14296
14297                     if (sts == 0) {
14298                         /* This is VMS */
14299
14300                         int dir_len = v_len + r_len + d_len + n_len;
14301                         if (dir_len > 0) {
14302                            strncpy(dir_name, filespec, dir_len);
14303                            dir_name[dir_len] = '\0';
14304                            file_name = (char *)&filespec[dir_len + 1];
14305                         }
14306                     } else {
14307                         /* This must be UNIX */
14308                         char * tchar;
14309
14310                         tchar = strrchr(filespec, '/');
14311
14312                         if (tchar != NULL) {
14313                             int dir_len = tchar - filespec;
14314                             strncpy(dir_name, filespec, dir_len);
14315                             dir_name[dir_len] = '\0';
14316                             file_name = (char *) &filespec[dir_len + 1];
14317                         }
14318                     }
14319
14320                     /* Dir name is defaulted */
14321                     if (dir_name[0] == 0) {
14322                         dir_name[0] = '.';
14323                         dir_name[1] = '\0';
14324                     }
14325
14326                     /* Need realpath for the directory */
14327                     sts = vms_fid_to_name(vms_dir_name,
14328                                           VMS_MAXRSS + 1,
14329                                           dir_name, 0, NULL);
14330
14331                     if (sts == 0) {
14332                         /* Now need to pathify it.
14333                         char *tdir = int_pathify_dirspec(vms_dir_name,
14334                                                          outbuf);
14335
14336                         /* And now add the original filespec to it */
14337                         if (file_name != NULL) {
14338                             strcat(outbuf, file_name);
14339                         }
14340                         return outbuf;
14341                     }
14342                     Safefree(vms_dir_name);
14343                     Safefree(dir_name);
14344                 }
14345             }
14346         }
14347         Safefree(vms_spec);
14348     }
14349     return rslt;
14350 }
14351
14352 static char *
14353 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
14354                    int *utf8_fl)
14355 {
14356     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14357     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14358     int file_len;
14359
14360     /* Fall back to fid_to_name */
14361
14362     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
14363     if (sts != 0) {
14364         return NULL;
14365     }
14366     else {
14367
14368
14369         /* Now need to trim the version off */
14370         sts = vms_split_path
14371                   (outbuf,
14372                    &v_spec,
14373                    &v_len,
14374                    &r_spec,
14375                    &r_len,
14376                    &d_spec,
14377                    &d_len,
14378                    &n_spec,
14379                    &n_len,
14380                    &e_spec,
14381                    &e_len,
14382                    &vs_spec,
14383                    &vs_len);
14384
14385
14386         if (sts == 0) {
14387             int haslower = 0;
14388             const char *cp;
14389
14390             /* Trim off the version */
14391             int file_len = v_len + r_len + d_len + n_len + e_len;
14392             outbuf[file_len] = 0;
14393
14394             /* Downcase if input had any lower case letters and
14395              * case preservation is not in effect.
14396              */
14397             if (!decc_efs_case_preserve) {
14398                 for (cp = filespec; *cp; cp++)
14399                     if (islower(*cp)) { haslower = 1; break; }
14400
14401                 if (haslower) __mystrtolower(outbuf);
14402             }
14403         }
14404     }
14405     return outbuf;
14406 }
14407
14408
14409 /*}}}*/
14410 /* External entry points */
14411 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14412 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
14413
14414 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14415 { return do_vms_realname(filespec, outbuf, utf8_fl); }
14416
14417 /* case_tolerant */
14418
14419 /*{{{int do_vms_case_tolerant(void)*/
14420 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
14421  * controlled by a process setting.
14422  */
14423 int do_vms_case_tolerant(void)
14424 {
14425     return vms_process_case_tolerant;
14426 }
14427 /*}}}*/
14428 /* External entry points */
14429 #if __CRTL_VER >= 70301000 && !defined(__VAX)
14430 int Perl_vms_case_tolerant(void)
14431 { return do_vms_case_tolerant(); }
14432 #else
14433 int Perl_vms_case_tolerant(void)
14434 { return vms_process_case_tolerant; }
14435 #endif
14436
14437
14438  /* Start of DECC RTL Feature handling */
14439
14440 static int sys_trnlnm
14441    (const char * logname,
14442     char * value,
14443     int value_len)
14444 {
14445     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
14446     const unsigned long attr = LNM$M_CASE_BLIND;
14447     struct dsc$descriptor_s name_dsc;
14448     int status;
14449     unsigned short result;
14450     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
14451                                 {0, 0, 0, 0}};
14452
14453     name_dsc.dsc$w_length = strlen(logname);
14454     name_dsc.dsc$a_pointer = (char *)logname;
14455     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14456     name_dsc.dsc$b_class = DSC$K_CLASS_S;
14457
14458     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
14459
14460     if ($VMS_STATUS_SUCCESS(status)) {
14461
14462          /* Null terminate and return the string */
14463         /*--------------------------------------*/
14464         value[result] = 0;
14465     }
14466
14467     return status;
14468 }
14469
14470 static int sys_crelnm
14471    (const char * logname,
14472     const char * value)
14473 {
14474     int ret_val;
14475     const char * proc_table = "LNM$PROCESS_TABLE";
14476     struct dsc$descriptor_s proc_table_dsc;
14477     struct dsc$descriptor_s logname_dsc;
14478     struct itmlst_3 item_list[2];
14479
14480     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
14481     proc_table_dsc.dsc$w_length = strlen(proc_table);
14482     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14483     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
14484
14485     logname_dsc.dsc$a_pointer = (char *) logname;
14486     logname_dsc.dsc$w_length = strlen(logname);
14487     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14488     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
14489
14490     item_list[0].buflen = strlen(value);
14491     item_list[0].itmcode = LNM$_STRING;
14492     item_list[0].bufadr = (char *)value;
14493     item_list[0].retlen = NULL;
14494
14495     item_list[1].buflen = 0;
14496     item_list[1].itmcode = 0;
14497
14498     ret_val = sys$crelnm
14499                        (NULL,
14500                         (const struct dsc$descriptor_s *)&proc_table_dsc,
14501                         (const struct dsc$descriptor_s *)&logname_dsc,
14502                         NULL,
14503                         (const struct item_list_3 *) item_list);
14504
14505     return ret_val;
14506 }
14507
14508 /* C RTL Feature settings */
14509
14510 static int set_features
14511    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
14512     int (* cli_routine)(void),  /* Not documented */
14513     void *image_info)           /* Not documented */
14514 {
14515     int status;
14516     int s;
14517     char* str;
14518     char val_str[10];
14519 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
14520     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
14521     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
14522     unsigned long case_perm;
14523     unsigned long case_image;
14524 #endif
14525
14526     /* Allow an exception to bring Perl into the VMS debugger */
14527     vms_debug_on_exception = 0;
14528     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
14529     if ($VMS_STATUS_SUCCESS(status)) {
14530        val_str[0] = _toupper(val_str[0]);
14531        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14532          vms_debug_on_exception = 1;
14533        else
14534          vms_debug_on_exception = 0;
14535     }
14536
14537     /* Debug unix/vms file translation routines */
14538     vms_debug_fileify = 0;
14539     status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14540     if ($VMS_STATUS_SUCCESS(status)) {
14541         val_str[0] = _toupper(val_str[0]);
14542         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14543             vms_debug_fileify = 1;
14544         else
14545             vms_debug_fileify = 0;
14546     }
14547
14548
14549     /* Historically PERL has been doing vmsify / stat differently than */
14550     /* the CRTL.  In particular, under some conditions the CRTL will   */
14551     /* remove some illegal characters like spaces from filenames       */
14552     /* resulting in some differences.  The stat()/lstat() wrapper has  */
14553     /* been reporting such file names as invalid and fails to stat them */
14554     /* fixing this bug so that stat()/lstat() accept these like the     */
14555     /* CRTL does will result in several tests failing.                  */
14556     /* This should really be fixed, but for now, set up a feature to    */
14557     /* enable it so that the impact can be studied.                     */
14558     vms_bug_stat_filename = 0;
14559     status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14560     if ($VMS_STATUS_SUCCESS(status)) {
14561         val_str[0] = _toupper(val_str[0]);
14562         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14563             vms_bug_stat_filename = 1;
14564         else
14565             vms_bug_stat_filename = 0;
14566     }
14567
14568
14569     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14570     vms_vtf7_filenames = 0;
14571     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14572     if ($VMS_STATUS_SUCCESS(status)) {
14573        val_str[0] = _toupper(val_str[0]);
14574        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14575          vms_vtf7_filenames = 1;
14576        else
14577          vms_vtf7_filenames = 0;
14578     }
14579
14580     /* unlink all versions on unlink() or rename() */
14581     vms_unlink_all_versions = 0;
14582     status = sys_trnlnm
14583         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14584     if ($VMS_STATUS_SUCCESS(status)) {
14585        val_str[0] = _toupper(val_str[0]);
14586        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14587          vms_unlink_all_versions = 1;
14588        else
14589          vms_unlink_all_versions = 0;
14590     }
14591
14592     /* Dectect running under GNV Bash or other UNIX like shell */
14593 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14594     gnv_unix_shell = 0;
14595     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14596     if ($VMS_STATUS_SUCCESS(status)) {
14597          gnv_unix_shell = 1;
14598          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14599          set_feature_default("DECC$EFS_CHARSET", 1);
14600          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14601          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14602          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14603          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14604          vms_unlink_all_versions = 1;
14605          vms_posix_exit = 1;
14606     }
14607 #endif
14608
14609     /* hacks to see if known bugs are still present for testing */
14610
14611     /* PCP mode requires creating /dev/null special device file */
14612     decc_bug_devnull = 0;
14613     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14614     if ($VMS_STATUS_SUCCESS(status)) {
14615        val_str[0] = _toupper(val_str[0]);
14616        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14617           decc_bug_devnull = 1;
14618        else
14619           decc_bug_devnull = 0;
14620     }
14621
14622     /* UNIX directory names with no paths are broken in a lot of places */
14623     decc_dir_barename = 1;
14624     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14625     if ($VMS_STATUS_SUCCESS(status)) {
14626       val_str[0] = _toupper(val_str[0]);
14627       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14628         decc_dir_barename = 1;
14629       else
14630         decc_dir_barename = 0;
14631     }
14632
14633 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14634     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14635     if (s >= 0) {
14636         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14637         if (decc_disable_to_vms_logname_translation < 0)
14638             decc_disable_to_vms_logname_translation = 0;
14639     }
14640
14641     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14642     if (s >= 0) {
14643         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14644         if (decc_efs_case_preserve < 0)
14645             decc_efs_case_preserve = 0;
14646     }
14647
14648     s = decc$feature_get_index("DECC$EFS_CHARSET");
14649     decc_efs_charset_index = s;
14650     if (s >= 0) {
14651         decc_efs_charset = decc$feature_get_value(s, 1);
14652         if (decc_efs_charset < 0)
14653             decc_efs_charset = 0;
14654     }
14655
14656     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14657     if (s >= 0) {
14658         decc_filename_unix_report = decc$feature_get_value(s, 1);
14659         if (decc_filename_unix_report > 0) {
14660             decc_filename_unix_report = 1;
14661             vms_posix_exit = 1;
14662         }
14663         else
14664             decc_filename_unix_report = 0;
14665     }
14666
14667     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14668     if (s >= 0) {
14669         decc_filename_unix_only = decc$feature_get_value(s, 1);
14670         if (decc_filename_unix_only > 0) {
14671             decc_filename_unix_only = 1;
14672         }
14673         else {
14674             decc_filename_unix_only = 0;
14675         }
14676     }
14677
14678     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14679     if (s >= 0) {
14680         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14681         if (decc_filename_unix_no_version < 0)
14682             decc_filename_unix_no_version = 0;
14683     }
14684
14685     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14686     if (s >= 0) {
14687         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14688         if (decc_readdir_dropdotnotype < 0)
14689             decc_readdir_dropdotnotype = 0;
14690     }
14691
14692 #if __CRTL_VER >= 80200000
14693     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14694     if (s >= 0) {
14695         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14696         if (decc_posix_compliant_pathnames < 0)
14697             decc_posix_compliant_pathnames = 0;
14698         if (decc_posix_compliant_pathnames > 4)
14699             decc_posix_compliant_pathnames = 0;
14700     }
14701
14702 #endif
14703 #else
14704     status = sys_trnlnm
14705         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14706     if ($VMS_STATUS_SUCCESS(status)) {
14707         val_str[0] = _toupper(val_str[0]);
14708         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14709            decc_disable_to_vms_logname_translation = 1;
14710         }
14711     }
14712
14713 #ifndef __VAX
14714     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14715     if ($VMS_STATUS_SUCCESS(status)) {
14716         val_str[0] = _toupper(val_str[0]);
14717         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14718            decc_efs_case_preserve = 1;
14719         }
14720     }
14721 #endif
14722
14723     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14724     if ($VMS_STATUS_SUCCESS(status)) {
14725         val_str[0] = _toupper(val_str[0]);
14726         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14727            decc_filename_unix_report = 1;
14728         }
14729     }
14730     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14731     if ($VMS_STATUS_SUCCESS(status)) {
14732         val_str[0] = _toupper(val_str[0]);
14733         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14734            decc_filename_unix_only = 1;
14735            decc_filename_unix_report = 1;
14736         }
14737     }
14738     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14739     if ($VMS_STATUS_SUCCESS(status)) {
14740         val_str[0] = _toupper(val_str[0]);
14741         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14742            decc_filename_unix_no_version = 1;
14743         }
14744     }
14745     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14746     if ($VMS_STATUS_SUCCESS(status)) {
14747         val_str[0] = _toupper(val_str[0]);
14748         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14749            decc_readdir_dropdotnotype = 1;
14750         }
14751     }
14752 #endif
14753
14754 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14755
14756      /* Report true case tolerance */
14757     /*----------------------------*/
14758     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14759     if (!$VMS_STATUS_SUCCESS(status))
14760         case_perm = PPROP$K_CASE_BLIND;
14761     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14762     if (!$VMS_STATUS_SUCCESS(status))
14763         case_image = PPROP$K_CASE_BLIND;
14764     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14765         (case_image == PPROP$K_CASE_SENSITIVE))
14766         vms_process_case_tolerant = 0;
14767
14768 #endif
14769
14770     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14771     /* for strict backward compatibilty */
14772     status = sys_trnlnm
14773         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14774     if ($VMS_STATUS_SUCCESS(status)) {
14775        val_str[0] = _toupper(val_str[0]);
14776        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14777          vms_posix_exit = 1;
14778        else
14779          vms_posix_exit = 0;
14780     }
14781
14782
14783     /* CRTL can be initialized past this point, but not before. */
14784 /*    DECC$CRTL_INIT(); */
14785
14786     return SS$_NORMAL;
14787 }
14788
14789 #ifdef __DECC
14790 #pragma nostandard
14791 #pragma extern_model save
14792 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14793         const __align (LONGWORD) int spare[8] = {0};
14794
14795 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14796 #if __DECC_VER >= 60560002
14797 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14798 #else
14799 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14800 #endif
14801 #endif /* __DECC */
14802
14803 const long vms_cc_features = (const long)set_features;
14804
14805 /*
14806 ** Force a reference to LIB$INITIALIZE to ensure it
14807 ** exists in the image.
14808 */
14809 int lib$initialize(void);
14810 #ifdef __DECC
14811 #pragma extern_model strict_refdef
14812 #endif
14813     int lib_init_ref = (int) lib$initialize;
14814
14815 #ifdef __DECC
14816 #pragma extern_model restore
14817 #pragma standard
14818 #endif
14819
14820 /*  End of vms.c */