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
2068 /*{{{int do_rmdir(char *name)*/
2069 int
2070 Perl_do_rmdir(pTHX_ const char *name)
2071 {
2072     char * dirfile;
2073     int retval;
2074     Stat_t st;
2075
2076     /* lstat returns a VMS fileified specification of the name */
2077     /* that is looked up, and also lets verifies that this is a directory */
2078
2079     retval = Perl_flex_lstat(NULL, name, &st);
2080     if (retval != 0) {
2081         char * ret_spec;
2082
2083         /* Due to a historical feature, flex_stat/lstat can not see some */
2084         /* Unix format file names that the rest of the CRTL can see */
2085         /* Fixing that feature will cause some perl tests to fail */
2086         /* So try this one more time. */
2087
2088         retval = lstat(name, &st.crtl_stat);
2089         if (retval != 0)
2090             return -1;
2091
2092         /* force it to a file spec for the kill file to work. */
2093         ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
2094         if (ret_spec == NULL) {
2095             errno = EIO;
2096             return -1;
2097         }
2098     }
2099
2100     if (!S_ISDIR(st.st_mode)) {
2101         errno = ENOTDIR;
2102         retval = -1;
2103     }
2104     else {
2105         dirfile = st.st_devnam;
2106
2107         /* It may be possible for flex_stat to find a file and vmsify() to */
2108         /* fail with ODS-2 specifications.  mp_do_kill_file can not deal */
2109         /* with that case, so fail it */
2110         if (dirfile[0] == 0) {
2111             errno = EIO;
2112             return -1;
2113         }
2114
2115         retval = mp_do_kill_file(aTHX_ dirfile, 1);
2116     }
2117
2118     return retval;
2119
2120 }  /* end of do_rmdir */
2121 /*}}}*/
2122
2123 /* kill_file
2124  * Delete any file to which user has control access, regardless of whether
2125  * delete access is explicitly allowed.
2126  * Limitations: User must have write access to parent directory.
2127  *              Does not block signals or ASTs; if interrupted in midstream
2128  *              may leave file with an altered ACL.
2129  * HANDLE WITH CARE!
2130  */
2131 /*{{{int kill_file(char *name)*/
2132 int
2133 Perl_kill_file(pTHX_ const char *name)
2134 {
2135     char * vmsfile;
2136     Stat_t st;
2137     int rmsts;
2138
2139     /* Convert the filename to VMS format and see if it is a directory */
2140     /* flex_lstat returns a vmsified file specification */
2141     rmsts = Perl_flex_lstat(NULL, name, &st);
2142     if (rmsts != 0) {
2143
2144         /* Due to a historical feature, flex_stat/lstat can not see some */
2145         /* Unix format file names that the rest of the CRTL can see when */
2146         /* ODS-2 file specifications are in use. */
2147         /* Fixing that feature will cause some perl tests to fail */
2148         /* [.lib.ExtUtils.t]Manifest.t is one of them */
2149         st.st_mode = 0;
2150         vmsfile = (char *) name; /* cast ok */
2151
2152     } else {
2153         vmsfile = st.st_devnam;
2154         if (vmsfile[0] == 0) {
2155             /* It may be possible for flex_stat to find a file and vmsify() */
2156             /* to fail with ODS-2 specifications.  mp_do_kill_file can not */
2157             /* deal with that case, so fail it */
2158             errno = EIO;
2159             return -1;
2160         }
2161     }
2162
2163     /* Remove() is allowed to delete directories, according to the X/Open
2164      * specifications.
2165      * This may need special handling to work with the ACL hacks.
2166      */
2167     if (S_ISDIR(st.st_mode)) {
2168         rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2169         return rmsts;
2170     }
2171
2172     rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2173
2174     /* Need to delete all versions ? */
2175     if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2176         int i = 0;
2177
2178         /* Just use lstat() here as do not need st_dev */
2179         /* and we know that the file is in VMS format or that */
2180         /* because of a historical bug, flex_stat can not see the file */
2181         while (lstat(vmsfile, (stat_t *)&st) == 0) {
2182             rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2183             if (rmsts != 0)
2184                 break;
2185             i++;
2186
2187             /* Make sure that we do not loop forever */
2188             if (i > 32767) {
2189                 errno = EIO;
2190                 rmsts = -1;
2191                 break;
2192             }
2193         }
2194     }
2195
2196     return rmsts;
2197
2198 }  /* end of kill_file() */
2199 /*}}}*/
2200
2201
2202 /*{{{int my_mkdir(char *,Mode_t)*/
2203 int
2204 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2205 {
2206   STRLEN dirlen = strlen(dir);
2207
2208   /* zero length string sometimes gives ACCVIO */
2209   if (dirlen == 0) return -1;
2210
2211   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2212    * null file name/type.  However, it's commonplace under Unix,
2213    * so we'll allow it for a gain in portability.
2214    */
2215   if (dir[dirlen-1] == '/') {
2216     char *newdir = savepvn(dir,dirlen-1);
2217     int ret = mkdir(newdir,mode);
2218     Safefree(newdir);
2219     return ret;
2220   }
2221   else return mkdir(dir,mode);
2222 }  /* end of my_mkdir */
2223 /*}}}*/
2224
2225 /*{{{int my_chdir(char *)*/
2226 int
2227 Perl_my_chdir(pTHX_ const char *dir)
2228 {
2229   STRLEN dirlen = strlen(dir);
2230
2231   /* zero length string sometimes gives ACCVIO */
2232   if (dirlen == 0) return -1;
2233   const char *dir1;
2234
2235   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2236    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2237    * so that existing scripts do not need to be changed.
2238    */
2239   dir1 = dir;
2240   while ((dirlen > 0) && (*dir1 == ' ')) {
2241     dir1++;
2242     dirlen--;
2243   }
2244
2245   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2246    * that implies
2247    * null file name/type.  However, it's commonplace under Unix,
2248    * so we'll allow it for a gain in portability.
2249    *
2250    * - Preview- '/' will be valid soon on VMS
2251    */
2252   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2253     char *newdir = savepvn(dir1,dirlen-1);
2254     int ret = chdir(newdir);
2255     Safefree(newdir);
2256     return ret;
2257   }
2258   else return chdir(dir1);
2259 }  /* end of my_chdir */
2260 /*}}}*/
2261
2262
2263 /*{{{int my_chmod(char *, mode_t)*/
2264 int
2265 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2266 {
2267   STRLEN speclen = strlen(file_spec);
2268
2269   /* zero length string sometimes gives ACCVIO */
2270   if (speclen == 0) return -1;
2271
2272   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2273    * that implies null file name/type.  However, it's commonplace under Unix,
2274    * so we'll allow it for a gain in portability.
2275    *
2276    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2277    * in VMS file.dir notation.
2278    */
2279   if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2280     char *vms_src, *vms_dir, *rslt;
2281     int ret = -1;
2282     errno = EIO;
2283
2284     /* First convert this to a VMS format specification */
2285     vms_src = PerlMem_malloc(VMS_MAXRSS);
2286     if (vms_src == NULL)
2287         _ckvmssts_noperl(SS$_INSFMEM);
2288
2289     rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2290     if (rslt == NULL) {
2291         /* If we fail, then not a file specification */
2292         PerlMem_free(vms_src);
2293         errno = EIO;
2294         return -1;
2295     }
2296
2297     /* Now make it a directory spec so chmod is happy */
2298     vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2299     if (vms_dir == NULL)
2300         _ckvmssts_noperl(SS$_INSFMEM);
2301     rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2302     PerlMem_free(vms_src);
2303
2304     /* Now do it */
2305     if (rslt != NULL) {
2306         ret = chmod(vms_dir, mode);
2307     } else {
2308         errno = EIO;
2309     }
2310     PerlMem_free(vms_dir);
2311     return ret;
2312   }
2313   else return chmod(file_spec, mode);
2314 }  /* end of my_chmod */
2315 /*}}}*/
2316
2317
2318 /*{{{FILE *my_tmpfile()*/
2319 FILE *
2320 my_tmpfile(void)
2321 {
2322   FILE *fp;
2323   char *cp;
2324
2325   if ((fp = tmpfile())) return fp;
2326
2327   cp = PerlMem_malloc(L_tmpnam+24);
2328   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2329
2330   if (decc_filename_unix_only == 0)
2331     strcpy(cp,"Sys$Scratch:");
2332   else
2333     strcpy(cp,"/tmp/");
2334   tmpnam(cp+strlen(cp));
2335   strcat(cp,".Perltmp");
2336   fp = fopen(cp,"w+","fop=dlt");
2337   PerlMem_free(cp);
2338   return fp;
2339 }
2340 /*}}}*/
2341
2342
2343 #ifndef HOMEGROWN_POSIX_SIGNALS
2344 /*
2345  * The C RTL's sigaction fails to check for invalid signal numbers so we
2346  * help it out a bit.  The docs are correct, but the actual routine doesn't
2347  * do what the docs say it will.
2348  */
2349 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2350 int
2351 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2352                    struct sigaction* oact)
2353 {
2354   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2355         SETERRNO(EINVAL, SS$_INVARG);
2356         return -1;
2357   }
2358   return sigaction(sig, act, oact);
2359 }
2360 /*}}}*/
2361 #endif
2362
2363 #ifdef KILL_BY_SIGPRC
2364 #include <errnodef.h>
2365
2366 /* We implement our own kill() using the undocumented system service
2367    sys$sigprc for one of two reasons:
2368
2369    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2370    target process to do a sys$exit, which usually can't be handled
2371    gracefully...certainly not by Perl and the %SIG{} mechanism.
2372
2373    2.) If the kill() in the CRTL can't be called from a signal
2374    handler without disappearing into the ether, i.e., the signal
2375    it purportedly sends is never trapped. Still true as of VMS 7.3.
2376
2377    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2378    in the target process rather than calling sys$exit.
2379
2380    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2381    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2382    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2383    with condition codes C$_SIG0+nsig*8, catching the exception on the
2384    target process and resignaling with appropriate arguments.
2385
2386    But we don't have that VMS 7.0+ exception handler, so if you
2387    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2388
2389    Also note that SIGTERM is listed in the docs as being "unimplemented",
2390    yet always seems to be signaled with a VMS condition code of 4 (and
2391    correctly handled for that code).  So we hardwire it in.
2392
2393    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2394    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2395    than signalling with an unrecognized (and unhandled by CRTL) code.
2396 */
2397
2398 #define _MY_SIG_MAX 28
2399
2400 static unsigned int
2401 Perl_sig_to_vmscondition_int(int sig)
2402 {
2403     static unsigned int sig_code[_MY_SIG_MAX+1] =
2404     {
2405         0,                  /*  0 ZERO     */
2406         SS$_HANGUP,         /*  1 SIGHUP   */
2407         SS$_CONTROLC,       /*  2 SIGINT   */
2408         SS$_CONTROLY,       /*  3 SIGQUIT  */
2409         SS$_RADRMOD,        /*  4 SIGILL   */
2410         SS$_BREAK,          /*  5 SIGTRAP  */
2411         SS$_OPCCUS,         /*  6 SIGABRT  */
2412         SS$_COMPAT,         /*  7 SIGEMT   */
2413 #ifdef __VAX
2414         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2415 #else
2416         SS$_HPARITH,        /*  8 SIGFPE AXP */
2417 #endif
2418         SS$_ABORT,          /*  9 SIGKILL  */
2419         SS$_ACCVIO,         /* 10 SIGBUS   */
2420         SS$_ACCVIO,         /* 11 SIGSEGV  */
2421         SS$_BADPARAM,       /* 12 SIGSYS   */
2422         SS$_NOMBX,          /* 13 SIGPIPE  */
2423         SS$_ASTFLT,         /* 14 SIGALRM  */
2424         4,                  /* 15 SIGTERM  */
2425         0,                  /* 16 SIGUSR1  */
2426         0,                  /* 17 SIGUSR2  */
2427         0,                  /* 18 */
2428         0,                  /* 19 */
2429         0,                  /* 20 SIGCHLD  */
2430         0,                  /* 21 SIGCONT  */
2431         0,                  /* 22 SIGSTOP  */
2432         0,                  /* 23 SIGTSTP  */
2433         0,                  /* 24 SIGTTIN  */
2434         0,                  /* 25 SIGTTOU  */
2435         0,                  /* 26 */
2436         0,                  /* 27 */
2437         0                   /* 28 SIGWINCH  */
2438     };
2439
2440 #if __VMS_VER >= 60200000
2441     static int initted = 0;
2442     if (!initted) {
2443         initted = 1;
2444         sig_code[16] = C$_SIGUSR1;
2445         sig_code[17] = C$_SIGUSR2;
2446 #if __CRTL_VER >= 70000000
2447         sig_code[20] = C$_SIGCHLD;
2448 #endif
2449 #if __CRTL_VER >= 70300000
2450         sig_code[28] = C$_SIGWINCH;
2451 #endif
2452     }
2453 #endif
2454
2455     if (sig < _SIG_MIN) return 0;
2456     if (sig > _MY_SIG_MAX) return 0;
2457     return sig_code[sig];
2458 }
2459
2460 unsigned int
2461 Perl_sig_to_vmscondition(int sig)
2462 {
2463 #ifdef SS$_DEBUG
2464     if (vms_debug_on_exception != 0)
2465         lib$signal(SS$_DEBUG);
2466 #endif
2467     return Perl_sig_to_vmscondition_int(sig);
2468 }
2469
2470
2471 int
2472 Perl_my_kill(int pid, int sig)
2473 {
2474     dTHX;
2475     int iss;
2476     unsigned int code;
2477     int sys$sigprc(unsigned int *pidadr,
2478                      struct dsc$descriptor_s *prcname,
2479                      unsigned int code);
2480
2481      /* sig 0 means validate the PID */
2482     /*------------------------------*/
2483     if (sig == 0) {
2484         const unsigned long int jpicode = JPI$_PID;
2485         pid_t ret_pid;
2486         int status;
2487         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2488         if ($VMS_STATUS_SUCCESS(status))
2489            return 0;
2490         switch (status) {
2491         case SS$_NOSUCHNODE:
2492         case SS$_UNREACHABLE:
2493         case SS$_NONEXPR:
2494            errno = ESRCH;
2495            break;
2496         case SS$_NOPRIV:
2497            errno = EPERM;
2498            break;
2499         default:
2500            errno = EVMSERR;
2501         }
2502         vaxc$errno=status;
2503         return -1;
2504     }
2505
2506     code = Perl_sig_to_vmscondition_int(sig);
2507
2508     if (!code) {
2509         SETERRNO(EINVAL, SS$_BADPARAM);
2510         return -1;
2511     }
2512
2513     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2514      * signals are to be sent to multiple processes.
2515      *  pid = 0 - all processes in group except ones that the system exempts
2516      *  pid = -1 - all processes except ones that the system exempts
2517      *  pid = -n - all processes in group (abs(n)) except ...
2518      * For now, just report as not supported.
2519      */
2520
2521     if (pid <= 0) {
2522         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2523         return -1;
2524     }
2525
2526     iss = sys$sigprc((unsigned int *)&pid,0,code);
2527     if (iss&1) return 0;
2528
2529     switch (iss) {
2530       case SS$_NOPRIV:
2531         set_errno(EPERM);  break;
2532       case SS$_NONEXPR:
2533       case SS$_NOSUCHNODE:
2534       case SS$_UNREACHABLE:
2535         set_errno(ESRCH);  break;
2536       case SS$_INSFMEM:
2537         set_errno(ENOMEM); break;
2538       default:
2539         _ckvmssts_noperl(iss);
2540         set_errno(EVMSERR);
2541     }
2542     set_vaxc_errno(iss);
2543
2544     return -1;
2545 }
2546 #endif
2547
2548 /* Routine to convert a VMS status code to a UNIX status code.
2549 ** More tricky than it appears because of conflicting conventions with
2550 ** existing code.
2551 **
2552 ** VMS status codes are a bit mask, with the least significant bit set for
2553 ** success.
2554 **
2555 ** Special UNIX status of EVMSERR indicates that no translation is currently
2556 ** available, and programs should check the VMS status code.
2557 **
2558 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2559 ** decoding.
2560 */
2561
2562 #ifndef C_FACILITY_NO
2563 #define C_FACILITY_NO 0x350000
2564 #endif
2565 #ifndef DCL_IVVERB
2566 #define DCL_IVVERB 0x38090
2567 #endif
2568
2569 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2570 {
2571 int facility;
2572 int fac_sp;
2573 int msg_no;
2574 int msg_status;
2575 int unix_status;
2576
2577   /* Assume the best or the worst */
2578   if (vms_status & STS$M_SUCCESS)
2579     unix_status = 0;
2580   else
2581     unix_status = EVMSERR;
2582
2583   msg_status = vms_status & ~STS$M_CONTROL;
2584
2585   facility = vms_status & STS$M_FAC_NO;
2586   fac_sp = vms_status & STS$M_FAC_SP;
2587   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2588
2589   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2590     switch(msg_no) {
2591     case SS$_NORMAL:
2592         unix_status = 0;
2593         break;
2594     case SS$_ACCVIO:
2595         unix_status = EFAULT;
2596         break;
2597     case SS$_DEVOFFLINE:
2598         unix_status = EBUSY;
2599         break;
2600     case SS$_CLEARED:
2601         unix_status = ENOTCONN;
2602         break;
2603     case SS$_IVCHAN:
2604     case SS$_IVLOGNAM:
2605     case SS$_BADPARAM:
2606     case SS$_IVLOGTAB:
2607     case SS$_NOLOGNAM:
2608     case SS$_NOLOGTAB:
2609     case SS$_INVFILFOROP:
2610     case SS$_INVARG:
2611     case SS$_NOSUCHID:
2612     case SS$_IVIDENT:
2613         unix_status = EINVAL;
2614         break;
2615     case SS$_UNSUPPORTED:
2616         unix_status = ENOTSUP;
2617         break;
2618     case SS$_FILACCERR:
2619     case SS$_NOGRPPRV:
2620     case SS$_NOSYSPRV:
2621         unix_status = EACCES;
2622         break;
2623     case SS$_DEVICEFULL:
2624         unix_status = ENOSPC;
2625         break;
2626     case SS$_NOSUCHDEV:
2627         unix_status = ENODEV;
2628         break;
2629     case SS$_NOSUCHFILE:
2630     case SS$_NOSUCHOBJECT:
2631         unix_status = ENOENT;
2632         break;
2633     case SS$_ABORT:                                 /* Fatal case */
2634     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2635     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2636         unix_status = EINTR;
2637         break;
2638     case SS$_BUFFEROVF:
2639         unix_status = E2BIG;
2640         break;
2641     case SS$_INSFMEM:
2642         unix_status = ENOMEM;
2643         break;
2644     case SS$_NOPRIV:
2645         unix_status = EPERM;
2646         break;
2647     case SS$_NOSUCHNODE:
2648     case SS$_UNREACHABLE:
2649         unix_status = ESRCH;
2650         break;
2651     case SS$_NONEXPR:
2652         unix_status = ECHILD;
2653         break;
2654     default:
2655         if ((facility == 0) && (msg_no < 8)) {
2656           /* These are not real VMS status codes so assume that they are
2657           ** already UNIX status codes
2658           */
2659           unix_status = msg_no;
2660           break;
2661         }
2662     }
2663   }
2664   else {
2665     /* Translate a POSIX exit code to a UNIX exit code */
2666     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2667         unix_status = (msg_no & 0x07F8) >> 3;
2668     }
2669     else {
2670
2671          /* Documented traditional behavior for handling VMS child exits */
2672         /*--------------------------------------------------------------*/
2673         if (child_flag != 0) {
2674
2675              /* Success / Informational return 0 */
2676             /*----------------------------------*/
2677             if (msg_no & STS$K_SUCCESS)
2678                 return 0;
2679
2680              /* Warning returns 1 */
2681             /*-------------------*/
2682             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2683                 return 1;
2684
2685              /* Everything else pass through the severity bits */
2686             /*------------------------------------------------*/
2687             return (msg_no & STS$M_SEVERITY);
2688         }
2689
2690          /* Normal VMS status to ERRNO mapping attempt */
2691         /*--------------------------------------------*/
2692         switch(msg_status) {
2693         /* case RMS$_EOF: */ /* End of File */
2694         case RMS$_FNF:  /* File Not Found */
2695         case RMS$_DNF:  /* Dir Not Found */
2696                 unix_status = ENOENT;
2697                 break;
2698         case RMS$_RNF:  /* Record Not Found */
2699                 unix_status = ESRCH;
2700                 break;
2701         case RMS$_DIR:
2702                 unix_status = ENOTDIR;
2703                 break;
2704         case RMS$_DEV:
2705                 unix_status = ENODEV;
2706                 break;
2707         case RMS$_IFI:
2708         case RMS$_FAC:
2709         case RMS$_ISI:
2710                 unix_status = EBADF;
2711                 break;
2712         case RMS$_FEX:
2713                 unix_status = EEXIST;
2714                 break;
2715         case RMS$_SYN:
2716         case RMS$_FNM:
2717         case LIB$_INVSTRDES:
2718         case LIB$_INVARG:
2719         case LIB$_NOSUCHSYM:
2720         case LIB$_INVSYMNAM:
2721         case DCL_IVVERB:
2722                 unix_status = EINVAL;
2723                 break;
2724         case CLI$_BUFOVF:
2725         case RMS$_RTB:
2726         case CLI$_TKNOVF:
2727         case CLI$_RSLOVF:
2728                 unix_status = E2BIG;
2729                 break;
2730         case RMS$_PRV:  /* No privilege */
2731         case RMS$_ACC:  /* ACP file access failed */
2732         case RMS$_WLK:  /* Device write locked */
2733                 unix_status = EACCES;
2734                 break;
2735         case RMS$_MKD:  /* Failed to mark for delete */
2736                 unix_status = EPERM;
2737                 break;
2738         /* case RMS$_NMF: */  /* No more files */
2739         }
2740     }
2741   }
2742
2743   return unix_status;
2744 }
2745
2746 /* Try to guess at what VMS error status should go with a UNIX errno
2747  * value.  This is hard to do as there could be many possible VMS
2748  * error statuses that caused the errno value to be set.
2749  */
2750
2751 int Perl_unix_status_to_vms(int unix_status)
2752 {
2753 int test_unix_status;
2754
2755      /* Trivial cases first */
2756     /*---------------------*/
2757     if (unix_status == EVMSERR)
2758         return vaxc$errno;
2759
2760      /* Is vaxc$errno sane? */
2761     /*---------------------*/
2762     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2763     if (test_unix_status == unix_status)
2764         return vaxc$errno;
2765
2766      /* If way out of range, must be VMS code already */
2767     /*-----------------------------------------------*/
2768     if (unix_status > EVMSERR)
2769         return unix_status;
2770
2771      /* If out of range, punt */
2772     /*-----------------------*/
2773     if (unix_status > __ERRNO_MAX)
2774         return SS$_ABORT;
2775
2776
2777      /* Ok, now we have to do it the hard way. */
2778     /*----------------------------------------*/
2779     switch(unix_status) {
2780     case 0:     return SS$_NORMAL;
2781     case EPERM: return SS$_NOPRIV;
2782     case ENOENT: return SS$_NOSUCHOBJECT;
2783     case ESRCH: return SS$_UNREACHABLE;
2784     case EINTR: return SS$_ABORT;
2785     /* case EIO: */
2786     /* case ENXIO:  */
2787     case E2BIG: return SS$_BUFFEROVF;
2788     /* case ENOEXEC */
2789     case EBADF: return RMS$_IFI;
2790     case ECHILD: return SS$_NONEXPR;
2791     /* case EAGAIN */
2792     case ENOMEM: return SS$_INSFMEM;
2793     case EACCES: return SS$_FILACCERR;
2794     case EFAULT: return SS$_ACCVIO;
2795     /* case ENOTBLK */
2796     case EBUSY: return SS$_DEVOFFLINE;
2797     case EEXIST: return RMS$_FEX;
2798     /* case EXDEV */
2799     case ENODEV: return SS$_NOSUCHDEV;
2800     case ENOTDIR: return RMS$_DIR;
2801     /* case EISDIR */
2802     case EINVAL: return SS$_INVARG;
2803     /* case ENFILE */
2804     /* case EMFILE */
2805     /* case ENOTTY */
2806     /* case ETXTBSY */
2807     /* case EFBIG */
2808     case ENOSPC: return SS$_DEVICEFULL;
2809     case ESPIPE: return LIB$_INVARG;
2810     /* case EROFS: */
2811     /* case EMLINK: */
2812     /* case EPIPE: */
2813     /* case EDOM */
2814     case ERANGE: return LIB$_INVARG;
2815     /* case EWOULDBLOCK */
2816     /* case EINPROGRESS */
2817     /* case EALREADY */
2818     /* case ENOTSOCK */
2819     /* case EDESTADDRREQ */
2820     /* case EMSGSIZE */
2821     /* case EPROTOTYPE */
2822     /* case ENOPROTOOPT */
2823     /* case EPROTONOSUPPORT */
2824     /* case ESOCKTNOSUPPORT */
2825     /* case EOPNOTSUPP */
2826     /* case EPFNOSUPPORT */
2827     /* case EAFNOSUPPORT */
2828     /* case EADDRINUSE */
2829     /* case EADDRNOTAVAIL */
2830     /* case ENETDOWN */
2831     /* case ENETUNREACH */
2832     /* case ENETRESET */
2833     /* case ECONNABORTED */
2834     /* case ECONNRESET */
2835     /* case ENOBUFS */
2836     /* case EISCONN */
2837     case ENOTCONN: return SS$_CLEARED;
2838     /* case ESHUTDOWN */
2839     /* case ETOOMANYREFS */
2840     /* case ETIMEDOUT */
2841     /* case ECONNREFUSED */
2842     /* case ELOOP */
2843     /* case ENAMETOOLONG */
2844     /* case EHOSTDOWN */
2845     /* case EHOSTUNREACH */
2846     /* case ENOTEMPTY */
2847     /* case EPROCLIM */
2848     /* case EUSERS  */
2849     /* case EDQUOT  */
2850     /* case ENOMSG  */
2851     /* case EIDRM */
2852     /* case EALIGN */
2853     /* case ESTALE */
2854     /* case EREMOTE */
2855     /* case ENOLCK */
2856     /* case ENOSYS */
2857     /* case EFTYPE */
2858     /* case ECANCELED */
2859     /* case EFAIL */
2860     /* case EINPROG */
2861     case ENOTSUP:
2862         return SS$_UNSUPPORTED;
2863     /* case EDEADLK */
2864     /* case ENWAIT */
2865     /* case EILSEQ */
2866     /* case EBADCAT */
2867     /* case EBADMSG */
2868     /* case EABANDONED */
2869     default:
2870         return SS$_ABORT; /* punt */
2871     }
2872
2873   return SS$_ABORT; /* Should not get here */
2874 }
2875
2876
2877 /* default piping mailbox size */
2878 #define PERL_BUFSIZ        512
2879
2880
2881 static void
2882 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2883 {
2884   unsigned long int mbxbufsiz;
2885   static unsigned long int syssize = 0;
2886   unsigned long int dviitm = DVI$_DEVNAM;
2887   char csize[LNM$C_NAMLENGTH+1];
2888   int sts;
2889
2890   if (!syssize) {
2891     unsigned long syiitm = SYI$_MAXBUF;
2892     /*
2893      * Get the SYSGEN parameter MAXBUF
2894      *
2895      * If the logical 'PERL_MBX_SIZE' is defined
2896      * use the value of the logical instead of PERL_BUFSIZ, but
2897      * keep the size between 128 and MAXBUF.
2898      *
2899      */
2900     _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2901   }
2902
2903   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2904       mbxbufsiz = atoi(csize);
2905   } else {
2906       mbxbufsiz = PERL_BUFSIZ;
2907   }
2908   if (mbxbufsiz < 128) mbxbufsiz = 128;
2909   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2910
2911   _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2912
2913   sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2914   _ckvmssts_noperl(sts);
2915   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2916
2917 }  /* end of create_mbx() */
2918
2919
2920 /*{{{  my_popen and my_pclose*/
2921
2922 typedef struct _iosb           IOSB;
2923 typedef struct _iosb*         pIOSB;
2924 typedef struct _pipe           Pipe;
2925 typedef struct _pipe*         pPipe;
2926 typedef struct pipe_details    Info;
2927 typedef struct pipe_details*  pInfo;
2928 typedef struct _srqp            RQE;
2929 typedef struct _srqp*          pRQE;
2930 typedef struct _tochildbuf      CBuf;
2931 typedef struct _tochildbuf*    pCBuf;
2932
2933 struct _iosb {
2934     unsigned short status;
2935     unsigned short count;
2936     unsigned long  dvispec;
2937 };
2938
2939 #pragma member_alignment save
2940 #pragma nomember_alignment quadword
2941 struct _srqp {          /* VMS self-relative queue entry */
2942     unsigned long qptr[2];
2943 };
2944 #pragma member_alignment restore
2945 static RQE  RQE_ZERO = {0,0};
2946
2947 struct _tochildbuf {
2948     RQE             q;
2949     int             eof;
2950     unsigned short  size;
2951     char            *buf;
2952 };
2953
2954 struct _pipe {
2955     RQE            free;
2956     RQE            wait;
2957     int            fd_out;
2958     unsigned short chan_in;
2959     unsigned short chan_out;
2960     char          *buf;
2961     unsigned int   bufsize;
2962     IOSB           iosb;
2963     IOSB           iosb2;
2964     int           *pipe_done;
2965     int            retry;
2966     int            type;
2967     int            shut_on_empty;
2968     int            need_wake;
2969     pPipe         *home;
2970     pInfo          info;
2971     pCBuf          curr;
2972     pCBuf          curr2;
2973 #if defined(PERL_IMPLICIT_CONTEXT)
2974     void            *thx;           /* Either a thread or an interpreter */
2975                                     /* pointer, depending on how we're built */
2976 #endif
2977 };
2978
2979
2980 struct pipe_details
2981 {
2982     pInfo           next;
2983     PerlIO *fp;  /* file pointer to pipe mailbox */
2984     int useFILE; /* using stdio, not perlio */
2985     int pid;   /* PID of subprocess */
2986     int mode;  /* == 'r' if pipe open for reading */
2987     int done;  /* subprocess has completed */
2988     int waiting; /* waiting for completion/closure */
2989     int             closing;        /* my_pclose is closing this pipe */
2990     unsigned long   completion;     /* termination status of subprocess */
2991     pPipe           in;             /* pipe in to sub */
2992     pPipe           out;            /* pipe out of sub */
2993     pPipe           err;            /* pipe of sub's sys$error */
2994     int             in_done;        /* true when in pipe finished */
2995     int             out_done;
2996     int             err_done;
2997     unsigned short  xchan;          /* channel to debug xterm */
2998     unsigned short  xchan_valid;    /* channel is assigned */
2999 };
3000
3001 struct exit_control_block
3002 {
3003     struct exit_control_block *flink;
3004     unsigned long int   (*exit_routine)();
3005     unsigned long int arg_count;
3006     unsigned long int *status_address;
3007     unsigned long int exit_status;
3008 };
3009
3010 typedef struct _closed_pipes    Xpipe;
3011 typedef struct _closed_pipes*  pXpipe;
3012
3013 struct _closed_pipes {
3014     int             pid;            /* PID of subprocess */
3015     unsigned long   completion;     /* termination status of subprocess */
3016 };
3017 #define NKEEPCLOSED 50
3018 static Xpipe closed_list[NKEEPCLOSED];
3019 static int   closed_index = 0;
3020 static int   closed_num = 0;
3021
3022 #define RETRY_DELAY     "0 ::0.20"
3023 #define MAX_RETRY              50
3024
3025 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
3026 static unsigned long mypid;
3027 static unsigned long delaytime[2];
3028
3029 static pInfo open_pipes = NULL;
3030 static $DESCRIPTOR(nl_desc, "NL:");
3031
3032 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
3033
3034
3035
3036 static unsigned long int
3037 pipe_exit_routine()
3038 {
3039     pInfo info;
3040     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
3041     int sts, did_stuff, need_eof, j;
3042
3043    /*
3044     * Flush any pending i/o, but since we are in process run-down, be
3045     * careful about referencing PerlIO structures that may already have
3046     * been deallocated.  We may not even have an interpreter anymore.
3047     */
3048     info = open_pipes;
3049     while (info) {
3050         if (info->fp) {
3051 #if defined(PERL_IMPLICIT_CONTEXT)
3052            /* We need to use the Perl context of the thread that created */
3053            /* the pipe. */
3054            pTHX;
3055            if (info->err)
3056                aTHX = info->err->thx;
3057            else if (info->out)
3058                aTHX = info->out->thx;
3059            else if (info->in)
3060                aTHX = info->in->thx;
3061 #endif
3062            if (!info->useFILE
3063 #if defined(USE_ITHREADS)
3064              && my_perl
3065 #endif
3066              && PL_perlio_fd_refcnt)
3067                PerlIO_flush(info->fp);
3068            else
3069                fflush((FILE *)info->fp);
3070         }
3071         info = info->next;
3072     }
3073
3074     /*
3075      next we try sending an EOF...ignore if doesn't work, make sure we
3076      don't hang
3077     */
3078     did_stuff = 0;
3079     info = open_pipes;
3080
3081     while (info) {
3082       int need_eof;
3083       _ckvmssts_noperl(sys$setast(0));
3084       if (info->in && !info->in->shut_on_empty) {
3085         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3086                                  0, 0, 0, 0, 0, 0));
3087         info->waiting = 1;
3088         did_stuff = 1;
3089       }
3090       _ckvmssts_noperl(sys$setast(1));
3091       info = info->next;
3092     }
3093
3094     /* wait for EOF to have effect, up to ~ 30 sec [default] */
3095
3096     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3097         int nwait = 0;
3098
3099         info = open_pipes;
3100         while (info) {
3101           _ckvmssts_noperl(sys$setast(0));
3102           if (info->waiting && info->done)
3103                 info->waiting = 0;
3104           nwait += info->waiting;
3105           _ckvmssts_noperl(sys$setast(1));
3106           info = info->next;
3107         }
3108         if (!nwait) break;
3109         sleep(1);
3110     }
3111
3112     did_stuff = 0;
3113     info = open_pipes;
3114     while (info) {
3115       _ckvmssts_noperl(sys$setast(0));
3116       if (!info->done) { /* Tap them gently on the shoulder . . .*/
3117         sts = sys$forcex(&info->pid,0,&abort);
3118         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3119         did_stuff = 1;
3120       }
3121       _ckvmssts_noperl(sys$setast(1));
3122       info = info->next;
3123     }
3124
3125     /* again, wait for effect */
3126
3127     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3128         int nwait = 0;
3129
3130         info = open_pipes;
3131         while (info) {
3132           _ckvmssts_noperl(sys$setast(0));
3133           if (info->waiting && info->done)
3134                 info->waiting = 0;
3135           nwait += info->waiting;
3136           _ckvmssts_noperl(sys$setast(1));
3137           info = info->next;
3138         }
3139         if (!nwait) break;
3140         sleep(1);
3141     }
3142
3143     info = open_pipes;
3144     while (info) {
3145       _ckvmssts_noperl(sys$setast(0));
3146       if (!info->done) {  /* We tried to be nice . . . */
3147         sts = sys$delprc(&info->pid,0);
3148         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3149         info->done = 1;  /* sys$delprc is as done as we're going to get. */
3150       }
3151       _ckvmssts_noperl(sys$setast(1));
3152       info = info->next;
3153     }
3154
3155     while(open_pipes) {
3156
3157 #if defined(PERL_IMPLICIT_CONTEXT)
3158       /* We need to use the Perl context of the thread that created */
3159       /* the pipe. */
3160       pTHX;
3161       if (open_pipes->err)
3162           aTHX = open_pipes->err->thx;
3163       else if (open_pipes->out)
3164           aTHX = open_pipes->out->thx;
3165       else if (open_pipes->in)
3166           aTHX = open_pipes->in->thx;
3167 #endif
3168       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3169       else if (!(sts & 1)) retsts = sts;
3170     }
3171     return retsts;
3172 }
3173
3174 static struct exit_control_block pipe_exitblock =
3175        {(struct exit_control_block *) 0,
3176         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3177
3178 static void pipe_mbxtofd_ast(pPipe p);
3179 static void pipe_tochild1_ast(pPipe p);
3180 static void pipe_tochild2_ast(pPipe p);
3181
3182 static void
3183 popen_completion_ast(pInfo info)
3184 {
3185   pInfo i = open_pipes;
3186   int iss;
3187   int sts;
3188   pXpipe x;
3189
3190   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3191   closed_list[closed_index].pid = info->pid;
3192   closed_list[closed_index].completion = info->completion;
3193   closed_index++;
3194   if (closed_index == NKEEPCLOSED)
3195     closed_index = 0;
3196   closed_num++;
3197
3198   while (i) {
3199     if (i == info) break;
3200     i = i->next;
3201   }
3202   if (!i) return;       /* unlinked, probably freed too */
3203
3204   info->done = TRUE;
3205
3206 /*
3207     Writing to subprocess ...
3208             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3209
3210             chan_out may be waiting for "done" flag, or hung waiting
3211             for i/o completion to child...cancel the i/o.  This will
3212             put it into "snarf mode" (done but no EOF yet) that discards
3213             input.
3214
3215     Output from subprocess (stdout, stderr) needs to be flushed and
3216     shut down.   We try sending an EOF, but if the mbx is full the pipe
3217     routine should still catch the "shut_on_empty" flag, telling it to
3218     use immediate-style reads so that "mbx empty" -> EOF.
3219
3220
3221 */
3222   if (info->in && !info->in_done) {               /* only for mode=w */
3223         if (info->in->shut_on_empty && info->in->need_wake) {
3224             info->in->need_wake = FALSE;
3225             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3226         } else {
3227             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3228         }
3229   }
3230
3231   if (info->out && !info->out_done) {             /* were we also piping output? */
3232       info->out->shut_on_empty = TRUE;
3233       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3234       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3235       _ckvmssts_noperl(iss);
3236   }
3237
3238   if (info->err && !info->err_done) {        /* we were piping stderr */
3239         info->err->shut_on_empty = TRUE;
3240         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3241         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3242         _ckvmssts_noperl(iss);
3243   }
3244   _ckvmssts_noperl(sys$setef(pipe_ef));
3245
3246 }
3247
3248 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3249 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3250
3251 /*
3252     we actually differ from vmstrnenv since we use this to
3253     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3254     are pointing to the same thing
3255 */
3256
3257 static unsigned short
3258 popen_translate(pTHX_ char *logical, char *result)
3259 {
3260     int iss;
3261     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3262     $DESCRIPTOR(d_log,"");
3263     struct _il3 {
3264         unsigned short length;
3265         unsigned short code;
3266         char *         buffer_addr;
3267         unsigned short *retlenaddr;
3268     } itmlst[2];
3269     unsigned short l, ifi;
3270
3271     d_log.dsc$a_pointer = logical;
3272     d_log.dsc$w_length  = strlen(logical);
3273
3274     itmlst[0].code = LNM$_STRING;
3275     itmlst[0].length = 255;
3276     itmlst[0].buffer_addr = result;
3277     itmlst[0].retlenaddr = &l;
3278
3279     itmlst[1].code = 0;
3280     itmlst[1].length = 0;
3281     itmlst[1].buffer_addr = 0;
3282     itmlst[1].retlenaddr = 0;
3283
3284     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3285     if (iss == SS$_NOLOGNAM) {
3286         iss = SS$_NORMAL;
3287         l = 0;
3288     }
3289     if (!(iss&1)) lib$signal(iss);
3290     result[l] = '\0';
3291 /*
3292     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3293     strip it off and return the ifi, if any
3294 */
3295     ifi  = 0;
3296     if (result[0] == 0x1b && result[1] == 0x00) {
3297         memmove(&ifi,result+2,2);
3298         strcpy(result,result+4);
3299     }
3300     return ifi;     /* this is the RMS internal file id */
3301 }
3302
3303 static void pipe_infromchild_ast(pPipe p);
3304
3305 /*
3306     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3307     inside an AST routine without worrying about reentrancy and which Perl
3308     memory allocator is being used.
3309
3310     We read data and queue up the buffers, then spit them out one at a
3311     time to the output mailbox when the output mailbox is ready for one.
3312
3313 */
3314 #define INITIAL_TOCHILDQUEUE  2
3315
3316 static pPipe
3317 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3318 {
3319     pPipe p;
3320     pCBuf b;
3321     char mbx1[64], mbx2[64];
3322     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3323                                       DSC$K_CLASS_S, mbx1},
3324                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3325                                       DSC$K_CLASS_S, mbx2};
3326     unsigned int dviitm = DVI$_DEVBUFSIZ;
3327     int j, n;
3328
3329     n = sizeof(Pipe);
3330     _ckvmssts_noperl(lib$get_vm(&n, &p));
3331
3332     create_mbx(&p->chan_in , &d_mbx1);
3333     create_mbx(&p->chan_out, &d_mbx2);
3334     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3335
3336     p->buf           = 0;
3337     p->shut_on_empty = FALSE;
3338     p->need_wake     = FALSE;
3339     p->type          = 0;
3340     p->retry         = 0;
3341     p->iosb.status   = SS$_NORMAL;
3342     p->iosb2.status  = SS$_NORMAL;
3343     p->free          = RQE_ZERO;
3344     p->wait          = RQE_ZERO;
3345     p->curr          = 0;
3346     p->curr2         = 0;
3347     p->info          = 0;
3348 #ifdef PERL_IMPLICIT_CONTEXT
3349     p->thx           = aTHX;
3350 #endif
3351
3352     n = sizeof(CBuf) + p->bufsize;
3353
3354     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3355         _ckvmssts_noperl(lib$get_vm(&n, &b));
3356         b->buf = (char *) b + sizeof(CBuf);
3357         _ckvmssts_noperl(lib$insqhi(b, &p->free));
3358     }
3359
3360     pipe_tochild2_ast(p);
3361     pipe_tochild1_ast(p);
3362     strcpy(wmbx, mbx1);
3363     strcpy(rmbx, mbx2);
3364     return p;
3365 }
3366
3367 /*  reads the MBX Perl is writing, and queues */
3368
3369 static void
3370 pipe_tochild1_ast(pPipe p)
3371 {
3372     pCBuf b = p->curr;
3373     int iss = p->iosb.status;
3374     int eof = (iss == SS$_ENDOFFILE);
3375     int sts;
3376 #ifdef PERL_IMPLICIT_CONTEXT
3377     pTHX = p->thx;
3378 #endif
3379
3380     if (p->retry) {
3381         if (eof) {
3382             p->shut_on_empty = TRUE;
3383             b->eof     = TRUE;
3384             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3385         } else  {
3386             _ckvmssts_noperl(iss);
3387         }
3388
3389         b->eof  = eof;
3390         b->size = p->iosb.count;
3391         _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3392         if (p->need_wake) {
3393             p->need_wake = FALSE;
3394             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3395         }
3396     } else {
3397         p->retry = 1;   /* initial call */
3398     }
3399
3400     if (eof) {                  /* flush the free queue, return when done */
3401         int n = sizeof(CBuf) + p->bufsize;
3402         while (1) {
3403             iss = lib$remqti(&p->free, &b);
3404             if (iss == LIB$_QUEWASEMP) return;
3405             _ckvmssts_noperl(iss);
3406             _ckvmssts_noperl(lib$free_vm(&n, &b));
3407         }
3408     }
3409
3410     iss = lib$remqti(&p->free, &b);
3411     if (iss == LIB$_QUEWASEMP) {
3412         int n = sizeof(CBuf) + p->bufsize;
3413         _ckvmssts_noperl(lib$get_vm(&n, &b));
3414         b->buf = (char *) b + sizeof(CBuf);
3415     } else {
3416        _ckvmssts_noperl(iss);
3417     }
3418
3419     p->curr = b;
3420     iss = sys$qio(0,p->chan_in,
3421              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3422              &p->iosb,
3423              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3424     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3425     _ckvmssts_noperl(iss);
3426 }
3427
3428
3429 /* writes queued buffers to output, waits for each to complete before
3430    doing the next */
3431
3432 static void
3433 pipe_tochild2_ast(pPipe p)
3434 {
3435     pCBuf b = p->curr2;
3436     int iss = p->iosb2.status;
3437     int n = sizeof(CBuf) + p->bufsize;
3438     int done = (p->info && p->info->done) ||
3439               iss == SS$_CANCEL || iss == SS$_ABORT;
3440 #if defined(PERL_IMPLICIT_CONTEXT)
3441     pTHX = p->thx;
3442 #endif
3443
3444     do {
3445         if (p->type) {         /* type=1 has old buffer, dispose */
3446             if (p->shut_on_empty) {
3447                 _ckvmssts_noperl(lib$free_vm(&n, &b));
3448             } else {
3449                 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3450             }
3451             p->type = 0;
3452         }
3453
3454         iss = lib$remqti(&p->wait, &b);
3455         if (iss == LIB$_QUEWASEMP) {
3456             if (p->shut_on_empty) {
3457                 if (done) {
3458                     _ckvmssts_noperl(sys$dassgn(p->chan_out));
3459                     *p->pipe_done = TRUE;
3460                     _ckvmssts_noperl(sys$setef(pipe_ef));
3461                 } else {
3462                     _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3463                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3464                 }
3465                 return;
3466             }
3467             p->need_wake = TRUE;
3468             return;
3469         }
3470         _ckvmssts_noperl(iss);
3471         p->type = 1;
3472     } while (done);
3473
3474
3475     p->curr2 = b;
3476     if (b->eof) {
3477         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3478             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3479     } else {
3480         _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3481             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3482     }
3483
3484     return;
3485
3486 }
3487
3488
3489 static pPipe
3490 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3491 {
3492     pPipe p;
3493     char mbx1[64], mbx2[64];
3494     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3495                                       DSC$K_CLASS_S, mbx1},
3496                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3497                                       DSC$K_CLASS_S, mbx2};
3498     unsigned int dviitm = DVI$_DEVBUFSIZ;
3499
3500     int n = sizeof(Pipe);
3501     _ckvmssts_noperl(lib$get_vm(&n, &p));
3502     create_mbx(&p->chan_in , &d_mbx1);
3503     create_mbx(&p->chan_out, &d_mbx2);
3504
3505     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3506     n = p->bufsize * sizeof(char);
3507     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3508     p->shut_on_empty = FALSE;
3509     p->info   = 0;
3510     p->type   = 0;
3511     p->iosb.status = SS$_NORMAL;
3512 #if defined(PERL_IMPLICIT_CONTEXT)
3513     p->thx = aTHX;
3514 #endif
3515     pipe_infromchild_ast(p);
3516
3517     strcpy(wmbx, mbx1);
3518     strcpy(rmbx, mbx2);
3519     return p;
3520 }
3521
3522 static void
3523 pipe_infromchild_ast(pPipe p)
3524 {
3525     int iss = p->iosb.status;
3526     int eof = (iss == SS$_ENDOFFILE);
3527     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3528     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3529 #if defined(PERL_IMPLICIT_CONTEXT)
3530     pTHX = p->thx;
3531 #endif
3532
3533     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3534         _ckvmssts_noperl(sys$dassgn(p->chan_out));
3535         p->chan_out = 0;
3536     }
3537
3538     /* read completed:
3539             input shutdown if EOF from self (done or shut_on_empty)
3540             output shutdown if closing flag set (my_pclose)
3541             send data/eof from child or eof from self
3542             otherwise, re-read (snarf of data from child)
3543     */
3544
3545     if (p->type == 1) {
3546         p->type = 0;
3547         if (myeof && p->chan_in) {                  /* input shutdown */
3548             _ckvmssts_noperl(sys$dassgn(p->chan_in));
3549             p->chan_in = 0;
3550         }
3551
3552         if (p->chan_out) {
3553             if (myeof || kideof) {      /* pass EOF to parent */
3554                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3555                                          pipe_infromchild_ast, p,
3556                                          0, 0, 0, 0, 0, 0));
3557                 return;
3558             } else if (eof) {       /* eat EOF --- fall through to read*/
3559
3560             } else {                /* transmit data */
3561                 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3562                                          pipe_infromchild_ast,p,
3563                                          p->buf, p->iosb.count, 0, 0, 0, 0));
3564                 return;
3565             }
3566         }
3567     }
3568
3569     /*  everything shut? flag as done */
3570
3571     if (!p->chan_in && !p->chan_out) {
3572         *p->pipe_done = TRUE;
3573         _ckvmssts_noperl(sys$setef(pipe_ef));
3574         return;
3575     }
3576
3577     /* write completed (or read, if snarfing from child)
3578             if still have input active,
3579                queue read...immediate mode if shut_on_empty so we get EOF if empty
3580             otherwise,
3581                check if Perl reading, generate EOFs as needed
3582     */
3583
3584     if (p->type == 0) {
3585         p->type = 1;
3586         if (p->chan_in) {
3587             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3588                           pipe_infromchild_ast,p,
3589                           p->buf, p->bufsize, 0, 0, 0, 0);
3590             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3591             _ckvmssts_noperl(iss);
3592         } else {           /* send EOFs for extra reads */
3593             p->iosb.status = SS$_ENDOFFILE;
3594             p->iosb.dvispec = 0;
3595             _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3596                                      0, 0, 0,
3597                                      pipe_infromchild_ast, p, 0, 0, 0, 0));
3598         }
3599     }
3600 }
3601
3602 static pPipe
3603 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3604 {
3605     pPipe p;
3606     char mbx[64];
3607     unsigned long dviitm = DVI$_DEVBUFSIZ;
3608     struct stat s;
3609     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3610                                       DSC$K_CLASS_S, mbx};
3611     int n = sizeof(Pipe);
3612
3613     /* things like terminals and mbx's don't need this filter */
3614     if (fd && fstat(fd,&s) == 0) {
3615         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3616         char device[65];
3617         unsigned short dev_len;
3618         struct dsc$descriptor_s d_dev;
3619         char * cptr;
3620         struct item_list_3 items[3];
3621         int status;
3622         unsigned short dvi_iosb[4];
3623
3624         cptr = getname(fd, out, 1);
3625         if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3626         d_dev.dsc$a_pointer = out;
3627         d_dev.dsc$w_length = strlen(out);
3628         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3629         d_dev.dsc$b_class = DSC$K_CLASS_S;
3630
3631         items[0].len = 4;
3632         items[0].code = DVI$_DEVCHAR;
3633         items[0].bufadr = &devchar;
3634         items[0].retadr = NULL;
3635         items[1].len = 64;
3636         items[1].code = DVI$_FULLDEVNAM;
3637         items[1].bufadr = device;
3638         items[1].retadr = &dev_len;
3639         items[2].len = 0;
3640         items[2].code = 0;
3641
3642         status = sys$getdviw
3643                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3644         _ckvmssts_noperl(status);
3645         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3646             device[dev_len] = 0;
3647
3648             if (!(devchar & DEV$M_DIR)) {
3649                 strcpy(out, device);
3650                 return 0;
3651             }
3652         }
3653     }
3654
3655     _ckvmssts_noperl(lib$get_vm(&n, &p));
3656     p->fd_out = dup(fd);
3657     create_mbx(&p->chan_in, &d_mbx);
3658     _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3659     n = (p->bufsize+1) * sizeof(char);
3660     _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3661     p->shut_on_empty = FALSE;
3662     p->retry = 0;
3663     p->info  = 0;
3664     strcpy(out, mbx);
3665
3666     _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3667                              pipe_mbxtofd_ast, p,
3668                              p->buf, p->bufsize, 0, 0, 0, 0));
3669
3670     return p;
3671 }
3672
3673 static void
3674 pipe_mbxtofd_ast(pPipe p)
3675 {
3676     int iss = p->iosb.status;
3677     int done = p->info->done;
3678     int iss2;
3679     int eof = (iss == SS$_ENDOFFILE);
3680     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3681     int err = !(iss&1) && !eof;
3682 #if defined(PERL_IMPLICIT_CONTEXT)
3683     pTHX = p->thx;
3684 #endif
3685
3686     if (done && myeof) {               /* end piping */
3687         close(p->fd_out);
3688         sys$dassgn(p->chan_in);
3689         *p->pipe_done = TRUE;
3690         _ckvmssts_noperl(sys$setef(pipe_ef));
3691         return;
3692     }
3693
3694     if (!err && !eof) {             /* good data to send to file */
3695         p->buf[p->iosb.count] = '\n';
3696         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3697         if (iss2 < 0) {
3698             p->retry++;
3699             if (p->retry < MAX_RETRY) {
3700                 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3701                 return;
3702             }
3703         }
3704         p->retry = 0;
3705     } else if (err) {
3706         _ckvmssts_noperl(iss);
3707     }
3708
3709
3710     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3711           pipe_mbxtofd_ast, p,
3712           p->buf, p->bufsize, 0, 0, 0, 0);
3713     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3714     _ckvmssts_noperl(iss);
3715 }
3716
3717
3718 typedef struct _pipeloc     PLOC;
3719 typedef struct _pipeloc*   pPLOC;
3720
3721 struct _pipeloc {
3722     pPLOC   next;
3723     char    dir[NAM$C_MAXRSS+1];
3724 };
3725 static pPLOC  head_PLOC = 0;
3726
3727 void
3728 free_pipelocs(pTHX_ void *head)
3729 {
3730     pPLOC p, pnext;
3731     pPLOC *pHead = (pPLOC *)head;
3732
3733     p = *pHead;
3734     while (p) {
3735         pnext = p->next;
3736         PerlMem_free(p);
3737         p = pnext;
3738     }
3739     *pHead = 0;
3740 }
3741
3742 static void
3743 store_pipelocs(pTHX)
3744 {
3745     int    i;
3746     pPLOC  p;
3747     AV    *av = 0;
3748     SV    *dirsv;
3749     GV    *gv;
3750     char  *dir, *x;
3751     char  *unixdir;
3752     char  temp[NAM$C_MAXRSS+1];
3753     STRLEN n_a;
3754
3755     if (head_PLOC)
3756         free_pipelocs(aTHX_ &head_PLOC);
3757
3758 /*  the . directory from @INC comes last */
3759
3760     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3761     if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3762     p->next = head_PLOC;
3763     head_PLOC = p;
3764     strcpy(p->dir,"./");
3765
3766 /*  get the directory from $^X */
3767
3768     unixdir = PerlMem_malloc(VMS_MAXRSS);
3769     if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3770
3771 #ifdef PERL_IMPLICIT_CONTEXT
3772     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3773 #else
3774     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3775 #endif
3776         strcpy(temp, PL_origargv[0]);
3777         x = strrchr(temp,']');
3778         if (x == NULL) {
3779         x = strrchr(temp,'>');
3780           if (x == NULL) {
3781             /* It could be a UNIX path */
3782             x = strrchr(temp,'/');
3783           }
3784         }
3785         if (x)
3786           x[1] = '\0';
3787         else {
3788           /* Got a bare name, so use default directory */
3789           temp[0] = '.';
3790           temp[1] = '\0';
3791         }
3792
3793         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3794             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3795             if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3796             p->next = head_PLOC;
3797             head_PLOC = p;
3798             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3799             p->dir[NAM$C_MAXRSS] = '\0';
3800         }
3801     }
3802
3803 /*  reverse order of @INC entries, skip "." since entered above */
3804
3805 #ifdef PERL_IMPLICIT_CONTEXT
3806     if (aTHX)
3807 #endif
3808     if (PL_incgv) av = GvAVn(PL_incgv);
3809
3810     for (i = 0; av && i <= AvFILL(av); i++) {
3811         dirsv = *av_fetch(av,i,TRUE);
3812
3813         if (SvROK(dirsv)) continue;
3814         dir = SvPVx(dirsv,n_a);
3815         if (strcmp(dir,".") == 0) continue;
3816         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3817             continue;
3818
3819         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3820         p->next = head_PLOC;
3821         head_PLOC = p;
3822         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3823         p->dir[NAM$C_MAXRSS] = '\0';
3824     }
3825
3826 /* most likely spot (ARCHLIB) put first in the list */
3827
3828 #ifdef ARCHLIB_EXP
3829     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3830         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3831         if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3832         p->next = head_PLOC;
3833         head_PLOC = p;
3834         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3835         p->dir[NAM$C_MAXRSS] = '\0';
3836     }
3837 #endif
3838     PerlMem_free(unixdir);
3839 }
3840
3841 static I32
3842 Perl_cando_by_name_int
3843    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3844 #if !defined(PERL_IMPLICIT_CONTEXT)
3845 #define cando_by_name_int               Perl_cando_by_name_int
3846 #else
3847 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3848 #endif
3849
3850 static char *
3851 find_vmspipe(pTHX)
3852 {
3853     static int   vmspipe_file_status = 0;
3854     static char  vmspipe_file[NAM$C_MAXRSS+1];
3855
3856     /* already found? Check and use ... need read+execute permission */
3857
3858     if (vmspipe_file_status == 1) {
3859         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3860          && cando_by_name_int
3861            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3862             return vmspipe_file;
3863         }
3864         vmspipe_file_status = 0;
3865     }
3866
3867     /* scan through stored @INC, $^X */
3868
3869     if (vmspipe_file_status == 0) {
3870         char file[NAM$C_MAXRSS+1];
3871         pPLOC  p = head_PLOC;
3872
3873         while (p) {
3874             char * exp_res;
3875             int dirlen;
3876             strcpy(file, p->dir);
3877             dirlen = strlen(file);
3878             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3879             file[NAM$C_MAXRSS] = '\0';
3880             p = p->next;
3881
3882             exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3883             if (!exp_res) continue;
3884
3885             if (cando_by_name_int
3886                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3887              && cando_by_name_int
3888                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3889                 vmspipe_file_status = 1;
3890                 return vmspipe_file;
3891             }
3892         }
3893         vmspipe_file_status = -1;   /* failed, use tempfiles */
3894     }
3895
3896     return 0;
3897 }
3898
3899 static FILE *
3900 vmspipe_tempfile(pTHX)
3901 {
3902     char file[NAM$C_MAXRSS+1];
3903     FILE *fp;
3904     static int index = 0;
3905     Stat_t s0, s1;
3906     int cmp_result;
3907
3908     /* create a tempfile */
3909
3910     /* we can't go from   W, shr=get to  R, shr=get without
3911        an intermediate vulnerable state, so don't bother trying...
3912
3913        and lib$spawn doesn't shr=put, so have to close the write
3914
3915        So... match up the creation date/time and the FID to
3916        make sure we're dealing with the same file
3917
3918     */
3919
3920     index++;
3921     if (!decc_filename_unix_only) {
3922       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3923       fp = fopen(file,"w");
3924       if (!fp) {
3925         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3926         fp = fopen(file,"w");
3927         if (!fp) {
3928             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3929             fp = fopen(file,"w");
3930         }
3931       }
3932      }
3933      else {
3934       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3935       fp = fopen(file,"w");
3936       if (!fp) {
3937         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3938         fp = fopen(file,"w");
3939         if (!fp) {
3940           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3941           fp = fopen(file,"w");
3942         }
3943       }
3944     }
3945     if (!fp) return 0;  /* we're hosed */
3946
3947     fprintf(fp,"$! 'f$verify(0)'\n");
3948     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3949     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3950     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3951     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3952     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3953     fprintf(fp,"$ perl_del    = \"delete\"\n");
3954     fprintf(fp,"$ pif         = \"if\"\n");
3955     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3956     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3957     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3958     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3959     fprintf(fp,"$!  --- build command line to get max possible length\n");
3960     fprintf(fp,"$c=perl_popen_cmd0\n");
3961     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3962     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3963     fprintf(fp,"$x=perl_popen_cmd3\n");
3964     fprintf(fp,"$c=c+x\n");
3965     fprintf(fp,"$ perl_on\n");
3966     fprintf(fp,"$ 'c'\n");
3967     fprintf(fp,"$ perl_status = $STATUS\n");
3968     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3969     fprintf(fp,"$ perl_exit 'perl_status'\n");
3970     fsync(fileno(fp));
3971
3972     fgetname(fp, file, 1);
3973     fstat(fileno(fp), &s0.crtl_stat);
3974     fclose(fp);
3975
3976     if (decc_filename_unix_only)
3977         int_tounixspec(file, file, NULL);
3978     fp = fopen(file,"r","shr=get");
3979     if (!fp) return 0;
3980     fstat(fileno(fp), &s1.crtl_stat);
3981
3982     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3983     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3984         fclose(fp);
3985         return 0;
3986     }
3987
3988     return fp;
3989 }
3990
3991
3992 static int vms_is_syscommand_xterm(void)
3993 {
3994     const static struct dsc$descriptor_s syscommand_dsc =
3995       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3996
3997     const static struct dsc$descriptor_s decwdisplay_dsc =
3998       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3999
4000     struct item_list_3 items[2];
4001     unsigned short dvi_iosb[4];
4002     unsigned long devchar;
4003     unsigned long devclass;
4004     int status;
4005
4006     /* Very simple check to guess if sys$command is a decterm? */
4007     /* First see if the DECW$DISPLAY: device exists */
4008     items[0].len = 4;
4009     items[0].code = DVI$_DEVCHAR;
4010     items[0].bufadr = &devchar;
4011     items[0].retadr = NULL;
4012     items[1].len = 0;
4013     items[1].code = 0;
4014
4015     status = sys$getdviw
4016         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
4017
4018     if ($VMS_STATUS_SUCCESS(status)) {
4019         status = dvi_iosb[0];
4020     }
4021
4022     if (!$VMS_STATUS_SUCCESS(status)) {
4023         SETERRNO(EVMSERR, status);
4024         return -1;
4025     }
4026
4027     /* If it does, then for now assume that we are on a workstation */
4028     /* Now verify that SYS$COMMAND is a terminal */
4029     /* for creating the debugger DECTerm */
4030
4031     items[0].len = 4;
4032     items[0].code = DVI$_DEVCLASS;
4033     items[0].bufadr = &devclass;
4034     items[0].retadr = NULL;
4035     items[1].len = 0;
4036     items[1].code = 0;
4037
4038     status = sys$getdviw
4039         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
4040
4041     if ($VMS_STATUS_SUCCESS(status)) {
4042         status = dvi_iosb[0];
4043     }
4044
4045     if (!$VMS_STATUS_SUCCESS(status)) {
4046         SETERRNO(EVMSERR, status);
4047         return -1;
4048     }
4049     else {
4050         if (devclass == DC$_TERM) {
4051             return 0;
4052         }
4053     }
4054     return -1;
4055 }
4056
4057 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
4058 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
4059 {
4060     int status;
4061     int ret_stat;
4062     char * ret_char;
4063     char device_name[65];
4064     unsigned short device_name_len;
4065     struct dsc$descriptor_s customization_dsc;
4066     struct dsc$descriptor_s device_name_dsc;
4067     const char * cptr;
4068     char * tptr;
4069     char customization[200];
4070     char title[40];
4071     pInfo info = NULL;
4072     char mbx1[64];
4073     unsigned short p_chan;
4074     int n;
4075     unsigned short iosb[4];
4076     struct item_list_3 items[2];
4077     const char * cust_str =
4078         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
4079     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
4080                                           DSC$K_CLASS_S, mbx1};
4081
4082      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4083     /*---------------------------------------*/
4084     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
4085
4086
4087     /* Make sure that this is from the Perl debugger */
4088     ret_char = strstr(cmd," xterm ");
4089     if (ret_char == NULL)
4090         return NULL;
4091     cptr = ret_char + 7;
4092     ret_char = strstr(cmd,"tty");
4093     if (ret_char == NULL)
4094         return NULL;
4095     ret_char = strstr(cmd,"sleep");
4096     if (ret_char == NULL)
4097         return NULL;
4098
4099     if (decw_term_port == 0) {
4100         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4101         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4102         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4103
4104        status = lib$find_image_symbol
4105                                (&filename1_dsc,
4106                                 &decw_term_port_dsc,
4107                                 (void *)&decw_term_port,
4108                                 NULL,
4109                                 0);
4110
4111         /* Try again with the other image name */
4112         if (!$VMS_STATUS_SUCCESS(status)) {
4113
4114            status = lib$find_image_symbol
4115                                (&filename2_dsc,
4116                                 &decw_term_port_dsc,
4117                                 (void *)&decw_term_port,
4118                                 NULL,
4119                                 0);
4120
4121         }
4122
4123     }
4124
4125
4126     /* No decw$term_port, give it up */
4127     if (!$VMS_STATUS_SUCCESS(status))
4128         return NULL;
4129
4130     /* Are we on a workstation? */
4131     /* to do: capture the rows / columns and pass their properties */
4132     ret_stat = vms_is_syscommand_xterm();
4133     if (ret_stat < 0)
4134         return NULL;
4135
4136     /* Make the title: */
4137     ret_char = strstr(cptr,"-title");
4138     if (ret_char != NULL) {
4139         while ((*cptr != 0) && (*cptr != '\"')) {
4140             cptr++;
4141         }
4142         if (*cptr == '\"')
4143             cptr++;
4144         n = 0;
4145         while ((*cptr != 0) && (*cptr != '\"')) {
4146             title[n] = *cptr;
4147             n++;
4148             if (n == 39) {
4149                 title[39] == 0;
4150                 break;
4151             }
4152             cptr++;
4153         }
4154         title[n] = 0;
4155     }
4156     else {
4157             /* Default title */
4158             strcpy(title,"Perl Debug DECTerm");
4159     }
4160     sprintf(customization, cust_str, title);
4161
4162     customization_dsc.dsc$a_pointer = customization;
4163     customization_dsc.dsc$w_length = strlen(customization);
4164     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4165     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4166
4167     device_name_dsc.dsc$a_pointer = device_name;
4168     device_name_dsc.dsc$w_length = sizeof device_name -1;
4169     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4170     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4171
4172     device_name_len = 0;
4173
4174     /* Try to create the window */
4175      status = (*decw_term_port)
4176        (NULL,
4177         NULL,
4178         &customization_dsc,
4179         &device_name_dsc,
4180         &device_name_len,
4181         NULL,
4182         NULL,
4183         NULL);
4184     if (!$VMS_STATUS_SUCCESS(status)) {
4185         SETERRNO(EVMSERR, status);
4186         return NULL;
4187     }
4188
4189     device_name[device_name_len] = '\0';
4190
4191     /* Need to set this up to look like a pipe for cleanup */
4192     n = sizeof(Info);
4193     status = lib$get_vm(&n, &info);
4194     if (!$VMS_STATUS_SUCCESS(status)) {
4195         SETERRNO(ENOMEM, status);
4196         return NULL;
4197     }
4198
4199     info->mode = *mode;
4200     info->done = FALSE;
4201     info->completion = 0;
4202     info->closing    = FALSE;
4203     info->in         = 0;
4204     info->out        = 0;
4205     info->err        = 0;
4206     info->fp         = NULL;
4207     info->useFILE    = 0;
4208     info->waiting    = 0;
4209     info->in_done    = TRUE;
4210     info->out_done   = TRUE;
4211     info->err_done   = TRUE;
4212
4213     /* Assign a channel on this so that it will persist, and not login */
4214     /* We stash this channel in the info structure for reference. */
4215     /* The created xterm self destructs when the last channel is removed */
4216     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4217     /* So leave this assigned. */
4218     device_name_dsc.dsc$w_length = device_name_len;
4219     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4220     if (!$VMS_STATUS_SUCCESS(status)) {
4221         SETERRNO(EVMSERR, status);
4222         return NULL;
4223     }
4224     info->xchan_valid = 1;
4225
4226     /* Now create a mailbox to be read by the application */
4227
4228     create_mbx(&p_chan, &d_mbx1);
4229
4230     /* write the name of the created terminal to the mailbox */
4231     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4232             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4233
4234     if (!$VMS_STATUS_SUCCESS(status)) {
4235         SETERRNO(EVMSERR, status);
4236         return NULL;
4237     }
4238
4239     info->fp  = PerlIO_open(mbx1, mode);
4240
4241     /* Done with this channel */
4242     sys$dassgn(p_chan);
4243
4244     /* If any errors, then clean up */
4245     if (!info->fp) {
4246         n = sizeof(Info);
4247         _ckvmssts_noperl(lib$free_vm(&n, &info));
4248         return NULL;
4249         }
4250
4251     /* All done */
4252     return info->fp;
4253 }
4254
4255 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4256
4257 static PerlIO *
4258 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4259 {
4260     static int handler_set_up = FALSE;
4261     PerlIO * ret_fp;
4262     unsigned long int sts, flags = CLI$M_NOWAIT;
4263     /* The use of a GLOBAL table (as was done previously) rendered
4264      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4265      * environment.  Hence we've switched to LOCAL symbol table.
4266      */
4267     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4268     int j, wait = 0, n;
4269     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4270     char *in, *out, *err, mbx[512];
4271     FILE *tpipe = 0;
4272     char tfilebuf[NAM$C_MAXRSS+1];
4273     pInfo info = NULL;
4274     char cmd_sym_name[20];
4275     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4276                                       DSC$K_CLASS_S, symbol};
4277     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4278                                       DSC$K_CLASS_S, 0};
4279     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4280                                       DSC$K_CLASS_S, cmd_sym_name};
4281     struct dsc$descriptor_s *vmscmd;
4282     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4283     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4284     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4285
4286     /* Check here for Xterm create request.  This means looking for
4287      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4288      *  is possible to create an xterm.
4289      */
4290     if (*in_mode == 'r') {
4291         PerlIO * xterm_fd;
4292
4293         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4294         if (xterm_fd != NULL)
4295             return xterm_fd;
4296     }
4297
4298     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4299
4300     /* once-per-program initialization...
4301        note that the SETAST calls and the dual test of pipe_ef
4302        makes sure that only the FIRST thread through here does
4303        the initialization...all other threads wait until it's
4304        done.
4305
4306        Yeah, uglier than a pthread call, it's got all the stuff inline
4307        rather than in a separate routine.
4308     */
4309
4310     if (!pipe_ef) {
4311         _ckvmssts_noperl(sys$setast(0));
4312         if (!pipe_ef) {
4313             unsigned long int pidcode = JPI$_PID;
4314             $DESCRIPTOR(d_delay, RETRY_DELAY);
4315             _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4316             _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4317             _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4318         }
4319         if (!handler_set_up) {
4320           _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4321           handler_set_up = TRUE;
4322         }
4323         _ckvmssts_noperl(sys$setast(1));
4324     }
4325
4326     /* see if we can find a VMSPIPE.COM */
4327
4328     tfilebuf[0] = '@';
4329     vmspipe = find_vmspipe(aTHX);
4330     if (vmspipe) {
4331         strcpy(tfilebuf+1,vmspipe);
4332     } else {        /* uh, oh...we're in tempfile hell */
4333         tpipe = vmspipe_tempfile(aTHX);
4334         if (!tpipe) {       /* a fish popular in Boston */
4335             if (ckWARN(WARN_PIPE)) {
4336                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4337             }
4338         return NULL;
4339         }
4340         fgetname(tpipe,tfilebuf+1,1);
4341     }
4342     vmspipedsc.dsc$a_pointer = tfilebuf;
4343     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4344
4345     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4346     if (!(sts & 1)) {
4347       switch (sts) {
4348         case RMS$_FNF:  case RMS$_DNF:
4349           set_errno(ENOENT); break;
4350         case RMS$_DIR:
4351           set_errno(ENOTDIR); break;
4352         case RMS$_DEV:
4353           set_errno(ENODEV); break;
4354         case RMS$_PRV:
4355           set_errno(EACCES); break;
4356         case RMS$_SYN:
4357           set_errno(EINVAL); break;
4358         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4359           set_errno(E2BIG); break;
4360         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4361           _ckvmssts_noperl(sts); /* fall through */
4362         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4363           set_errno(EVMSERR);
4364       }
4365       set_vaxc_errno(sts);
4366       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4367         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4368       }
4369       *psts = sts;
4370       return NULL;
4371     }
4372     n = sizeof(Info);
4373     _ckvmssts_noperl(lib$get_vm(&n, &info));
4374
4375     strcpy(mode,in_mode);
4376     info->mode = *mode;
4377     info->done = FALSE;
4378     info->completion = 0;
4379     info->closing    = FALSE;
4380     info->in         = 0;
4381     info->out        = 0;
4382     info->err        = 0;
4383     info->fp         = NULL;
4384     info->useFILE    = 0;
4385     info->waiting    = 0;
4386     info->in_done    = TRUE;
4387     info->out_done   = TRUE;
4388     info->err_done   = TRUE;
4389     info->xchan      = 0;
4390     info->xchan_valid = 0;
4391
4392     in = PerlMem_malloc(VMS_MAXRSS);
4393     if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4394     out = PerlMem_malloc(VMS_MAXRSS);
4395     if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4396     err = PerlMem_malloc(VMS_MAXRSS);
4397     if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4398
4399     in[0] = out[0] = err[0] = '\0';
4400
4401     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4402         info->useFILE = 1;
4403         strcpy(p,p+1);
4404     }
4405     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4406         wait = 1;
4407         strcpy(p,p+1);
4408     }
4409
4410     if (*mode == 'r') {             /* piping from subroutine */
4411
4412         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4413         if (info->out) {
4414             info->out->pipe_done = &info->out_done;
4415             info->out_done = FALSE;
4416             info->out->info = info;
4417         }
4418         if (!info->useFILE) {
4419             info->fp  = PerlIO_open(mbx, mode);
4420         } else {
4421             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4422             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4423         }
4424
4425         if (!info->fp && info->out) {
4426             sys$cancel(info->out->chan_out);
4427
4428             while (!info->out_done) {
4429                 int done;
4430                 _ckvmssts_noperl(sys$setast(0));
4431                 done = info->out_done;
4432                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4433                 _ckvmssts_noperl(sys$setast(1));
4434                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4435             }
4436
4437             if (info->out->buf) {
4438                 n = info->out->bufsize * sizeof(char);
4439                 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4440             }
4441             n = sizeof(Pipe);
4442             _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4443             n = sizeof(Info);
4444             _ckvmssts_noperl(lib$free_vm(&n, &info));
4445             *psts = RMS$_FNF;
4446             return NULL;
4447         }
4448
4449         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4450         if (info->err) {
4451             info->err->pipe_done = &info->err_done;
4452             info->err_done = FALSE;
4453             info->err->info = info;
4454         }
4455
4456     } else if (*mode == 'w') {      /* piping to subroutine */
4457
4458         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4459         if (info->out) {
4460             info->out->pipe_done = &info->out_done;
4461             info->out_done = FALSE;
4462             info->out->info = info;
4463         }
4464
4465         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4466         if (info->err) {
4467             info->err->pipe_done = &info->err_done;
4468             info->err_done = FALSE;
4469             info->err->info = info;
4470         }
4471
4472         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4473         if (!info->useFILE) {
4474             info->fp  = PerlIO_open(mbx, mode);
4475         } else {
4476             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4477             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4478         }
4479
4480         if (info->in) {
4481             info->in->pipe_done = &info->in_done;
4482             info->in_done = FALSE;
4483             info->in->info = info;
4484         }
4485
4486         /* error cleanup */
4487         if (!info->fp && info->in) {
4488             info->done = TRUE;
4489             _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4490                                       0, 0, 0, 0, 0, 0, 0, 0));
4491
4492             while (!info->in_done) {
4493                 int done;
4494                 _ckvmssts_noperl(sys$setast(0));
4495                 done = info->in_done;
4496                 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4497                 _ckvmssts_noperl(sys$setast(1));
4498                 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4499             }
4500
4501             if (info->in->buf) {
4502                 n = info->in->bufsize * sizeof(char);
4503                 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4504             }
4505             n = sizeof(Pipe);
4506             _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4507             n = sizeof(Info);
4508             _ckvmssts_noperl(lib$free_vm(&n, &info));
4509             *psts = RMS$_FNF;
4510             return NULL;
4511         }
4512
4513
4514     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4515         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4516         if (info->out) {
4517             info->out->pipe_done = &info->out_done;
4518             info->out_done = FALSE;
4519             info->out->info = info;
4520         }
4521
4522         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4523         if (info->err) {
4524             info->err->pipe_done = &info->err_done;
4525             info->err_done = FALSE;
4526             info->err->info = info;
4527         }
4528     }
4529
4530     symbol[MAX_DCL_SYMBOL] = '\0';
4531
4532     strncpy(symbol, in, MAX_DCL_SYMBOL);
4533     d_symbol.dsc$w_length = strlen(symbol);
4534     _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4535
4536     strncpy(symbol, err, MAX_DCL_SYMBOL);
4537     d_symbol.dsc$w_length = strlen(symbol);
4538     _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4539
4540     strncpy(symbol, out, MAX_DCL_SYMBOL);
4541     d_symbol.dsc$w_length = strlen(symbol);
4542     _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4543
4544     /* Done with the names for the pipes */
4545     PerlMem_free(err);
4546     PerlMem_free(out);
4547     PerlMem_free(in);
4548
4549     p = vmscmd->dsc$a_pointer;
4550     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4551     if (*p == '$') p++;                         /* remove leading $ */
4552     while (*p == ' ' || *p == '\t') p++;
4553
4554     for (j = 0; j < 4; j++) {
4555         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4556         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4557
4558     strncpy(symbol, p, MAX_DCL_SYMBOL);
4559     d_symbol.dsc$w_length = strlen(symbol);
4560     _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4561
4562         if (strlen(p) > MAX_DCL_SYMBOL) {
4563             p += MAX_DCL_SYMBOL;
4564         } else {
4565             p += strlen(p);
4566         }
4567     }
4568     _ckvmssts_noperl(sys$setast(0));
4569     info->next=open_pipes;  /* prepend to list */
4570     open_pipes=info;
4571     _ckvmssts_noperl(sys$setast(1));
4572     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4573      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4574      * have SYS$COMMAND if we need it.
4575      */
4576     _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4577                       0, &info->pid, &info->completion,
4578                       0, popen_completion_ast,info,0,0,0));
4579
4580     /* if we were using a tempfile, close it now */
4581
4582     if (tpipe) fclose(tpipe);
4583
4584     /* once the subprocess is spawned, it has copied the symbols and
4585        we can get rid of ours */
4586
4587     for (j = 0; j < 4; j++) {
4588         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4589         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4590     _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4591     }
4592     _ckvmssts_noperl(lib$delete_symbol(&d_sym_in,  &table));
4593     _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4594     _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4595     vms_execfree(vmscmd);
4596
4597 #ifdef PERL_IMPLICIT_CONTEXT
4598     if (aTHX)
4599 #endif
4600     PL_forkprocess = info->pid;
4601
4602     ret_fp = info->fp;
4603     if (wait) {
4604          dSAVEDERRNO;
4605          int done = 0;
4606          while (!done) {
4607              _ckvmssts_noperl(sys$setast(0));
4608              done = info->done;
4609              if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4610              _ckvmssts_noperl(sys$setast(1));
4611              if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4612          }
4613         *psts = info->completion;
4614 /* Caller thinks it is open and tries to close it. */
4615 /* This causes some problems, as it changes the error status */
4616 /*        my_pclose(info->fp); */
4617
4618          /* If we did not have a file pointer open, then we have to */
4619          /* clean up here or eventually we will run out of something */
4620          SAVE_ERRNO;
4621          if (info->fp == NULL) {
4622              my_pclose_pinfo(aTHX_ info);
4623          }
4624          RESTORE_ERRNO;
4625
4626     } else {
4627         *psts = info->pid;
4628     }
4629     return ret_fp;
4630 }  /* end of safe_popen */
4631
4632
4633 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4634 PerlIO *
4635 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4636 {
4637     int sts;
4638     TAINT_ENV();
4639     TAINT_PROPER("popen");
4640     PERL_FLUSHALL_FOR_CHILD;
4641     return safe_popen(aTHX_ cmd,mode,&sts);
4642 }
4643
4644 /*}}}*/
4645
4646
4647 /* Routine to close and cleanup a pipe info structure */
4648
4649 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4650
4651     unsigned long int retsts;
4652     int done, iss, n;
4653     int status;
4654     pInfo next, last;
4655
4656     /* If we were writing to a subprocess, insure that someone reading from
4657      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4658      * produce an EOF record in the mailbox.
4659      *
4660      *  well, at least sometimes it *does*, so we have to watch out for
4661      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4662      */
4663      if (info->fp) {
4664         if (!info->useFILE
4665 #if defined(USE_ITHREADS)
4666           && my_perl
4667 #endif
4668           && PL_perlio_fd_refcnt)
4669             PerlIO_flush(info->fp);
4670         else
4671             fflush((FILE *)info->fp);
4672     }
4673
4674     _ckvmssts(sys$setast(0));
4675      info->closing = TRUE;
4676      done = info->done && info->in_done && info->out_done && info->err_done;
4677      /* hanging on write to Perl's input? cancel it */
4678      if (info->mode == 'r' && info->out && !info->out_done) {
4679         if (info->out->chan_out) {
4680             _ckvmssts(sys$cancel(info->out->chan_out));
4681             if (!info->out->chan_in) {   /* EOF generation, need AST */
4682                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4683             }
4684         }
4685      }
4686      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4687          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4688                            0, 0, 0, 0, 0, 0));
4689     _ckvmssts(sys$setast(1));
4690     if (info->fp) {
4691      if (!info->useFILE
4692 #if defined(USE_ITHREADS)
4693          && my_perl
4694 #endif
4695          && PL_perlio_fd_refcnt)
4696         PerlIO_close(info->fp);
4697      else
4698         fclose((FILE *)info->fp);
4699     }
4700      /*
4701         we have to wait until subprocess completes, but ALSO wait until all
4702         the i/o completes...otherwise we'll be freeing the "info" structure
4703         that the i/o ASTs could still be using...
4704      */
4705
4706      while (!done) {
4707          _ckvmssts(sys$setast(0));
4708          done = info->done && info->in_done && info->out_done && info->err_done;
4709          if (!done) _ckvmssts(sys$clref(pipe_ef));
4710          _ckvmssts(sys$setast(1));
4711          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4712      }
4713      retsts = info->completion;
4714
4715     /* remove from list of open pipes */
4716     _ckvmssts(sys$setast(0));
4717     last = NULL;
4718     for (next = open_pipes; next != NULL; last = next, next = next->next) {
4719         if (next == info)
4720             break;
4721     }
4722
4723     if (last)
4724         last->next = info->next;
4725     else
4726         open_pipes = info->next;
4727     _ckvmssts(sys$setast(1));
4728
4729     /* free buffers and structures */
4730
4731     if (info->in) {
4732         if (info->in->buf) {
4733             n = info->in->bufsize * sizeof(char);
4734             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4735         }
4736         n = sizeof(Pipe);
4737         _ckvmssts(lib$free_vm(&n, &info->in));
4738     }
4739     if (info->out) {
4740         if (info->out->buf) {
4741             n = info->out->bufsize * sizeof(char);
4742             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4743         }
4744         n = sizeof(Pipe);
4745         _ckvmssts(lib$free_vm(&n, &info->out));
4746     }
4747     if (info->err) {
4748         if (info->err->buf) {
4749             n = info->err->bufsize * sizeof(char);
4750             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4751         }
4752         n = sizeof(Pipe);
4753         _ckvmssts(lib$free_vm(&n, &info->err));
4754     }
4755     n = sizeof(Info);
4756     _ckvmssts(lib$free_vm(&n, &info));
4757
4758     return retsts;
4759 }
4760
4761
4762 /*{{{  I32 my_pclose(PerlIO *fp)*/
4763 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4764 {
4765     pInfo info, last = NULL;
4766     I32 ret_status;
4767
4768     /* Fixme - need ast and mutex protection here */
4769     for (info = open_pipes; info != NULL; last = info, info = info->next)
4770         if (info->fp == fp) break;
4771
4772     if (info == NULL) {  /* no such pipe open */
4773       set_errno(ECHILD); /* quoth POSIX */
4774       set_vaxc_errno(SS$_NONEXPR);
4775       return -1;
4776     }
4777
4778     ret_status = my_pclose_pinfo(aTHX_ info);
4779
4780     return ret_status;
4781
4782 }  /* end of my_pclose() */
4783
4784 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4785   /* Roll our own prototype because we want this regardless of whether
4786    * _VMS_WAIT is defined.
4787    */
4788   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4789 #endif
4790 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4791    created with popen(); otherwise partially emulate waitpid() unless
4792    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4793    Also check processes not considered by the CRTL waitpid().
4794  */
4795 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4796 Pid_t
4797 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4798 {
4799     pInfo info;
4800     int done;
4801     int sts;
4802     int j;
4803
4804     if (statusp) *statusp = 0;
4805
4806     for (info = open_pipes; info != NULL; info = info->next)
4807         if (info->pid == pid) break;
4808
4809     if (info != NULL) {  /* we know about this child */
4810       while (!info->done) {
4811           _ckvmssts(sys$setast(0));
4812           done = info->done;
4813           if (!done) _ckvmssts(sys$clref(pipe_ef));
4814           _ckvmssts(sys$setast(1));
4815           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4816       }
4817
4818       if (statusp) *statusp = info->completion;
4819       return pid;
4820     }
4821
4822     /* child that already terminated? */
4823
4824     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4825         if (closed_list[j].pid == pid) {
4826             if (statusp) *statusp = closed_list[j].completion;
4827             return pid;
4828         }
4829     }
4830
4831     /* fall through if this child is not one of our own pipe children */
4832
4833 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4834
4835       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4836        * in 7.2 did we get a version that fills in the VMS completion
4837        * status as Perl has always tried to do.
4838        */
4839
4840       sts = __vms_waitpid( pid, statusp, flags );
4841
4842       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4843          return sts;
4844
4845       /* If the real waitpid tells us the child does not exist, we
4846        * fall through here to implement waiting for a child that
4847        * was created by some means other than exec() (say, spawned
4848        * from DCL) or to wait for a process that is not a subprocess
4849        * of the current process.
4850        */
4851
4852 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4853
4854     {
4855       $DESCRIPTOR(intdsc,"0 00:00:01");
4856       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4857       unsigned long int pidcode = JPI$_PID, mypid;
4858       unsigned long int interval[2];
4859       unsigned int jpi_iosb[2];
4860       struct itmlst_3 jpilist[2] = {
4861           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4862           {                      0,         0,                 0, 0}
4863       };
4864
4865       if (pid <= 0) {
4866         /* Sorry folks, we don't presently implement rooting around for
4867            the first child we can find, and we definitely don't want to
4868            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4869          */
4870         set_errno(ENOTSUP);
4871         return -1;
4872       }
4873
4874       /* Get the owner of the child so I can warn if it's not mine. If the
4875        * process doesn't exist or I don't have the privs to look at it,
4876        * I can go home early.
4877        */
4878       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4879       if (sts & 1) sts = jpi_iosb[0];
4880       if (!(sts & 1)) {
4881         switch (sts) {
4882             case SS$_NONEXPR:
4883                 set_errno(ECHILD);
4884                 break;
4885             case SS$_NOPRIV:
4886                 set_errno(EACCES);
4887                 break;
4888             default:
4889                 _ckvmssts(sts);
4890         }
4891         set_vaxc_errno(sts);
4892         return -1;
4893       }
4894
4895       if (ckWARN(WARN_EXEC)) {
4896         /* remind folks they are asking for non-standard waitpid behavior */
4897         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4898         if (ownerpid != mypid)
4899           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4900                       "waitpid: process %x is not a child of process %x",
4901                       pid,mypid);
4902       }
4903
4904       /* simply check on it once a second until it's not there anymore. */
4905
4906       _ckvmssts(sys$bintim(&intdsc,interval));
4907       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4908             _ckvmssts(sys$schdwk(0,0,interval,0));
4909             _ckvmssts(sys$hiber());
4910       }
4911       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4912
4913       _ckvmssts(sts);
4914       return pid;
4915     }
4916 }  /* end of waitpid() */
4917 /*}}}*/
4918 /*}}}*/
4919 /*}}}*/
4920
4921 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4922 char *
4923 my_gconvert(double val, int ndig, int trail, char *buf)
4924 {
4925   static char __gcvtbuf[DBL_DIG+1];
4926   char *loc;
4927
4928   loc = buf ? buf : __gcvtbuf;
4929
4930 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4931   if (val < 1) {
4932     sprintf(loc,"%.*g",ndig,val);
4933     return loc;
4934   }
4935 #endif
4936
4937   if (val) {
4938     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4939     return gcvt(val,ndig,loc);
4940   }
4941   else {
4942     loc[0] = '0'; loc[1] = '\0';
4943     return loc;
4944   }
4945
4946 }
4947 /*}}}*/
4948
4949 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4950 static int rms_free_search_context(struct FAB * fab)
4951 {
4952 struct NAM * nam;
4953
4954     nam = fab->fab$l_nam;
4955     nam->nam$b_nop |= NAM$M_SYNCHK;
4956     nam->nam$l_rlf = NULL;
4957     fab->fab$b_dns = 0;
4958     return sys$parse(fab, NULL, NULL);
4959 }
4960
4961 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4962 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4963 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4964 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4965 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4966 #define rms_nam_esll(nam) nam.nam$b_esl
4967 #define rms_nam_esl(nam) nam.nam$b_esl
4968 #define rms_nam_name(nam) nam.nam$l_name
4969 #define rms_nam_namel(nam) nam.nam$l_name
4970 #define rms_nam_type(nam) nam.nam$l_type
4971 #define rms_nam_typel(nam) nam.nam$l_type
4972 #define rms_nam_ver(nam) nam.nam$l_ver
4973 #define rms_nam_verl(nam) nam.nam$l_ver
4974 #define rms_nam_rsll(nam) nam.nam$b_rsl
4975 #define rms_nam_rsl(nam) nam.nam$b_rsl
4976 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4977 #define rms_set_fna(fab, nam, name, size) \
4978         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4979 #define rms_get_fna(fab, nam) fab.fab$l_fna
4980 #define rms_set_dna(fab, nam, name, size) \
4981         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4982 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4983 #define rms_set_esa(nam, name, size) \
4984         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4985 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4986         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4987 #define rms_set_rsa(nam, name, size) \
4988         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4989 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4990         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4991 #define rms_nam_name_type_l_size(nam) \
4992         (nam.nam$b_name + nam.nam$b_type)
4993 #else
4994 static int rms_free_search_context(struct FAB * fab)
4995 {
4996 struct NAML * nam;
4997
4998     nam = fab->fab$l_naml;
4999     nam->naml$b_nop |= NAM$M_SYNCHK;
5000     nam->naml$l_rlf = NULL;
5001     nam->naml$l_long_defname_size = 0;
5002
5003     fab->fab$b_dns = 0;
5004     return sys$parse(fab, NULL, NULL);
5005 }
5006
5007 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
5008 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
5009 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
5010 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
5011 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
5012 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
5013 #define rms_nam_esl(nam) nam.naml$b_esl
5014 #define rms_nam_name(nam) nam.naml$l_name
5015 #define rms_nam_namel(nam) nam.naml$l_long_name
5016 #define rms_nam_type(nam) nam.naml$l_type
5017 #define rms_nam_typel(nam) nam.naml$l_long_type
5018 #define rms_nam_ver(nam) nam.naml$l_ver
5019 #define rms_nam_verl(nam) nam.naml$l_long_ver
5020 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
5021 #define rms_nam_rsl(nam) nam.naml$b_rsl
5022 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
5023 #define rms_set_fna(fab, nam, name, size) \
5024         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
5025         nam.naml$l_long_filename_size = size; \
5026         nam.naml$l_long_filename = name;}
5027 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
5028 #define rms_set_dna(fab, nam, name, size) \
5029         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
5030         nam.naml$l_long_defname_size = size; \
5031         nam.naml$l_long_defname = name; }
5032 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
5033 #define rms_set_esa(nam, name, size) \
5034         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
5035         nam.naml$l_long_expand_alloc = size; \
5036         nam.naml$l_long_expand = name; }
5037 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
5038         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
5039         nam.naml$l_long_expand = l_name; \
5040         nam.naml$l_long_expand_alloc = l_size; }
5041 #define rms_set_rsa(nam, name, size) \
5042         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
5043         nam.naml$l_long_result = name; \
5044         nam.naml$l_long_result_alloc = size; }
5045 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
5046         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
5047         nam.naml$l_long_result = l_name; \
5048         nam.naml$l_long_result_alloc = l_size; }
5049 #define rms_nam_name_type_l_size(nam) \
5050         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
5051 #endif
5052
5053
5054 /* rms_erase
5055  * The CRTL for 8.3 and later can create symbolic links in any mode,
5056  * however in 8.3 the unlink/remove/delete routines will only properly handle
5057  * them if one of the PCP modes is active.
5058  */
5059 static int rms_erase(const char * vmsname)
5060 {
5061   int status;
5062   struct FAB myfab = cc$rms_fab;
5063   rms_setup_nam(mynam);
5064
5065   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
5066   rms_bind_fab_nam(myfab, mynam);
5067
5068   /* Are we removing all versions? */
5069   if (vms_unlink_all_versions == 1) {
5070     const char * defspec = ";*";
5071     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5072   }
5073
5074 #ifdef NAML$M_OPEN_SPECIAL
5075   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5076 #endif
5077
5078   status = sys$erase(&myfab, 0, 0);
5079
5080   return status;
5081 }
5082
5083
5084 static int
5085 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5086                     const struct dsc$descriptor_s * vms_dst_dsc,
5087                     unsigned long flags)
5088 {
5089     /*  VMS and UNIX handle file permissions differently and the
5090      * the same ACL trick may be needed for renaming files,
5091      * especially if they are directories.
5092      */
5093
5094    /* todo: get kill_file and rename to share common code */
5095    /* I can not find online documentation for $change_acl
5096     * it appears to be replaced by $set_security some time ago */
5097
5098 const unsigned int access_mode = 0;
5099 $DESCRIPTOR(obj_file_dsc,"FILE");
5100 char *vmsname;
5101 char *rslt;
5102 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
5103 int aclsts, fndsts, rnsts = -1;
5104 unsigned int ctx = 0;
5105 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5106 struct dsc$descriptor_s * clean_dsc;
5107
5108 struct myacedef {
5109     unsigned char myace$b_length;
5110     unsigned char myace$b_type;
5111     unsigned short int myace$w_flags;
5112     unsigned long int myace$l_access;
5113     unsigned long int myace$l_ident;
5114 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5115              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5116              0},
5117              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5118
5119 struct item_list_3
5120         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5121                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5122                       {0,0,0,0}},
5123         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5124         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5125                      {0,0,0,0}};
5126
5127
5128     /* Expand the input spec using RMS, since we do not want to put
5129      * ACLs on the target of a symbolic link */
5130     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
5131     if (vmsname == NULL)
5132         return SS$_INSFMEM;
5133
5134     rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5135                         vmsname,
5136                         PERL_RMSEXPAND_M_SYMLINK);
5137     if (rslt == NULL) {
5138         PerlMem_free(vmsname);
5139         return SS$_INSFMEM;
5140     }
5141
5142     /* So we get our own UIC to use as a rights identifier,
5143      * and the insert an ACE at the head of the ACL which allows us
5144      * to delete the file.
5145      */
5146     _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5147
5148     fildsc.dsc$w_length = strlen(vmsname);
5149     fildsc.dsc$a_pointer = vmsname;
5150     ctx = 0;
5151     newace.myace$l_ident = oldace.myace$l_ident;
5152     rnsts = SS$_ABORT;
5153
5154     /* Grab any existing ACEs with this identifier in case we fail */
5155     clean_dsc = &fildsc;
5156     aclsts = fndsts = sys$get_security(&obj_file_dsc,
5157                                &fildsc,
5158                                NULL,
5159                                OSS$M_WLOCK,
5160                                findlst,
5161                                &ctx,
5162                                &access_mode);
5163
5164     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
5165         /* Add the new ACE . . . */
5166
5167         /* if the sys$get_security succeeded, then ctx is valid, and the
5168          * object/file descriptors will be ignored.  But otherwise they
5169          * are needed
5170          */
5171         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5172                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
5173         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5174             set_errno(EVMSERR);
5175             set_vaxc_errno(aclsts);
5176             PerlMem_free(vmsname);
5177             return aclsts;
5178         }
5179
5180         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5181                                 NULL, NULL,
5182                                 &flags,
5183                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5184
5185         if ($VMS_STATUS_SUCCESS(rnsts)) {
5186             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5187         }
5188
5189         /* Put things back the way they were. */
5190         ctx = 0;
5191         aclsts = sys$get_security(&obj_file_dsc,
5192                                   clean_dsc,
5193                                   NULL,
5194                                   OSS$M_WLOCK,
5195                                   findlst,
5196                                   &ctx,
5197                                   &access_mode);
5198
5199         if ($VMS_STATUS_SUCCESS(aclsts)) {
5200         int sec_flags;
5201
5202             sec_flags = 0;
5203             if (!$VMS_STATUS_SUCCESS(fndsts))
5204                 sec_flags = OSS$M_RELCTX;
5205
5206             /* Get rid of the new ACE */
5207             aclsts = sys$set_security(NULL, NULL, NULL,
5208                                   sec_flags, dellst, &ctx, &access_mode);
5209
5210             /* If there was an old ACE, put it back */
5211             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5212                 addlst[0].bufadr = &oldace;
5213                 aclsts = sys$set_security(NULL, NULL, NULL,
5214                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
5215                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5216                     set_errno(EVMSERR);
5217                     set_vaxc_errno(aclsts);
5218                     rnsts = aclsts;
5219                 }
5220             } else {
5221             int aclsts2;
5222
5223                 /* Try to clear the lock on the ACL list */
5224                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5225                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5226
5227                 /* Rename errors are most important */
5228                 if (!$VMS_STATUS_SUCCESS(rnsts))
5229                     aclsts = rnsts;
5230                 set_errno(EVMSERR);
5231                 set_vaxc_errno(aclsts);
5232                 rnsts = aclsts;
5233             }
5234         }
5235         else {
5236             if (aclsts != SS$_ACLEMPTY)
5237                 rnsts = aclsts;
5238         }
5239     }
5240     else
5241         rnsts = fndsts;
5242
5243     PerlMem_free(vmsname);
5244     return rnsts;
5245 }
5246
5247
5248 /*{{{int rename(const char *, const char * */
5249 /* Not exactly what X/Open says to do, but doing it absolutely right
5250  * and efficiently would require a lot more work.  This should be close
5251  * enough to pass all but the most strict X/Open compliance test.
5252  */
5253 int
5254 Perl_rename(pTHX_ const char *src, const char * dst)
5255 {
5256 int retval;
5257 int pre_delete = 0;
5258 int src_sts;
5259 int dst_sts;
5260 Stat_t src_st;
5261 Stat_t dst_st;
5262
5263     /* Validate the source file */
5264     src_sts = flex_lstat(src, &src_st);
5265     if (src_sts != 0) {
5266
5267         /* No source file or other problem */
5268         return src_sts;
5269     }
5270
5271     dst_sts = flex_lstat(dst, &dst_st);
5272     if (dst_sts == 0) {
5273
5274         if (dst_st.st_dev != src_st.st_dev) {
5275             /* Must be on the same device */
5276             errno = EXDEV;
5277             return -1;
5278         }
5279
5280         /* VMS_INO_T_COMPARE is true if the inodes are different
5281          * to match the output of memcmp
5282          */
5283
5284         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5285             /* That was easy, the files are the same! */
5286             return 0;
5287         }
5288
5289         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5290             /* If source is a directory, so must be dest */
5291                 errno = EISDIR;
5292                 return -1;
5293         }
5294
5295     }
5296
5297
5298     if ((dst_sts == 0) &&
5299         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5300
5301         /* We have issues here if vms_unlink_all_versions is set
5302          * If the destination exists, and is not a directory, then
5303          * we must delete in advance.
5304          *
5305          * If the src is a directory, then we must always pre-delete
5306          * the destination.
5307          *
5308          * If we successfully delete the dst in advance, and the rename fails
5309          * X/Open requires that errno be EIO.
5310          *
5311          */
5312
5313         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5314             int d_sts;
5315             d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5316             if (d_sts != 0)
5317                 return d_sts;
5318
5319             /* We killed the destination, so only errno now is EIO */
5320             pre_delete = 1;
5321         }
5322     }
5323
5324     /* Originally the idea was to call the CRTL rename() and only
5325      * try the lib$rename_file if it failed.
5326      * It turns out that there are too many variants in what the
5327      * the CRTL rename might do, so only use lib$rename_file
5328      */
5329     retval = -1;
5330
5331     {
5332         /* Is the source and dest both in VMS format */
5333         /* if the source is a directory, then need to fileify */
5334         /*  and dest must be a directory or non-existant. */
5335
5336         char * vms_src;
5337         char * vms_dst;
5338         int sts;
5339         char * ret_str;
5340         unsigned long flags;
5341         struct dsc$descriptor_s old_file_dsc;
5342         struct dsc$descriptor_s new_file_dsc;
5343
5344         /* We need to modify the src and dst depending
5345          * on if one or more of them are directories.
5346          */
5347
5348         vms_src = PerlMem_malloc(VMS_MAXRSS);
5349         if (vms_src == NULL)
5350             _ckvmssts_noperl(SS$_INSFMEM);
5351
5352         /* Source is always a VMS format file */
5353         ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5354         if (ret_str == NULL) {
5355             PerlMem_free(vms_src);
5356             errno = EIO;
5357             return -1;
5358         }
5359
5360         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5361         if (vms_dst == NULL)
5362             _ckvmssts_noperl(SS$_INSFMEM);
5363
5364         if (S_ISDIR(src_st.st_mode)) {
5365         char * ret_str;
5366         char * vms_dir_file;
5367
5368             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5369             if (vms_dir_file == NULL)
5370                 _ckvmssts_noperl(SS$_INSFMEM);
5371
5372             /* The source must be a file specification */
5373             ret_str = int_fileify_dirspec(vms_src, vms_dir_file, NULL);
5374             if (ret_str == NULL) {
5375                 PerlMem_free(vms_src);
5376                 PerlMem_free(vms_dst);
5377                 PerlMem_free(vms_dir_file);
5378                 errno = EIO;
5379                 return -1;
5380             }
5381             PerlMem_free(vms_src);
5382             vms_src = vms_dir_file;
5383
5384             /* If the dest is a directory, we must remove it
5385             if (dst_sts == 0) {
5386                 int d_sts;
5387                 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5388                 if (d_sts != 0) {
5389                     PerlMem_free(vms_src);
5390                     PerlMem_free(vms_dst);
5391                     errno = EIO;
5392                     return sts;
5393                 }
5394
5395                 pre_delete = 1;
5396             }
5397
5398            /* The dest must be a VMS file specification */
5399            ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5400            if (ret_str == NULL) {
5401                 PerlMem_free(vms_src);
5402                 PerlMem_free(vms_dst);
5403                 errno = EIO;
5404                 return -1;
5405            }
5406
5407             /* The source must be a file specification */
5408             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5409             if (vms_dir_file == NULL)
5410                 _ckvmssts_noperl(SS$_INSFMEM);
5411
5412             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5413             if (ret_str == NULL) {
5414                 PerlMem_free(vms_src);
5415                 PerlMem_free(vms_dst);
5416                 PerlMem_free(vms_dir_file);
5417                 errno = EIO;
5418                 return -1;
5419             }
5420             PerlMem_free(vms_dst);
5421             vms_dst = vms_dir_file;
5422
5423         } else {
5424             /* File to file or file to new dir */
5425
5426             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5427                 /* VMS pathify a dir target */
5428                 ret_str = int_tovmspath(dst, vms_dst, NULL);
5429                 if (ret_str == NULL) {
5430                     PerlMem_free(vms_src);
5431                     PerlMem_free(vms_dst);
5432                     errno = EIO;
5433                     return -1;
5434                 }
5435             } else {
5436
5437                 /* fileify a target VMS file specification */
5438                 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5439                 if (ret_str == NULL) {
5440                     PerlMem_free(vms_src);
5441                     PerlMem_free(vms_dst);
5442                     errno = EIO;
5443                     return -1;
5444                 }
5445             }
5446         }
5447
5448         old_file_dsc.dsc$a_pointer = vms_src;
5449         old_file_dsc.dsc$w_length = strlen(vms_src);
5450         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5451         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5452
5453         new_file_dsc.dsc$a_pointer = vms_dst;
5454         new_file_dsc.dsc$w_length = strlen(vms_dst);
5455         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5456         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5457
5458         flags = 0;
5459 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5460         flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5461 #endif
5462
5463         sts = lib$rename_file(&old_file_dsc,
5464                               &new_file_dsc,
5465                               NULL, NULL,
5466                               &flags,
5467                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5468         if (!$VMS_STATUS_SUCCESS(sts)) {
5469
5470            /* We could have failed because VMS style permissions do not
5471             * permit renames that UNIX will allow.  Just like the hack
5472             * in for kill_file.
5473             */
5474            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5475         }
5476
5477         PerlMem_free(vms_src);
5478         PerlMem_free(vms_dst);
5479         if (!$VMS_STATUS_SUCCESS(sts)) {
5480             errno = EIO;
5481             return -1;
5482         }
5483         retval = 0;
5484     }
5485
5486     if (vms_unlink_all_versions) {
5487         /* Now get rid of any previous versions of the source file that
5488          * might still exist
5489          */
5490         int save_errno;
5491         save_errno = errno;
5492         src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5493         errno = save_errno;
5494     }
5495
5496     /* We deleted the destination, so must force the error to be EIO */
5497     if ((retval != 0) && (pre_delete != 0))
5498         errno = EIO;
5499
5500     return retval;
5501 }
5502 /*}}}*/
5503
5504
5505 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5506 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5507  * to expand file specification.  Allows for a single default file
5508  * specification and a simple mask of options.  If outbuf is non-NULL,
5509  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5510  * the resultant file specification is placed.  If outbuf is NULL, the
5511  * resultant file specification is placed into a static buffer.
5512  * The third argument, if non-NULL, is taken to be a default file
5513  * specification string.  The fourth argument is unused at present.
5514  * rmesexpand() returns the address of the resultant string if
5515  * successful, and NULL on error.
5516  *
5517  * New functionality for previously unused opts value:
5518  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5519  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5520  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5521  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5522  */
5523 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5524
5525 static char *
5526 int_rmsexpand
5527    (const char *filespec,
5528     char *outbuf,
5529     const char *defspec,
5530     unsigned opts,
5531     int * fs_utf8,
5532     int * dfs_utf8)
5533 {
5534   char * ret_spec;
5535   const char * in_spec;
5536   char * spec_buf;
5537   const char * def_spec;
5538   char * vmsfspec, *vmsdefspec;
5539   char * esa;
5540   char * esal = NULL;
5541   char * outbufl;
5542   struct FAB myfab = cc$rms_fab;
5543   rms_setup_nam(mynam);
5544   STRLEN speclen;
5545   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5546   int sts;
5547
5548   /* temp hack until UTF8 is actually implemented */
5549   if (fs_utf8 != NULL)
5550     *fs_utf8 = 0;
5551
5552   if (!filespec || !*filespec) {
5553     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5554     return NULL;
5555   }
5556
5557   vmsfspec = NULL;
5558   vmsdefspec = NULL;
5559   outbufl = NULL;
5560
5561   in_spec = filespec;
5562   isunix = 0;
5563   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5564       char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5565       int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5566
5567       /* If this is a UNIX file spec, convert it to VMS */
5568       sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5569                            &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5570                            &e_len, &vs_spec, &vs_len);
5571       if (sts != 0) {
5572           isunix = 1;
5573           char * ret_spec;
5574
5575           vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5576           if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5577           ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5578           if (ret_spec == NULL) {
5579               PerlMem_free(vmsfspec);
5580               return NULL;
5581           }
5582           in_spec = (const char *)vmsfspec;
5583
5584           /* Unless we are forcing to VMS format, a UNIX input means
5585            * UNIX output, and that requires long names to be used
5586            */
5587           if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5588 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5589               opts |= PERL_RMSEXPAND_M_LONG;
5590 #endif
5591           else
5592               isunix = 0;
5593       }
5594
5595   }
5596
5597   rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5598   rms_bind_fab_nam(myfab, mynam);
5599
5600   /* Process the default file specification if present */
5601   def_spec = defspec;
5602   if (defspec && *defspec) {
5603     int t_isunix;
5604     t_isunix = is_unix_filespec(defspec);
5605     if (t_isunix) {
5606       vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
5607       if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5608       ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5609
5610       if (ret_spec == NULL) {
5611           /* Clean up and bail */
5612           PerlMem_free(vmsdefspec);
5613           if (vmsfspec != NULL)
5614               PerlMem_free(vmsfspec);
5615               return NULL;
5616           }
5617           def_spec = (const char *)vmsdefspec;
5618       }
5619       rms_set_dna(myfab, mynam,
5620                   (char *)def_spec, strlen(def_spec)); /* cast ok */
5621   }
5622
5623   /* Now we need the expansion buffers */
5624   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5625   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5626 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5627   esal = PerlMem_malloc(VMS_MAXRSS);
5628   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5629 #endif
5630   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5631
5632   /* If a NAML block is used RMS always writes to the long and short
5633    * addresses unless you suppress the short name.
5634    */
5635 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5636   outbufl = PerlMem_malloc(VMS_MAXRSS);
5637   if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5638 #endif
5639    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5640
5641 #ifdef NAM$M_NO_SHORT_UPCASE
5642   if (decc_efs_case_preserve)
5643     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5644 #endif
5645
5646    /* We may not want to follow symbolic links */
5647 #ifdef NAML$M_OPEN_SPECIAL
5648   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5649     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5650 #endif
5651
5652   /* First attempt to parse as an existing file */
5653   retsts = sys$parse(&myfab,0,0);
5654   if (!(retsts & STS$K_SUCCESS)) {
5655
5656     /* Could not find the file, try as syntax only if error is not fatal */
5657     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5658     if (retsts == RMS$_DNF ||
5659         retsts == RMS$_DIR ||
5660         retsts == RMS$_DEV ||
5661         retsts == RMS$_PRV) {
5662       retsts = sys$parse(&myfab,0,0);
5663       if (retsts & STS$K_SUCCESS) goto int_expanded;
5664     }
5665
5666      /* Still could not parse the file specification */
5667     /*----------------------------------------------*/
5668     sts = rms_free_search_context(&myfab); /* Free search context */
5669     if (vmsdefspec != NULL)
5670         PerlMem_free(vmsdefspec);
5671     if (vmsfspec != NULL)
5672         PerlMem_free(vmsfspec);
5673     if (outbufl != NULL)
5674         PerlMem_free(outbufl);
5675     PerlMem_free(esa);
5676     if (esal != NULL)
5677         PerlMem_free(esal);
5678     set_vaxc_errno(retsts);
5679     if      (retsts == RMS$_PRV) set_errno(EACCES);
5680     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5681     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5682     else                         set_errno(EVMSERR);
5683     return NULL;
5684   }
5685   retsts = sys$search(&myfab,0,0);
5686   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5687     sts = rms_free_search_context(&myfab); /* Free search context */
5688     if (vmsdefspec != NULL)
5689         PerlMem_free(vmsdefspec);
5690     if (vmsfspec != NULL)
5691         PerlMem_free(vmsfspec);
5692     if (outbufl != NULL)
5693         PerlMem_free(outbufl);
5694     PerlMem_free(esa);
5695     if (esal != NULL)
5696         PerlMem_free(esal);
5697     set_vaxc_errno(retsts);
5698     if      (retsts == RMS$_PRV) set_errno(EACCES);
5699     else                         set_errno(EVMSERR);
5700     return NULL;
5701   }
5702
5703   /* If the input filespec contained any lowercase characters,
5704    * downcase the result for compatibility with Unix-minded code. */
5705 int_expanded:
5706   if (!decc_efs_case_preserve) {
5707     char * tbuf;
5708     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5709       if (islower(*tbuf)) { haslower = 1; break; }
5710   }
5711
5712    /* Is a long or a short name expected */
5713   /*------------------------------------*/
5714   spec_buf = NULL;
5715   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5716     if (rms_nam_rsll(mynam)) {
5717         spec_buf = outbufl;
5718         speclen = rms_nam_rsll(mynam);
5719     }
5720     else {
5721         spec_buf = esal; /* Not esa */
5722         speclen = rms_nam_esll(mynam);
5723     }
5724   }
5725   else {
5726     if (rms_nam_rsl(mynam)) {
5727         spec_buf = outbuf;
5728         speclen = rms_nam_rsl(mynam);
5729     }
5730     else {
5731         spec_buf = esa; /* Not esal */
5732         speclen = rms_nam_esl(mynam);
5733     }
5734   }
5735   spec_buf[speclen] = '\0';
5736
5737   /* Trim off null fields added by $PARSE
5738    * If type > 1 char, must have been specified in original or default spec
5739    * (not true for version; $SEARCH may have added version of existing file).
5740    */
5741   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5742   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5743     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5744              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5745   }
5746   else {
5747     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5748              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5749   }
5750   if (trimver || trimtype) {
5751     if (defspec && *defspec) {
5752       char *defesal = NULL;
5753       char *defesa = NULL;
5754       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5755       if (defesa != NULL) {
5756         struct FAB deffab = cc$rms_fab;
5757 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5758         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5759         if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5760 #endif
5761         rms_setup_nam(defnam);
5762
5763         rms_bind_fab_nam(deffab, defnam);
5764
5765         /* Cast ok */
5766         rms_set_fna
5767             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5768
5769         /* RMS needs the esa/esal as a work area if wildcards are involved */
5770         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5771
5772         rms_clear_nam_nop(defnam);
5773         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5774 #ifdef NAM$M_NO_SHORT_UPCASE
5775         if (decc_efs_case_preserve)
5776           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5777 #endif
5778 #ifdef NAML$M_OPEN_SPECIAL
5779         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5780           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5781 #endif
5782         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5783           if (trimver) {
5784              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5785           }
5786           if (trimtype) {
5787             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5788           }
5789         }
5790         if (defesal != NULL)
5791             PerlMem_free(defesal);
5792         PerlMem_free(defesa);
5793       } else {
5794           _ckvmssts_noperl(SS$_INSFMEM);
5795       }
5796     }
5797     if (trimver) {
5798       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5799         if (*(rms_nam_verl(mynam)) != '\"')
5800           speclen = rms_nam_verl(mynam) - spec_buf;
5801       }
5802       else {
5803         if (*(rms_nam_ver(mynam)) != '\"')
5804           speclen = rms_nam_ver(mynam) - spec_buf;
5805       }
5806     }
5807     if (trimtype) {
5808       /* If we didn't already trim version, copy down */
5809       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5810         if (speclen > rms_nam_verl(mynam) - spec_buf)
5811           memmove
5812            (rms_nam_typel(mynam),
5813             rms_nam_verl(mynam),
5814             speclen - (rms_nam_verl(mynam) - spec_buf));
5815           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5816       }
5817       else {
5818         if (speclen > rms_nam_ver(mynam) - spec_buf)
5819           memmove
5820            (rms_nam_type(mynam),
5821             rms_nam_ver(mynam),
5822             speclen - (rms_nam_ver(mynam) - spec_buf));
5823           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5824       }
5825     }
5826   }
5827
5828    /* Done with these copies of the input files */
5829   /*-------------------------------------------*/
5830   if (vmsfspec != NULL)
5831         PerlMem_free(vmsfspec);
5832   if (vmsdefspec != NULL)
5833         PerlMem_free(vmsdefspec);
5834
5835   /* If we just had a directory spec on input, $PARSE "helpfully"
5836    * adds an empty name and type for us */
5837 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5838   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5839     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5840         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5841         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5842       speclen = rms_nam_namel(mynam) - spec_buf;
5843   }
5844   else
5845 #endif
5846   {
5847     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5848         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5849         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5850       speclen = rms_nam_name(mynam) - spec_buf;
5851   }
5852
5853   /* Posix format specifications must have matching quotes */
5854   if (speclen < (VMS_MAXRSS - 1)) {
5855     if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5856       if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5857         spec_buf[speclen] = '\"';
5858         speclen++;
5859       }
5860     }
5861   }
5862   spec_buf[speclen] = '\0';
5863   if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5864
5865   /* Have we been working with an expanded, but not resultant, spec? */
5866   /* Also, convert back to Unix syntax if necessary. */
5867   {
5868   int rsl;
5869
5870 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5871     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5872       rsl = rms_nam_rsll(mynam);
5873     } else
5874 #endif
5875     {
5876       rsl = rms_nam_rsl(mynam);
5877     }
5878     if (!rsl) {
5879       /* rsl is not present, it means that spec_buf is either */
5880       /* esa or esal, and needs to be copied to outbuf */
5881       /* convert to Unix if desired */
5882       if (isunix) {
5883         ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5884       } else {
5885         /* VMS file specs are not in UTF-8 */
5886         if (fs_utf8 != NULL)
5887             *fs_utf8 = 0;
5888         strcpy(outbuf, spec_buf);
5889         ret_spec = outbuf;
5890       }
5891     }
5892     else {
5893       /* Now spec_buf is either outbuf or outbufl */
5894       /* We need the result into outbuf */
5895       if (isunix) {
5896            /* If we need this in UNIX, then we need another buffer */
5897            /* to keep things in order */
5898            char * src;
5899            char * new_src = NULL;
5900            if (spec_buf == outbuf) {
5901                new_src = PerlMem_malloc(VMS_MAXRSS);
5902                strcpy(new_src, spec_buf);
5903            } else {
5904                src = spec_buf;
5905            }
5906            ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5907            if (new_src) {
5908                PerlMem_free(new_src);
5909            }
5910       } else {
5911            /* VMS file specs are not in UTF-8 */
5912            if (fs_utf8 != NULL)
5913                *fs_utf8 = 0;
5914
5915            /* Copy the buffer if needed */
5916            if (outbuf != spec_buf)
5917                strcpy(outbuf, spec_buf);
5918            ret_spec = outbuf;
5919       }
5920     }
5921   }
5922
5923   /* Need to clean up the search context */
5924   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5925   sts = rms_free_search_context(&myfab); /* Free search context */
5926
5927   /* Clean up the extra buffers */
5928   if (esal != NULL)
5929       PerlMem_free(esal);
5930   PerlMem_free(esa);
5931   if (outbufl != NULL)
5932      PerlMem_free(outbufl);
5933
5934   /* Return the result */
5935   return ret_spec;
5936 }
5937
5938 /* Common simple case - Expand an already VMS spec */
5939 static char *
5940 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5941     opts |= PERL_RMSEXPAND_M_VMS_IN;
5942     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5943 }
5944
5945 /* Common simple case - Expand to a VMS spec */
5946 static char *
5947 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5948     opts |= PERL_RMSEXPAND_M_VMS;
5949     return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5950 }
5951
5952
5953 /* Entry point used by perl routines */
5954 static char *
5955 mp_do_rmsexpand
5956    (pTHX_ const char *filespec,
5957     char *outbuf,
5958     int ts,
5959     const char *defspec,
5960     unsigned opts,
5961     int * fs_utf8,
5962     int * dfs_utf8)
5963 {
5964     static char __rmsexpand_retbuf[VMS_MAXRSS];
5965     char * expanded, *ret_spec, *ret_buf;
5966
5967     expanded = NULL;
5968     ret_buf = outbuf;
5969     if (ret_buf == NULL) {
5970         if (ts) {
5971             Newx(expanded, VMS_MAXRSS, char);
5972             if (expanded == NULL)
5973                 _ckvmssts(SS$_INSFMEM);
5974             ret_buf = expanded;
5975         } else {
5976             ret_buf = __rmsexpand_retbuf;
5977         }
5978     }
5979
5980
5981     ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5982                              opts, fs_utf8,  dfs_utf8);
5983
5984     if (ret_spec == NULL) {
5985        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5986        if (expanded)
5987            Safefree(expanded);
5988     }
5989
5990     return ret_spec;
5991 }
5992 /*}}}*/
5993 /* External entry points */
5994 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5995 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5996 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5997 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5998 char *Perl_rmsexpand_utf8
5999   (pTHX_ const char *spec, char *buf, const char *def,
6000    unsigned opt, int * fs_utf8, int * dfs_utf8)
6001 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
6002 char *Perl_rmsexpand_utf8_ts
6003   (pTHX_ const char *spec, char *buf, const char *def,
6004    unsigned opt, int * fs_utf8, int * dfs_utf8)
6005 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
6006
6007
6008 /*
6009 ** The following routines are provided to make life easier when
6010 ** converting among VMS-style and Unix-style directory specifications.
6011 ** All will take input specifications in either VMS or Unix syntax. On
6012 ** failure, all return NULL.  If successful, the routines listed below
6013 ** return a pointer to a buffer containing the appropriately
6014 ** reformatted spec (and, therefore, subsequent calls to that routine
6015 ** will clobber the result), while the routines of the same names with
6016 ** a _ts suffix appended will return a pointer to a mallocd string
6017 ** containing the appropriately reformatted spec.
6018 ** In all cases, only explicit syntax is altered; no check is made that
6019 ** the resulting string is valid or that the directory in question
6020 ** actually exists.
6021 **
6022 **   fileify_dirspec() - convert a directory spec into the name of the
6023 **     directory file (i.e. what you can stat() to see if it's a dir).
6024 **     The style (VMS or Unix) of the result is the same as the style
6025 **     of the parameter passed in.
6026 **   pathify_dirspec() - convert a directory spec into a path (i.e.
6027 **     what you prepend to a filename to indicate what directory it's in).
6028 **     The style (VMS or Unix) of the result is the same as the style
6029 **     of the parameter passed in.
6030 **   tounixpath() - convert a directory spec into a Unix-style path.
6031 **   tovmspath() - convert a directory spec into a VMS-style path.
6032 **   tounixspec() - convert any file spec into a Unix-style file spec.
6033 **   tovmsspec() - convert any file spec into a VMS-style spec.
6034 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
6035 **
6036 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
6037 ** Permission is given to distribute this code as part of the Perl
6038 ** standard distribution under the terms of the GNU General Public
6039 ** License or the Perl Artistic License.  Copies of each may be
6040 ** found in the Perl standard distribution.
6041  */
6042
6043 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6044 static char *
6045 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
6046 {
6047     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
6048     char *cp1, *cp2, *lastdir;
6049     char *trndir, *vmsdir;
6050     unsigned short int trnlnm_iter_count;
6051     int is_vms = 0;
6052     int is_unix = 0;
6053     int sts;
6054     if (utf8_fl != NULL)
6055         *utf8_fl = 0;
6056
6057     if (!dir || !*dir) {
6058       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6059     }
6060     dirlen = strlen(dir);
6061     while (dirlen && dir[dirlen-1] == '/') --dirlen;
6062     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
6063       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
6064         dir = "/sys$disk";
6065         dirlen = 9;
6066       }
6067       else
6068         dirlen = 1;
6069     }
6070     if (dirlen > (VMS_MAXRSS - 1)) {
6071       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6072       return NULL;
6073     }
6074     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
6075     if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6076     if (!strpbrk(dir+1,"/]>:")  &&
6077         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
6078       strcpy(trndir,*dir == '/' ? dir + 1: dir);
6079       trnlnm_iter_count = 0;
6080       while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6081         trnlnm_iter_count++;
6082         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6083       }
6084       dirlen = strlen(trndir);
6085     }
6086     else {
6087       strncpy(trndir,dir,dirlen);
6088       trndir[dirlen] = '\0';
6089     }
6090
6091     /* At this point we are done with *dir and use *trndir which is a
6092      * copy that can be modified.  *dir must not be modified.
6093      */
6094
6095     /* If we were handed a rooted logical name or spec, treat it like a
6096      * simple directory, so that
6097      *    $ Define myroot dev:[dir.]
6098      *    ... do_fileify_dirspec("myroot",buf,1) ...
6099      * does something useful.
6100      */
6101     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6102       trndir[--dirlen] = '\0';
6103       trndir[dirlen-1] = ']';
6104     }
6105     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6106       trndir[--dirlen] = '\0';
6107       trndir[dirlen-1] = '>';
6108     }
6109
6110     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6111       /* If we've got an explicit filename, we can just shuffle the string. */
6112       if (*(cp1+1)) hasfilename = 1;
6113       /* Similarly, we can just back up a level if we've got multiple levels
6114          of explicit directories in a VMS spec which ends with directories. */
6115       else {
6116         for (cp2 = cp1; cp2 > trndir; cp2--) {
6117           if (*cp2 == '.') {
6118             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6119 /* fix-me, can not scan EFS file specs backward like this */
6120               *cp2 = *cp1; *cp1 = '\0';
6121               hasfilename = 1;
6122               break;
6123             }
6124           }
6125           if (*cp2 == '[' || *cp2 == '<') break;
6126         }
6127       }
6128     }
6129
6130     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
6131     if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6132     cp1 = strpbrk(trndir,"]:>");
6133     if (hasfilename || !cp1) { /* filename present or not VMS */
6134
6135       if (decc_efs_charset && !cp1) {
6136
6137           /* EFS handling for UNIX mode */
6138
6139           /* Just remove the trailing '/' and we should be done */
6140           STRLEN trndir_len;
6141           trndir_len = strlen(trndir);
6142
6143           if (trndir_len > 1) {
6144               trndir_len--;
6145               if (trndir[trndir_len] == '/') {
6146                   trndir[trndir_len] = '\0';
6147               }
6148           }
6149           strcpy(buf, trndir);
6150           PerlMem_free(trndir);
6151           PerlMem_free(vmsdir);
6152           return buf;
6153       }
6154
6155       /* For non-EFS mode, this is left for backwards compatibility */
6156       /* For EFS mode, this is only done for VMS format filespecs as */
6157       /* Perl programs generally have problems when a UNIX format spec */
6158       /* returns a VMS format spec */
6159       if (trndir[0] == '.') {
6160         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6161           PerlMem_free(trndir);
6162           PerlMem_free(vmsdir);
6163           return int_fileify_dirspec("[]", buf, NULL);
6164         }
6165         else if (trndir[1] == '.' &&
6166                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6167           PerlMem_free(trndir);
6168           PerlMem_free(vmsdir);
6169           return int_fileify_dirspec("[-]", buf, NULL);
6170         }
6171       }
6172       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
6173         dirlen -= 1;                 /* to last element */
6174         lastdir = strrchr(trndir,'/');
6175       }
6176       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6177         /* If we have "/." or "/..", VMSify it and let the VMS code
6178          * below expand it, rather than repeating the code to handle
6179          * relative components of a filespec here */
6180         do {
6181           if (*(cp1+2) == '.') cp1++;
6182           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6183             char * ret_chr;
6184             if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6185                 PerlMem_free(trndir);
6186                 PerlMem_free(vmsdir);
6187                 return NULL;
6188             }
6189             if (strchr(vmsdir,'/') != NULL) {
6190               /* If int_tovmsspec() returned it, it must have VMS syntax
6191                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
6192                * the time to check this here only so we avoid a recursion
6193                * loop; otherwise, gigo.
6194                */
6195               PerlMem_free(trndir);
6196               PerlMem_free(vmsdir);
6197               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
6198               return NULL;
6199             }
6200             if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6201                 PerlMem_free(trndir);
6202                 PerlMem_free(vmsdir);
6203                 return NULL;
6204             }
6205             ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6206             PerlMem_free(trndir);
6207             PerlMem_free(vmsdir);
6208             return ret_chr;
6209           }
6210           cp1++;
6211         } while ((cp1 = strstr(cp1,"/.")) != NULL);
6212         lastdir = strrchr(trndir,'/');
6213       }
6214       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6215         char * ret_chr;
6216         /* Ditto for specs that end in an MFD -- let the VMS code
6217          * figure out whether it's a real device or a rooted logical. */
6218
6219         /* This should not happen any more.  Allowing the fake /000000
6220          * in a UNIX pathname causes all sorts of problems when trying
6221          * to run in UNIX emulation.  So the VMS to UNIX conversions
6222          * now remove the fake /000000 directories.
6223          */
6224
6225         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6226         if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6227             PerlMem_free(trndir);
6228             PerlMem_free(vmsdir);
6229             return NULL;
6230         }
6231         if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6232             PerlMem_free(trndir);
6233             PerlMem_free(vmsdir);
6234             return NULL;
6235         }
6236         ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6237         PerlMem_free(trndir);
6238         PerlMem_free(vmsdir);
6239         return ret_chr;
6240       }
6241       else {
6242
6243         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6244              !(lastdir = cp1 = strrchr(trndir,']')) &&
6245              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6246
6247         cp2 = strrchr(cp1,'.');
6248         if (cp2) {
6249             int e_len, vs_len = 0;
6250             int is_dir = 0;
6251             char * cp3;
6252             cp3 = strchr(cp2,';');
6253             e_len = strlen(cp2);
6254             if (cp3) {
6255                 vs_len = strlen(cp3);
6256                 e_len = e_len - vs_len;
6257             }
6258             is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6259             if (!is_dir) {
6260                 if (!decc_efs_charset) {
6261                     /* If this is not EFS, then not a directory */
6262                     PerlMem_free(trndir);
6263                     PerlMem_free(vmsdir);
6264                     set_errno(ENOTDIR);
6265                     set_vaxc_errno(RMS$_DIR);
6266                     return NULL;
6267                 }
6268             } else {
6269                 /* Ok, here we have an issue, technically if a .dir shows */
6270                 /* from inside a directory, then we should treat it as */
6271                 /* xxx^.dir.dir.  But we do not have that context at this */
6272                 /* point unless this is totally restructured, so we remove */
6273                 /* The .dir for now, and fix this better later */
6274                 dirlen = cp2 - trndir;
6275             }
6276         }
6277
6278       }
6279
6280       retlen = dirlen + 6;
6281       memcpy(buf, trndir, dirlen);
6282       buf[dirlen] = '\0';
6283
6284       /* We've picked up everything up to the directory file name.
6285          Now just add the type and version, and we're set. */
6286
6287       /* We should only add type for VMS syntax, but historically Perl
6288          has added it for UNIX style also */
6289
6290       /* Fix me - we should not be using the same routine for VMS and
6291          UNIX format files.  Things are too tangled so we need to lookup
6292          what syntax the output is */
6293
6294       is_unix = 0;
6295       is_vms = 0;
6296       lastdir = strrchr(trndir,'/');
6297       if (lastdir) {
6298           is_unix = 1;
6299       } else {
6300           lastdir = strpbrk(trndir,"]:>");
6301           if (lastdir) {
6302               is_vms = 1;
6303           }
6304       }
6305
6306       if ((is_vms == 0) && (is_unix == 0)) {
6307           /* We still do not  know? */
6308           is_unix = decc_filename_unix_report;
6309           if (is_unix == 0)
6310               is_vms = 1;
6311       }
6312
6313       if ((is_unix && !decc_efs_charset) || is_vms) {
6314
6315            /* It is a bug to add a .dir to a UNIX format directory spec */
6316            /* However Perl on VMS may have programs that expect this so */
6317            /* If not using EFS character specifications allow it. */
6318
6319            if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
6320                /* Traditionally Perl expects filenames in lower case */
6321                strcat(buf, ".dir");
6322            } else {
6323                /* VMS expects the .DIR to be in upper case */
6324                strcat(buf, ".DIR");
6325            }
6326
6327            /* It is also a bug to put a VMS format version on a UNIX file */
6328            /* specification.  Perl self tests are looking for this */
6329            if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
6330                strcat(buf, ";1");
6331       }
6332       PerlMem_free(trndir);
6333       PerlMem_free(vmsdir);
6334       return buf;
6335     }
6336     else {  /* VMS-style directory spec */
6337
6338       char *esa, *esal, term, *cp;
6339       char *my_esa;
6340       int my_esa_len;
6341       unsigned long int sts, cmplen, haslower = 0;
6342       unsigned int nam_fnb;
6343       char * nam_type;
6344       struct FAB dirfab = cc$rms_fab;
6345       rms_setup_nam(savnam);
6346       rms_setup_nam(dirnam);
6347
6348       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6349       if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6350       esal = NULL;
6351 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6352       esal = PerlMem_malloc(VMS_MAXRSS);
6353       if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6354 #endif
6355       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6356       rms_bind_fab_nam(dirfab, dirnam);
6357       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6358       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6359 #ifdef NAM$M_NO_SHORT_UPCASE
6360       if (decc_efs_case_preserve)
6361         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6362 #endif
6363
6364       for (cp = trndir; *cp; cp++)
6365         if (islower(*cp)) { haslower = 1; break; }
6366       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6367         if ((dirfab.fab$l_sts == RMS$_DIR) ||
6368             (dirfab.fab$l_sts == RMS$_DNF) ||
6369             (dirfab.fab$l_sts == RMS$_PRV)) {
6370             rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6371             sts = sys$parse(&dirfab);
6372         }
6373         if (!sts) {
6374           PerlMem_free(esa);
6375           if (esal != NULL)
6376               PerlMem_free(esal);
6377           PerlMem_free(trndir);
6378           PerlMem_free(vmsdir);
6379           set_errno(EVMSERR);
6380           set_vaxc_errno(dirfab.fab$l_sts);
6381           return NULL;
6382         }
6383       }
6384       else {
6385         savnam = dirnam;
6386         /* Does the file really exist? */
6387         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6388           /* Yes; fake the fnb bits so we'll check type below */
6389           rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6390         }
6391         else { /* No; just work with potential name */
6392           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6393           else {
6394             int fab_sts;
6395             fab_sts = dirfab.fab$l_sts;
6396             sts = rms_free_search_context(&dirfab);
6397             PerlMem_free(esa);
6398             if (esal != NULL)
6399                 PerlMem_free(esal);
6400             PerlMem_free(trndir);
6401             PerlMem_free(vmsdir);
6402             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6403             return NULL;
6404           }
6405         }
6406       }
6407
6408       /* Make sure we are using the right buffer */
6409       if (esal != NULL) {
6410         my_esa = esal;
6411         my_esa_len = rms_nam_esll(dirnam);
6412       } else {
6413         my_esa = esa;
6414         my_esa_len = rms_nam_esl(dirnam);
6415       }
6416       my_esa[my_esa_len] = '\0';
6417       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6418         cp1 = strchr(my_esa,']');
6419         if (!cp1) cp1 = strchr(my_esa,'>');
6420         if (cp1) {  /* Should always be true */
6421           my_esa_len -= cp1 - my_esa - 1;
6422           memmove(my_esa, cp1 + 1, my_esa_len);
6423         }
6424       }
6425       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6426         /* Yep; check version while we're at it, if it's there. */
6427         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6428         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6429           /* Something other than .DIR[;1].  Bzzt. */
6430           sts = rms_free_search_context(&dirfab);
6431           PerlMem_free(esa);
6432           if (esal != NULL)
6433              PerlMem_free(esal);
6434           PerlMem_free(trndir);
6435           PerlMem_free(vmsdir);
6436           set_errno(ENOTDIR);
6437           set_vaxc_errno(RMS$_DIR);
6438           return NULL;
6439         }
6440       }
6441
6442       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6443         /* They provided at least the name; we added the type, if necessary, */
6444         strcpy(buf, my_esa);
6445         sts = rms_free_search_context(&dirfab);
6446         PerlMem_free(trndir);
6447         PerlMem_free(esa);
6448         if (esal != NULL)
6449             PerlMem_free(esal);
6450         PerlMem_free(vmsdir);
6451         return buf;
6452       }
6453       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6454         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6455         *cp1 = '\0';
6456         my_esa_len -= 9;
6457       }
6458       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6459       if (cp1 == NULL) { /* should never happen */
6460         sts = rms_free_search_context(&dirfab);
6461         PerlMem_free(trndir);
6462         PerlMem_free(esa);
6463         if (esal != NULL)
6464             PerlMem_free(esal);
6465         PerlMem_free(vmsdir);
6466         return NULL;
6467       }
6468       term = *cp1;
6469       *cp1 = '\0';
6470       retlen = strlen(my_esa);
6471       cp1 = strrchr(my_esa,'.');
6472       /* ODS-5 directory specifications can have extra "." in them. */
6473       /* Fix-me, can not scan EFS file specifications backwards */
6474       while (cp1 != NULL) {
6475         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6476           break;
6477         else {
6478            cp1--;
6479            while ((cp1 > my_esa) && (*cp1 != '.'))
6480              cp1--;
6481         }
6482         if (cp1 == my_esa)
6483           cp1 = NULL;
6484       }
6485
6486       if ((cp1) != NULL) {
6487         /* There's more than one directory in the path.  Just roll back. */
6488         *cp1 = term;
6489         strcpy(buf, my_esa);
6490       }
6491       else {
6492         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6493           /* Go back and expand rooted logical name */
6494           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6495 #ifdef NAM$M_NO_SHORT_UPCASE
6496           if (decc_efs_case_preserve)
6497             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6498 #endif
6499           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6500             sts = rms_free_search_context(&dirfab);
6501             PerlMem_free(esa);
6502             if (esal != NULL)
6503                 PerlMem_free(esal);
6504             PerlMem_free(trndir);
6505             PerlMem_free(vmsdir);
6506             set_errno(EVMSERR);
6507             set_vaxc_errno(dirfab.fab$l_sts);
6508             return NULL;
6509           }
6510
6511           /* This changes the length of the string of course */
6512           if (esal != NULL) {
6513               my_esa_len = rms_nam_esll(dirnam);
6514           } else {
6515               my_esa_len = rms_nam_esl(dirnam);
6516           }
6517
6518           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6519           cp1 = strstr(my_esa,"][");
6520           if (!cp1) cp1 = strstr(my_esa,"]<");
6521           dirlen = cp1 - my_esa;
6522           memcpy(buf, my_esa, dirlen);
6523           if (!strncmp(cp1+2,"000000]",7)) {
6524             buf[dirlen-1] = '\0';
6525             /* fix-me Not full ODS-5, just extra dots in directories for now */
6526             cp1 = buf + dirlen - 1;
6527             while (cp1 > buf)
6528             {
6529               if (*cp1 == '[')
6530                 break;
6531               if (*cp1 == '.') {
6532                 if (*(cp1-1) != '^')
6533                   break;
6534               }
6535               cp1--;
6536             }
6537             if (*cp1 == '.') *cp1 = ']';
6538             else {
6539               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6540               memmove(cp1+1,"000000]",7);
6541             }
6542           }
6543           else {
6544             memmove(buf+dirlen, cp1+2, retlen-dirlen);
6545             buf[retlen] = '\0';
6546             /* Convert last '.' to ']' */
6547             cp1 = buf+retlen-1;
6548             while (*cp != '[') {
6549               cp1--;
6550               if (*cp1 == '.') {
6551                 /* Do not trip on extra dots in ODS-5 directories */
6552                 if ((cp1 == buf) || (*(cp1-1) != '^'))
6553                 break;
6554               }
6555             }
6556             if (*cp1 == '.') *cp1 = ']';
6557             else {
6558               memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6559               memmove(cp1+1,"000000]",7);
6560             }
6561           }
6562         }
6563         else {  /* This is a top-level dir.  Add the MFD to the path. */
6564           cp1 = my_esa;
6565           cp2 = buf;
6566           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6567           strcpy(cp2,":[000000]");
6568           cp1 += 2;
6569           strcpy(cp2+9,cp1);
6570         }
6571       }
6572       sts = rms_free_search_context(&dirfab);
6573       /* We've set up the string up through the filename.  Add the
6574          type and version, and we're done. */
6575       strcat(buf,".DIR;1");
6576
6577       /* $PARSE may have upcased filespec, so convert output to lower
6578        * case if input contained any lowercase characters. */
6579       if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6580       PerlMem_free(trndir);
6581       PerlMem_free(esa);
6582       if (esal != NULL)
6583         PerlMem_free(esal);
6584       PerlMem_free(vmsdir);
6585       return buf;
6586     }
6587 }  /* end of int_fileify_dirspec() */
6588
6589
6590 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6591 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6592 {
6593     static char __fileify_retbuf[VMS_MAXRSS];
6594     char * fileified, *ret_spec, *ret_buf;
6595
6596     fileified = NULL;
6597     ret_buf = buf;
6598     if (ret_buf == NULL) {
6599         if (ts) {
6600             Newx(fileified, VMS_MAXRSS, char);
6601             if (fileified == NULL)
6602                 _ckvmssts(SS$_INSFMEM);
6603             ret_buf = fileified;
6604         } else {
6605             ret_buf = __fileify_retbuf;
6606         }
6607     }
6608
6609     ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6610
6611     if (ret_spec == NULL) {
6612        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6613        if (fileified)
6614            Safefree(fileified);
6615     }
6616
6617     return ret_spec;
6618 }  /* end of do_fileify_dirspec() */
6619 /*}}}*/
6620
6621 /* External entry points */
6622 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6623 { return do_fileify_dirspec(dir,buf,0,NULL); }
6624 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6625 { return do_fileify_dirspec(dir,buf,1,NULL); }
6626 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6627 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6628 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6629 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6630
6631 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6632     char * v_spec, int v_len, char * r_spec, int r_len,
6633     char * d_spec, int d_len, char * n_spec, int n_len,
6634     char * e_spec, int e_len, char * vs_spec, int vs_len) {
6635
6636     /* VMS specification - Try to do this the simple way */
6637     if ((v_len + r_len > 0) || (d_len > 0)) {
6638         int is_dir;
6639
6640         /* No name or extension component, already a directory */
6641         if ((n_len + e_len + vs_len) == 0) {
6642             strcpy(buf, dir);
6643             return buf;
6644         }
6645
6646         /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6647         /* This results from catfile() being used instead of catdir() */
6648         /* So even though it should not work, we need to allow it */
6649
6650         /* If this is .DIR;1 then do a simple conversion */
6651         is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6652         if (is_dir || (e_len == 0) && (d_len > 0)) {
6653              int len;
6654              len = v_len + r_len + d_len - 1;
6655              char dclose = d_spec[d_len - 1];
6656              strncpy(buf, dir, len);
6657              buf[len] = '.';
6658              len++;
6659              strncpy(&buf[len], n_spec, n_len);
6660              len += n_len;
6661              buf[len] = dclose;
6662              buf[len + 1] = '\0';
6663              return buf;
6664         }
6665
6666 #ifdef HAS_SYMLINK
6667         else if (d_len > 0) {
6668             /* In the olden days, a directory needed to have a .DIR */
6669             /* extension to be a valid directory, but now it could  */
6670             /* be a symbolic link */
6671             int len;
6672             len = v_len + r_len + d_len - 1;
6673             char dclose = d_spec[d_len - 1];
6674             strncpy(buf, dir, len);
6675             buf[len] = '.';
6676             len++;
6677             strncpy(&buf[len], n_spec, n_len);
6678             len += n_len;
6679             if (e_len > 0) {
6680                 if (decc_efs_charset) {
6681                     buf[len] = '^';
6682                     len++;
6683                     strncpy(&buf[len], e_spec, e_len);
6684                     len += e_len;
6685                 } else {
6686                     set_vaxc_errno(RMS$_DIR);
6687                     set_errno(ENOTDIR);
6688                     return NULL;
6689                 }
6690             }
6691             buf[len] = dclose;
6692             buf[len + 1] = '\0';
6693             return buf;
6694         }
6695 #else
6696         else {
6697             set_vaxc_errno(RMS$_DIR);
6698             set_errno(ENOTDIR);
6699             return NULL;
6700         }
6701 #endif
6702     }
6703     set_vaxc_errno(RMS$_DIR);
6704     set_errno(ENOTDIR);
6705     return NULL;
6706 }
6707
6708
6709 /* Internal routine to make sure or convert a directory to be in a */
6710 /* path specification.  No utf8 flag because it is not changed or used */
6711 static char *int_pathify_dirspec(const char *dir, char *buf)
6712 {
6713     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6714     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6715     char * exp_spec, *ret_spec;
6716     char * trndir;
6717     unsigned short int trnlnm_iter_count;
6718     STRLEN trnlen;
6719     int need_to_lower;
6720
6721     if (vms_debug_fileify) {
6722         if (dir == NULL)
6723             fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6724         else
6725             fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6726     }
6727
6728     /* We may need to lower case the result if we translated  */
6729     /* a logical name or got the current working directory */
6730     need_to_lower = 0;
6731
6732     if (!dir || !*dir) {
6733       set_errno(EINVAL);
6734       set_vaxc_errno(SS$_BADPARAM);
6735       return NULL;
6736     }
6737
6738     trndir = PerlMem_malloc(VMS_MAXRSS);
6739     if (trndir == NULL)
6740         _ckvmssts_noperl(SS$_INSFMEM);
6741
6742     /* If no directory specified use the current default */
6743     if (*dir)
6744         strcpy(trndir, dir);
6745     else {
6746         getcwd(trndir, VMS_MAXRSS - 1);
6747         need_to_lower = 1;
6748     }
6749
6750     /* now deal with bare names that could be logical names */
6751     trnlnm_iter_count = 0;
6752     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6753            && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6754         trnlnm_iter_count++;
6755         need_to_lower = 1;
6756         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6757             break;
6758         trnlen = strlen(trndir);
6759
6760         /* Trap simple rooted lnms, and return lnm:[000000] */
6761         if (!strcmp(trndir+trnlen-2,".]")) {
6762             strcpy(buf, dir);
6763             strcat(buf, ":[000000]");
6764             PerlMem_free(trndir);
6765
6766             if (vms_debug_fileify) {
6767                 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6768             }
6769             return buf;
6770         }
6771     }
6772
6773     /* At this point we do not work with *dir, but the copy in  *trndir */
6774
6775     if (need_to_lower && !decc_efs_case_preserve) {
6776         /* Legacy mode, lower case the returned value */
6777         __mystrtolower(trndir);
6778     }
6779
6780
6781     /* Some special cases, '..', '.' */
6782     sts = 0;
6783     if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6784        /* Force UNIX filespec */
6785        sts = 1;
6786
6787     } else {
6788         /* Is this Unix or VMS format? */
6789         sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6790                              &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6791                              &e_len, &vs_spec, &vs_len);
6792         if (sts == 0) {
6793
6794             /* Just a filename? */
6795             if ((v_len + r_len + d_len) == 0) {
6796
6797                 /* Now we have a problem, this could be Unix or VMS */
6798                 /* We have to guess.  .DIR usually means VMS */
6799
6800                 /* In UNIX report mode, the .DIR extension is removed */
6801                 /* if one shows up, it is for a non-directory or a directory */
6802                 /* in EFS charset mode */
6803
6804                 /* So if we are in Unix report mode, assume that this */
6805                 /* is a relative Unix directory specification */
6806
6807                 sts = 1;
6808                 if (!decc_filename_unix_report && decc_efs_charset) {
6809                     int is_dir;
6810                     is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6811
6812                     if (is_dir) {
6813                         /* Traditional mode, assume .DIR is directory */
6814                         buf[0] = '[';
6815                         buf[1] = '.';
6816                         strncpy(&buf[2], n_spec, n_len);
6817                         buf[n_len + 2] = ']';
6818                         buf[n_len + 3] = '\0';
6819                         PerlMem_free(trndir);
6820                         if (vms_debug_fileify) {
6821                             fprintf(stderr,
6822                                     "int_pathify_dirspec: buf = %s\n",
6823                                     buf);
6824                         }
6825                         return buf;
6826                     }
6827                 }
6828             }
6829         }
6830     }
6831     if (sts == 0) {
6832         ret_spec = int_pathify_dirspec_simple(trndir, buf,
6833             v_spec, v_len, r_spec, r_len,
6834             d_spec, d_len, n_spec, n_len,
6835             e_spec, e_len, vs_spec, vs_len);
6836
6837         if (ret_spec != NULL) {
6838             PerlMem_free(trndir);
6839             if (vms_debug_fileify) {
6840                 fprintf(stderr,
6841                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6842             }
6843             return ret_spec;
6844         }
6845
6846         /* Simple way did not work, which means that a logical name */
6847         /* was present for the directory specification.             */
6848         /* Need to use an rmsexpand variant to decode it completely */
6849         exp_spec = PerlMem_malloc(VMS_MAXRSS);
6850         if (exp_spec == NULL)
6851             _ckvmssts_noperl(SS$_INSFMEM);
6852
6853         ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6854         if (ret_spec != NULL) {
6855             sts = vms_split_path(exp_spec, &v_spec, &v_len,
6856                                  &r_spec, &r_len, &d_spec, &d_len,
6857                                  &n_spec, &n_len, &e_spec,
6858                                  &e_len, &vs_spec, &vs_len);
6859             if (sts == 0) {
6860                 ret_spec = int_pathify_dirspec_simple(
6861                     exp_spec, buf, v_spec, v_len, r_spec, r_len,
6862                     d_spec, d_len, n_spec, n_len,
6863                     e_spec, e_len, vs_spec, vs_len);
6864
6865                 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6866                     /* Legacy mode, lower case the returned value */
6867                     __mystrtolower(ret_spec);
6868                 }
6869             } else {
6870                 set_vaxc_errno(RMS$_DIR);
6871                 set_errno(ENOTDIR);
6872                 ret_spec = NULL;
6873             }
6874         }
6875         PerlMem_free(exp_spec);
6876         PerlMem_free(trndir);
6877         if (vms_debug_fileify) {
6878             if (ret_spec == NULL)
6879                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6880             else
6881                 fprintf(stderr,
6882                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6883         }
6884         return ret_spec;
6885
6886     } else {
6887         /* Unix specification, Could be trivial conversion */
6888         STRLEN dir_len;
6889         dir_len = strlen(trndir);
6890
6891         /* If the extended file character set is in effect */
6892         /* then pathify is simple */
6893
6894         if (!decc_efs_charset) {
6895             /* Have to deal with traiing '.dir' or extra '.' */
6896             /* that should not be there in legacy mode, but is */
6897
6898             char * lastdot;
6899             char * lastslash;
6900             int is_dir;
6901
6902             lastslash = strrchr(trndir, '/');
6903             if (lastslash == NULL)
6904                 lastslash = trndir;
6905             else
6906                 lastslash++;
6907
6908             lastdot = NULL;
6909
6910             /* '..' or '.' are valid directory components */
6911             is_dir = 0;
6912             if (lastslash[0] == '.') {
6913                 if (lastslash[1] == '\0') {
6914                    is_dir = 1;
6915                 } else if (lastslash[1] == '.') {
6916                     if (lastslash[2] == '\0') {
6917                         is_dir = 1;
6918                     } else {
6919                         /* And finally allow '...' */
6920                         if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6921                             is_dir = 1;
6922                         }
6923                     }
6924                 }
6925             }
6926
6927             if (!is_dir) {
6928                lastdot = strrchr(lastslash, '.');
6929             }
6930             if (lastdot != NULL) {
6931                 STRLEN e_len;
6932
6933                 /* '.dir' is discarded, and any other '.' is invalid */
6934                 e_len = strlen(lastdot);
6935
6936                 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6937
6938                 if (is_dir) {
6939                     dir_len = dir_len - 4;
6940
6941                 }
6942             }
6943         }
6944
6945         strcpy(buf, trndir);
6946         if (buf[dir_len - 1] != '/') {
6947             buf[dir_len] = '/';
6948             buf[dir_len + 1] = '\0';
6949         }
6950
6951         /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6952         if (!decc_efs_charset) {
6953              int dir_start = 0;
6954              char * str = buf;
6955              if (str[0] == '.') {
6956                  char * dots = str;
6957                  int cnt = 1;
6958                  while ((dots[cnt] == '.') && (cnt < 3))
6959                      cnt++;
6960                  if (cnt <= 3) {
6961                      if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6962                          dir_start = 1;
6963                          str += cnt;
6964                      }
6965                  }
6966              }
6967              for (; *str; ++str) {
6968                  while (*str == '/') {
6969                      dir_start = 1;
6970                      *str++;
6971                  }
6972                  if (dir_start) {
6973
6974                      /* Have to skip up to three dots which could be */
6975                      /* directories, 3 dots being a VMS extension for Perl */
6976                      char * dots = str;
6977                      int cnt = 0;
6978                      while ((dots[cnt] == '.') && (cnt < 3)) {
6979                          cnt++;
6980                      }
6981                      if (dots[cnt] == '\0')
6982                          break;
6983                      if ((cnt > 1) && (dots[cnt] != '/')) {
6984                          dir_start = 0;
6985                      } else {
6986                          str += cnt;
6987                      }
6988
6989                      /* too many dots? */
6990                      if ((cnt == 0) || (cnt > 3)) {
6991                          dir_start = 0;
6992                      }
6993                  }
6994                  if (!dir_start && (*str == '.')) {
6995                      *str = '_';
6996                  }
6997              }
6998         }
6999         PerlMem_free(trndir);
7000         ret_spec = buf;
7001         if (vms_debug_fileify) {
7002             if (ret_spec == NULL)
7003                 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
7004             else
7005                 fprintf(stderr,
7006                         "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
7007         }
7008         return ret_spec;
7009     }
7010 }
7011
7012 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
7013 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
7014 {
7015     static char __pathify_retbuf[VMS_MAXRSS];
7016     char * pathified, *ret_spec, *ret_buf;
7017
7018     pathified = NULL;
7019     ret_buf = buf;
7020     if (ret_buf == NULL) {
7021         if (ts) {
7022             Newx(pathified, VMS_MAXRSS, char);
7023             if (pathified == NULL)
7024                 _ckvmssts(SS$_INSFMEM);
7025             ret_buf = pathified;
7026         } else {
7027             ret_buf = __pathify_retbuf;
7028         }
7029     }
7030
7031     ret_spec = int_pathify_dirspec(dir, ret_buf);
7032
7033     if (ret_spec == NULL) {
7034        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7035        if (pathified)
7036            Safefree(pathified);
7037     }
7038
7039     return ret_spec;
7040
7041 }  /* end of do_pathify_dirspec() */
7042
7043
7044 /* External entry points */
7045 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
7046 { return do_pathify_dirspec(dir,buf,0,NULL); }
7047 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
7048 { return do_pathify_dirspec(dir,buf,1,NULL); }
7049 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
7050 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
7051 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
7052 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
7053
7054 /* Internal tounixspec routine that does not use a thread context */
7055 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
7056 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
7057 {
7058   char *dirend, *cp1, *cp3, *tmp;
7059   const char *cp2;
7060   int devlen, dirlen, retlen = VMS_MAXRSS;
7061   int expand = 1; /* guarantee room for leading and trailing slashes */
7062   unsigned short int trnlnm_iter_count;
7063   int cmp_rslt;
7064   if (utf8_fl != NULL)
7065     *utf8_fl = 0;
7066
7067   if (vms_debug_fileify) {
7068       if (spec == NULL)
7069           fprintf(stderr, "int_tounixspec: spec = NULL\n");
7070       else
7071           fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7072   }
7073
7074
7075   if (spec == NULL) {
7076       set_errno(EINVAL);
7077       set_vaxc_errno(SS$_BADPARAM);
7078       return NULL;
7079   }
7080   if (strlen(spec) > (VMS_MAXRSS-1)) {
7081       set_errno(E2BIG);
7082       set_vaxc_errno(SS$_BUFFEROVF);
7083       return NULL;
7084   }
7085
7086   /* New VMS specific format needs translation
7087    * glob passes filenames with trailing '\n' and expects this preserved.
7088    */
7089   if (decc_posix_compliant_pathnames) {
7090     if (strncmp(spec, "\"^UP^", 5) == 0) {
7091       char * uspec;
7092       char *tunix;
7093       int tunix_len;
7094       int nl_flag;
7095
7096       tunix = PerlMem_malloc(VMS_MAXRSS);
7097       if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7098       strcpy(tunix, spec);
7099       tunix_len = strlen(tunix);
7100       nl_flag = 0;
7101       if (tunix[tunix_len - 1] == '\n') {
7102         tunix[tunix_len - 1] = '\"';
7103         tunix[tunix_len] = '\0';
7104         tunix_len--;
7105         nl_flag = 1;
7106       }
7107       uspec = decc$translate_vms(tunix);
7108       PerlMem_free(tunix);
7109       if ((int)uspec > 0) {
7110         strcpy(rslt,uspec);
7111         if (nl_flag) {
7112           strcat(rslt,"\n");
7113         }
7114         else {
7115           /* If we can not translate it, makemaker wants as-is */
7116           strcpy(rslt, spec);
7117         }
7118         return rslt;
7119       }
7120     }
7121   }
7122
7123   cmp_rslt = 0; /* Presume VMS */
7124   cp1 = strchr(spec, '/');
7125   if (cp1 == NULL)
7126     cmp_rslt = 0;
7127
7128     /* Look for EFS ^/ */
7129     if (decc_efs_charset) {
7130       while (cp1 != NULL) {
7131         cp2 = cp1 - 1;
7132         if (*cp2 != '^') {
7133           /* Found illegal VMS, assume UNIX */
7134           cmp_rslt = 1;
7135           break;
7136         }
7137       cp1++;
7138       cp1 = strchr(cp1, '/');
7139     }
7140   }
7141
7142   /* Look for "." and ".." */
7143   if (decc_filename_unix_report) {
7144     if (spec[0] == '.') {
7145       if ((spec[1] == '\0') || (spec[1] == '\n')) {
7146         cmp_rslt = 1;
7147       }
7148       else {
7149         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7150           cmp_rslt = 1;
7151         }
7152       }
7153     }
7154   }
7155   /* This is already UNIX or at least nothing VMS understands */
7156   if (cmp_rslt) {
7157     strcpy(rslt,spec);
7158     if (vms_debug_fileify) {
7159         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7160     }
7161     return rslt;
7162   }
7163
7164   cp1 = rslt;
7165   cp2 = spec;
7166   dirend = strrchr(spec,']');
7167   if (dirend == NULL) dirend = strrchr(spec,'>');
7168   if (dirend == NULL) dirend = strchr(spec,':');
7169   if (dirend == NULL) {
7170     strcpy(rslt,spec);
7171     if (vms_debug_fileify) {
7172         fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7173     }
7174     return rslt;
7175   }
7176
7177   /* Special case 1 - sys$posix_root = / */
7178 #if __CRTL_VER >= 70000000
7179   if (!decc_disable_posix_root) {
7180     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7181       *cp1 = '/';
7182       cp1++;
7183       cp2 = cp2 + 15;
7184       }
7185   }
7186 #endif
7187
7188   /* Special case 2 - Convert NLA0: to /dev/null */
7189 #if __CRTL_VER < 70000000
7190   cmp_rslt = strncmp(spec,"NLA0:", 5);
7191   if (cmp_rslt != 0)
7192      cmp_rslt = strncmp(spec,"nla0:", 5);
7193 #else
7194   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7195 #endif
7196   if (cmp_rslt == 0) {
7197     strcpy(rslt, "/dev/null");
7198     cp1 = cp1 + 9;
7199     cp2 = cp2 + 5;
7200     if (spec[6] != '\0') {
7201       cp1[9] == '/';
7202       cp1++;
7203       cp2++;
7204     }
7205   }
7206
7207    /* Also handle special case "SYS$SCRATCH:" */
7208 #if __CRTL_VER < 70000000
7209   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
7210   if (cmp_rslt != 0)
7211      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
7212 #else
7213   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7214 #endif
7215   tmp = PerlMem_malloc(VMS_MAXRSS);
7216   if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7217   if (cmp_rslt == 0) {
7218   int islnm;
7219
7220     islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7221     if (!islnm) {
7222       strcpy(rslt, "/tmp");
7223       cp1 = cp1 + 4;
7224       cp2 = cp2 + 12;
7225       if (spec[12] != '\0') {
7226         cp1[4] == '/';
7227         cp1++;
7228         cp2++;
7229       }
7230     }
7231   }
7232
7233   if (*cp2 != '[' && *cp2 != '<') {
7234     *(cp1++) = '/';
7235   }
7236   else {  /* the VMS spec begins with directories */
7237     cp2++;
7238     if (*cp2 == ']' || *cp2 == '>') {
7239       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7240       PerlMem_free(tmp);
7241       return rslt;
7242     }
7243     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7244       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7245         PerlMem_free(tmp);
7246         if (vms_debug_fileify) {
7247             fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7248         }
7249         return NULL;
7250       }
7251       trnlnm_iter_count = 0;
7252       do {
7253         cp3 = tmp;
7254         while (*cp3 != ':' && *cp3) cp3++;
7255         *(cp3++) = '\0';
7256         if (strchr(cp3,']') != NULL) break;
7257         trnlnm_iter_count++;
7258         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7259       } while (vmstrnenv(tmp,tmp,0,fildev,0));
7260       cp1 = rslt;
7261       cp3 = tmp;
7262       *(cp1++) = '/';
7263       while (*cp3) {
7264         *(cp1++) = *(cp3++);
7265         if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7266             PerlMem_free(tmp);
7267             set_errno(ENAMETOOLONG);
7268             set_vaxc_errno(SS$_BUFFEROVF);
7269             if (vms_debug_fileify) {
7270                 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7271             }
7272             return NULL; /* No room */
7273         }
7274       }
7275       *(cp1++) = '/';
7276     }
7277     if ((*cp2 == '^')) {
7278         /* EFS file escape, pass the next character as is */
7279         /* Fix me: HEX encoding for Unicode not implemented */
7280         cp2++;
7281     }
7282     else if ( *cp2 == '.') {
7283       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7284         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7285         cp2 += 3;
7286       }
7287       else cp2++;
7288     }
7289   }
7290   PerlMem_free(tmp);
7291   for (; cp2 <= dirend; cp2++) {
7292     if ((*cp2 == '^')) {
7293         /* EFS file escape, pass the next character as is */
7294         /* Fix me: HEX encoding for Unicode not implemented */
7295         *(cp1++) = *(++cp2);
7296         /* An escaped dot stays as is -- don't convert to slash */
7297         if (*cp2 == '.') cp2++;
7298     }
7299     if (*cp2 == ':') {
7300       *(cp1++) = '/';
7301       if (*(cp2+1) == '[') cp2++;
7302     }
7303     else if (*cp2 == ']' || *cp2 == '>') {
7304       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7305     }
7306     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7307       *(cp1++) = '/';
7308       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7309         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7310                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7311         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7312             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7313       }
7314       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7315         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7316         cp2 += 2;
7317       }
7318     }
7319     else if (*cp2 == '-') {
7320       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7321         while (*cp2 == '-') {
7322           cp2++;
7323           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7324         }
7325         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7326                                                          /* filespecs like */
7327           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
7328           if (vms_debug_fileify) {
7329               fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7330           }
7331           return NULL;
7332         }
7333       }
7334       else *(cp1++) = *cp2;
7335     }
7336     else *(cp1++) = *cp2;
7337   }
7338   /* Translate the rest of the filename. */
7339   while (*cp2) {
7340       int dot_seen;
7341       dot_seen = 0;
7342       switch(*cp2) {
7343       /* Fixme - for compatibility with the CRTL we should be removing */
7344       /* spaces from the file specifications, but this may show that */
7345       /* some tests that were appearing to pass are not really passing */
7346       case '%':
7347           cp2++;
7348           *(cp1++) = '?';
7349           break;
7350       case '^':
7351           /* Fix me hex expansions not implemented */
7352           cp2++;  /* '^.' --> '.' and other. */
7353           if (*cp2) {
7354               if (*cp2 == '_') {
7355                   cp2++;
7356                   *(cp1++) = ' ';
7357               } else {
7358                   *(cp1++) = *(cp2++);
7359               }
7360           }
7361           break;
7362       case ';':
7363           if (decc_filename_unix_no_version) {
7364               /* Easy, drop the version */
7365               while (*cp2)
7366                   cp2++;
7367               break;
7368           } else {
7369               /* Punt - passing the version as a dot will probably */
7370               /* break perl in weird ways, but so did passing */
7371               /* through the ; as a version.  Follow the CRTL and */
7372               /* hope for the best. */
7373               cp2++;
7374               *(cp1++) = '.';
7375           }
7376           break;
7377       case '.':
7378           if (dot_seen) {
7379               /* We will need to fix this properly later */
7380               /* As Perl may be installed on an ODS-5 volume, but not */
7381               /* have the EFS_CHARSET enabled, it still may encounter */
7382               /* filenames with extra dots in them, and a precedent got */
7383               /* set which allowed them to work, that we will uphold here */
7384               /* If extra dots are present in a name and no ^ is on them */
7385               /* VMS assumes that the first one is the extension delimiter */
7386               /* the rest have an implied ^. */
7387
7388               /* this is also a conflict as the . is also a version */
7389               /* delimiter in VMS, */
7390
7391               *(cp1++) = *(cp2++);
7392               break;
7393           }
7394           dot_seen = 1;
7395           /* This is an extension */
7396           if (decc_readdir_dropdotnotype) {
7397               cp2++;
7398               if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7399                   /* Drop the dot for the extension */
7400                   break;
7401               } else {
7402                   *(cp1++) = '.';
7403               }
7404               break;
7405           }
7406       default:
7407           *(cp1++) = *(cp2++);
7408       }
7409   }
7410   *cp1 = '\0';
7411
7412   /* This still leaves /000000/ when working with a
7413    * VMS device root or concealed root.
7414    */
7415   {
7416   int ulen;
7417   char * zeros;
7418
7419       ulen = strlen(rslt);
7420
7421       /* Get rid of "000000/ in rooted filespecs */
7422       if (ulen > 7) {
7423         zeros = strstr(rslt, "/000000/");
7424         if (zeros != NULL) {
7425           int mlen;
7426           mlen = ulen - (zeros - rslt) - 7;
7427           memmove(zeros, &zeros[7], mlen);
7428           ulen = ulen - 7;
7429           rslt[ulen] = '\0';
7430         }
7431       }
7432   }
7433
7434   if (vms_debug_fileify) {
7435       fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7436   }
7437   return rslt;
7438
7439 }  /* end of int_tounixspec() */
7440
7441
7442 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7443 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7444 {
7445     static char __tounixspec_retbuf[VMS_MAXRSS];
7446     char * unixspec, *ret_spec, *ret_buf;
7447
7448     unixspec = NULL;
7449     ret_buf = buf;
7450     if (ret_buf == NULL) {
7451         if (ts) {
7452             Newx(unixspec, VMS_MAXRSS, char);
7453             if (unixspec == NULL)
7454                 _ckvmssts(SS$_INSFMEM);
7455             ret_buf = unixspec;
7456         } else {
7457             ret_buf = __tounixspec_retbuf;
7458         }
7459     }
7460
7461     ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7462
7463     if (ret_spec == NULL) {
7464        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7465        if (unixspec)
7466            Safefree(unixspec);
7467     }
7468
7469     return ret_spec;
7470
7471 }  /* end of do_tounixspec() */
7472 /*}}}*/
7473 /* External entry points */
7474 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7475   { return do_tounixspec(spec,buf,0, NULL); }
7476 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7477   { return do_tounixspec(spec,buf,1, NULL); }
7478 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7479   { return do_tounixspec(spec,buf,0, utf8_fl); }
7480 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7481   { return do_tounixspec(spec,buf,1, utf8_fl); }
7482
7483 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7484
7485 /*
7486  This procedure is used to identify if a path is based in either
7487  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7488  it returns the OpenVMS format directory for it.
7489
7490  It is expecting specifications of only '/' or '/xxxx/'
7491
7492  If a posix root does not exist, or 'xxxx' is not a directory
7493  in the posix root, it returns a failure.
7494
7495  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7496
7497  It is used only internally by posix_to_vmsspec_hardway().
7498  */
7499
7500 static int posix_root_to_vms
7501   (char *vmspath, int vmspath_len,
7502    const char *unixpath,
7503    const int * utf8_fl)
7504 {
7505 int sts;
7506 struct FAB myfab = cc$rms_fab;
7507 rms_setup_nam(mynam);
7508 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7509 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7510 char * esa, * esal, * rsa, * rsal;
7511 char *vms_delim;
7512 int dir_flag;
7513 int unixlen;
7514
7515     dir_flag = 0;
7516     vmspath[0] = '\0';
7517     unixlen = strlen(unixpath);
7518     if (unixlen == 0) {
7519       return RMS$_FNF;
7520     }
7521
7522 #if __CRTL_VER >= 80200000
7523   /* If not a posix spec already, convert it */
7524   if (decc_posix_compliant_pathnames) {
7525     if (strncmp(unixpath,"\"^UP^",5) != 0) {
7526       sprintf(vmspath,"\"^UP^%s\"",unixpath);
7527     }
7528     else {
7529       /* This is already a VMS specification, no conversion */
7530       unixlen--;
7531       strncpy(vmspath,unixpath, vmspath_len);
7532     }
7533   }
7534   else
7535 #endif
7536   {
7537   int path_len;
7538   int i,j;
7539
7540      /* Check to see if this is under the POSIX root */
7541      if (decc_disable_posix_root) {
7542         return RMS$_FNF;
7543      }
7544
7545      /* Skip leading / */
7546      if (unixpath[0] == '/') {
7547         unixpath++;
7548         unixlen--;
7549      }
7550
7551
7552      strcpy(vmspath,"SYS$POSIX_ROOT:");
7553
7554      /* If this is only the / , or blank, then... */
7555      if (unixpath[0] == '\0') {
7556         /* by definition, this is the answer */
7557         return SS$_NORMAL;
7558      }
7559
7560      /* Need to look up a directory */
7561      vmspath[15] = '[';
7562      vmspath[16] = '\0';
7563
7564      /* Copy and add '^' escape characters as needed */
7565      j = 16;
7566      i = 0;
7567      while (unixpath[i] != 0) {
7568      int k;
7569
7570         j += copy_expand_unix_filename_escape
7571             (&vmspath[j], &unixpath[i], &k, utf8_fl);
7572         i += k;
7573      }
7574
7575      path_len = strlen(vmspath);
7576      if (vmspath[path_len - 1] == '/')
7577         path_len--;
7578      vmspath[path_len] = ']';
7579      path_len++;
7580      vmspath[path_len] = '\0';
7581
7582   }
7583   vmspath[vmspath_len] = 0;
7584   if (unixpath[unixlen - 1] == '/')
7585   dir_flag = 1;
7586   esal = PerlMem_malloc(VMS_MAXRSS);
7587   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7588   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7589   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7590   rsal = PerlMem_malloc(VMS_MAXRSS);
7591   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7592   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7593   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7594   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7595   rms_bind_fab_nam(myfab, mynam);
7596   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7597   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7598   if (decc_efs_case_preserve)
7599     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7600 #ifdef NAML$M_OPEN_SPECIAL
7601   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7602 #endif
7603
7604   /* Set up the remaining naml fields */
7605   sts = sys$parse(&myfab);
7606
7607   /* It failed! Try again as a UNIX filespec */
7608   if (!(sts & 1)) {
7609     PerlMem_free(esal);
7610     PerlMem_free(esa);
7611     PerlMem_free(rsal);
7612     PerlMem_free(rsa);
7613     return sts;
7614   }
7615
7616    /* get the Device ID and the FID */
7617    sts = sys$search(&myfab);
7618
7619    /* These are no longer needed */
7620    PerlMem_free(esa);
7621    PerlMem_free(rsal);
7622    PerlMem_free(rsa);
7623
7624    /* on any failure, returned the POSIX ^UP^ filespec */
7625    if (!(sts & 1)) {
7626       PerlMem_free(esal);
7627       return sts;
7628    }
7629    specdsc.dsc$a_pointer = vmspath;
7630    specdsc.dsc$w_length = vmspath_len;
7631
7632    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7633    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7634    sts = lib$fid_to_name
7635       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7636
7637   /* on any failure, returned the POSIX ^UP^ filespec */
7638   if (!(sts & 1)) {
7639      /* This can happen if user does not have permission to read directories */
7640      if (strncmp(unixpath,"\"^UP^",5) != 0)
7641        sprintf(vmspath,"\"^UP^%s\"",unixpath);
7642      else
7643        strcpy(vmspath, unixpath);
7644   }
7645   else {
7646     vmspath[specdsc.dsc$w_length] = 0;
7647
7648     /* Are we expecting a directory? */
7649     if (dir_flag != 0) {
7650     int i;
7651     char *eptr;
7652
7653       eptr = NULL;
7654
7655       i = specdsc.dsc$w_length - 1;
7656       while (i > 0) {
7657       int zercnt;
7658         zercnt = 0;
7659         /* Version must be '1' */
7660         if (vmspath[i--] != '1')
7661           break;
7662         /* Version delimiter is one of ".;" */
7663         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7664           break;
7665         i--;
7666         if (vmspath[i--] != 'R')
7667           break;
7668         if (vmspath[i--] != 'I')
7669           break;
7670         if (vmspath[i--] != 'D')
7671           break;
7672         if (vmspath[i--] != '.')
7673           break;
7674         eptr = &vmspath[i+1];
7675         while (i > 0) {
7676           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7677             if (vmspath[i-1] != '^') {
7678               if (zercnt != 6) {
7679                 *eptr = vmspath[i];
7680                 eptr[1] = '\0';
7681                 vmspath[i] = '.';
7682                 break;
7683               }
7684               else {
7685                 /* Get rid of 6 imaginary zero directory filename */
7686                 vmspath[i+1] = '\0';
7687               }
7688             }
7689           }
7690           if (vmspath[i] == '0')
7691             zercnt++;
7692           else
7693             zercnt = 10;
7694           i--;
7695         }
7696         break;
7697       }
7698     }
7699   }
7700   PerlMem_free(esal);
7701   return sts;
7702 }
7703
7704 /* /dev/mumble needs to be handled special.
7705    /dev/null becomes NLA0:, And there is the potential for other stuff
7706    like /dev/tty which may need to be mapped to something.
7707 */
7708
7709 static int
7710 slash_dev_special_to_vms
7711    (const char * unixptr,
7712     char * vmspath,
7713     int vmspath_len)
7714 {
7715 char * nextslash;
7716 int len;
7717 int cmp;
7718 int islnm;
7719
7720     unixptr += 4;
7721     nextslash = strchr(unixptr, '/');
7722     len = strlen(unixptr);
7723     if (nextslash != NULL)
7724         len = nextslash - unixptr;
7725     cmp = strncmp("null", unixptr, 5);
7726     if (cmp == 0) {
7727         if (vmspath_len >= 6) {
7728             strcpy(vmspath, "_NLA0:");
7729             return SS$_NORMAL;
7730         }
7731     }
7732 }
7733
7734
7735 /* The built in routines do not understand perl's special needs, so
7736     doing a manual conversion from UNIX to VMS
7737
7738     If the utf8_fl is not null and points to a non-zero value, then
7739     treat 8 bit characters as UTF-8.
7740
7741     The sequence starting with '$(' and ending with ')' will be passed
7742     through with out interpretation instead of being escaped.
7743
7744   */
7745 static int posix_to_vmsspec_hardway
7746   (char *vmspath, int vmspath_len,
7747    const char *unixpath,
7748    int dir_flag,
7749    int * utf8_fl) {
7750
7751 char *esa;
7752 const char *unixptr;
7753 const char *unixend;
7754 char *vmsptr;
7755 const char *lastslash;
7756 const char *lastdot;
7757 int unixlen;
7758 int vmslen;
7759 int dir_start;
7760 int dir_dot;
7761 int quoted;
7762 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7763 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7764
7765   if (utf8_fl != NULL)
7766     *utf8_fl = 0;
7767
7768   unixptr = unixpath;
7769   dir_dot = 0;
7770
7771   /* Ignore leading "/" characters */
7772   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7773     unixptr++;
7774   }
7775   unixlen = strlen(unixptr);
7776
7777   /* Do nothing with blank paths */
7778   if (unixlen == 0) {
7779     vmspath[0] = '\0';
7780     return SS$_NORMAL;
7781   }
7782
7783   quoted = 0;
7784   /* This could have a "^UP^ on the front */
7785   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7786     quoted = 1;
7787     unixptr+= 5;
7788     unixlen-= 5;
7789   }
7790
7791   lastslash = strrchr(unixptr,'/');
7792   lastdot = strrchr(unixptr,'.');
7793   unixend = strrchr(unixptr,'\"');
7794   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7795     unixend = unixptr + unixlen;
7796   }
7797
7798   /* last dot is last dot or past end of string */
7799   if (lastdot == NULL)
7800     lastdot = unixptr + unixlen;
7801
7802   /* if no directories, set last slash to beginning of string */
7803   if (lastslash == NULL) {
7804     lastslash = unixptr;
7805   }
7806   else {
7807     /* Watch out for trailing "." after last slash, still a directory */
7808     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7809       lastslash = unixptr + unixlen;
7810     }
7811
7812     /* Watch out for traiing ".." after last slash, still a directory */
7813     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7814       lastslash = unixptr + unixlen;
7815     }
7816
7817     /* dots in directories are aways escaped */
7818     if (lastdot < lastslash)
7819       lastdot = unixptr + unixlen;
7820   }
7821
7822   /* if (unixptr < lastslash) then we are in a directory */
7823
7824   dir_start = 0;
7825
7826   vmsptr = vmspath;
7827   vmslen = 0;
7828
7829   /* Start with the UNIX path */
7830   if (*unixptr != '/') {
7831     /* relative paths */
7832
7833     /* If allowing logical names on relative pathnames, then handle here */
7834     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7835         !decc_posix_compliant_pathnames) {
7836     char * nextslash;
7837     int seg_len;
7838     char * trn;
7839     int islnm;
7840
7841         /* Find the next slash */
7842         nextslash = strchr(unixptr,'/');
7843
7844         esa = PerlMem_malloc(vmspath_len);
7845         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7846
7847         trn = PerlMem_malloc(VMS_MAXRSS);
7848         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7849
7850         if (nextslash != NULL) {
7851
7852             seg_len = nextslash - unixptr;
7853             strncpy(esa, unixptr, seg_len);
7854             esa[seg_len] = 0;
7855         }
7856         else {
7857             strcpy(esa, unixptr);
7858             seg_len = strlen(unixptr);
7859         }
7860         /* trnlnm(section) */
7861         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7862
7863         if (islnm) {
7864             /* Now fix up the directory */
7865
7866             /* Split up the path to find the components */
7867             sts = vms_split_path
7868                   (trn,
7869                    &v_spec,
7870                    &v_len,
7871                    &r_spec,
7872                    &r_len,
7873                    &d_spec,
7874                    &d_len,
7875                    &n_spec,
7876                    &n_len,
7877                    &e_spec,
7878                    &e_len,
7879                    &vs_spec,
7880                    &vs_len);
7881
7882             while (sts == 0) {
7883             char * strt;
7884             int cmp;
7885
7886                 /* A logical name must be a directory  or the full
7887                    specification.  It is only a full specification if
7888                    it is the only component */
7889                 if ((unixptr[seg_len] == '\0') ||
7890                     (unixptr[seg_len+1] == '\0')) {
7891
7892                     /* Is a directory being required? */
7893                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7894                         /* Not a logical name */
7895                         break;
7896                     }
7897
7898
7899                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7900                         /* This must be a directory */
7901                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7902                             strcpy(vmsptr, esa);
7903                             vmslen=strlen(vmsptr);
7904                             vmsptr[vmslen] = ':';
7905                             vmslen++;
7906                             vmsptr[vmslen] = '\0';
7907                             return SS$_NORMAL;
7908                         }
7909                     }
7910
7911                 }
7912
7913
7914                 /* must be dev/directory - ignore version */
7915                 if ((n_len + e_len) != 0)
7916                     break;
7917
7918                 /* transfer the volume */
7919                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7920                     strncpy(vmsptr, v_spec, v_len);
7921                     vmsptr += v_len;
7922                     vmsptr[0] = '\0';
7923                     vmslen += v_len;
7924                 }
7925
7926                 /* unroot the rooted directory */
7927                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7928                     r_spec[0] = '[';
7929                     r_spec[r_len - 1] = ']';
7930
7931                     /* This should not be there, but nothing is perfect */
7932                     if (r_len > 9) {
7933                         cmp = strcmp(&r_spec[1], "000000.");
7934                         if (cmp == 0) {
7935                             r_spec += 7;
7936                             r_spec[7] = '[';
7937                             r_len -= 7;
7938                             if (r_len == 2)
7939                                 r_len = 0;
7940                         }
7941                     }
7942                     if (r_len > 0) {
7943                         strncpy(vmsptr, r_spec, r_len);
7944                         vmsptr += r_len;
7945                         vmslen += r_len;
7946                         vmsptr[0] = '\0';
7947                     }
7948                 }
7949                 /* Bring over the directory. */
7950                 if ((d_len > 0) &&
7951                     ((d_len + vmslen) < vmspath_len)) {
7952                     d_spec[0] = '[';
7953                     d_spec[d_len - 1] = ']';
7954                     if (d_len > 9) {
7955                         cmp = strcmp(&d_spec[1], "000000.");
7956                         if (cmp == 0) {
7957                             d_spec += 7;
7958                             d_spec[7] = '[';
7959                             d_len -= 7;
7960                             if (d_len == 2)
7961                                 d_len = 0;
7962                         }
7963                     }
7964
7965                     if (r_len > 0) {
7966                         /* Remove the redundant root */
7967                         if (r_len > 0) {
7968                             /* remove the ][ */
7969                             vmsptr--;
7970                             vmslen--;
7971                             d_spec++;
7972                             d_len--;
7973                         }
7974                         strncpy(vmsptr, d_spec, d_len);
7975                             vmsptr += d_len;
7976                             vmslen += d_len;
7977                             vmsptr[0] = '\0';
7978                     }
7979                 }
7980                 break;
7981             }
7982         }
7983
7984         PerlMem_free(esa);
7985         PerlMem_free(trn);
7986     }
7987
7988     if (lastslash > unixptr) {
7989     int dotdir_seen;
7990
7991       /* skip leading ./ */
7992       dotdir_seen = 0;
7993       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7994         dotdir_seen = 1;
7995         unixptr++;
7996         unixptr++;
7997       }
7998
7999       /* Are we still in a directory? */
8000       if (unixptr <= lastslash) {
8001         *vmsptr++ = '[';
8002         vmslen = 1;
8003         dir_start = 1;
8004
8005         /* if not backing up, then it is relative forward. */
8006         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
8007               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
8008           *vmsptr++ = '.';
8009           vmslen++;
8010           dir_dot = 1;
8011           }
8012        }
8013        else {
8014          if (dotdir_seen) {
8015            /* Perl wants an empty directory here to tell the difference
8016             * between a DCL commmand and a filename
8017             */
8018           *vmsptr++ = '[';
8019           *vmsptr++ = ']';
8020           vmslen = 2;
8021         }
8022       }
8023     }
8024     else {
8025       /* Handle two special files . and .. */
8026       if (unixptr[0] == '.') {
8027         if (&unixptr[1] == unixend) {
8028           *vmsptr++ = '[';
8029           *vmsptr++ = ']';
8030           vmslen += 2;
8031           *vmsptr++ = '\0';
8032           return SS$_NORMAL;
8033         }
8034         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
8035           *vmsptr++ = '[';
8036           *vmsptr++ = '-';
8037           *vmsptr++ = ']';
8038           vmslen += 3;
8039           *vmsptr++ = '\0';
8040           return SS$_NORMAL;
8041         }
8042       }
8043     }
8044   }
8045   else {        /* Absolute PATH handling */
8046   int sts;
8047   char * nextslash;
8048   int seg_len;
8049     /* Need to find out where root is */
8050
8051     /* In theory, this procedure should never get an absolute POSIX pathname
8052      * that can not be found on the POSIX root.
8053      * In practice, that can not be relied on, and things will show up
8054      * here that are a VMS device name or concealed logical name instead.
8055      * So to make things work, this procedure must be tolerant.
8056      */
8057     esa = PerlMem_malloc(vmspath_len);
8058     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8059
8060     sts = SS$_NORMAL;
8061     nextslash = strchr(&unixptr[1],'/');
8062     seg_len = 0;
8063     if (nextslash != NULL) {
8064     int cmp;
8065       seg_len = nextslash - &unixptr[1];
8066       strncpy(vmspath, unixptr, seg_len + 1);
8067       vmspath[seg_len+1] = 0;
8068       cmp = 1;
8069       if (seg_len == 3) {
8070         cmp = strncmp(vmspath, "dev", 4);
8071         if (cmp == 0) {
8072             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
8073             if (sts = SS$_NORMAL)
8074                 return SS$_NORMAL;
8075         }
8076       }
8077       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
8078     }
8079
8080     if ($VMS_STATUS_SUCCESS(sts)) {
8081       /* This is verified to be a real path */
8082
8083       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8084       if ($VMS_STATUS_SUCCESS(sts)) {
8085         strcpy(vmspath, esa);
8086         vmslen = strlen(vmspath);
8087         vmsptr = vmspath + vmslen;
8088         unixptr++;
8089         if (unixptr < lastslash) {
8090         char * rptr;
8091           vmsptr--;
8092           *vmsptr++ = '.';
8093           dir_start = 1;
8094           dir_dot = 1;
8095           if (vmslen > 7) {
8096           int cmp;
8097             rptr = vmsptr - 7;
8098             cmp = strcmp(rptr,"000000.");
8099             if (cmp == 0) {
8100               vmslen -= 7;
8101               vmsptr -= 7;
8102               vmsptr[1] = '\0';
8103             } /* removing 6 zeros */
8104           } /* vmslen < 7, no 6 zeros possible */
8105         } /* Not in a directory */
8106       } /* Posix root found */
8107       else {
8108         /* No posix root, fall back to default directory */
8109         strcpy(vmspath, "SYS$DISK:[");
8110         vmsptr = &vmspath[10];
8111         vmslen = 10;
8112         if (unixptr > lastslash) {
8113            *vmsptr = ']';
8114            vmsptr++;
8115            vmslen++;
8116         }
8117         else {
8118            dir_start = 1;
8119         }
8120       }
8121     } /* end of verified real path handling */
8122     else {
8123     int add_6zero;
8124     int islnm;
8125
8126       /* Ok, we have a device or a concealed root that is not in POSIX
8127        * or we have garbage.  Make the best of it.
8128        */
8129
8130       /* Posix to VMS destroyed this, so copy it again */
8131       strncpy(vmspath, &unixptr[1], seg_len);
8132       vmspath[seg_len] = 0;
8133       vmslen = seg_len;
8134       vmsptr = &vmsptr[vmslen];
8135       islnm = 0;
8136
8137       /* Now do we need to add the fake 6 zero directory to it? */
8138       add_6zero = 1;
8139       if ((*lastslash == '/') && (nextslash < lastslash)) {
8140         /* No there is another directory */
8141         add_6zero = 0;
8142       }
8143       else {
8144       int trnend;
8145       int cmp;
8146
8147         /* now we have foo:bar or foo:[000000]bar to decide from */
8148         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8149
8150         if (!islnm && !decc_posix_compliant_pathnames) {
8151
8152             cmp = strncmp("bin", vmspath, 4);
8153             if (cmp == 0) {
8154                 /* bin => SYS$SYSTEM: */
8155                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8156             }
8157             else {
8158                 /* tmp => SYS$SCRATCH: */
8159                 cmp = strncmp("tmp", vmspath, 4);
8160                 if (cmp == 0) {
8161                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8162                 }
8163             }
8164         }
8165
8166         trnend = islnm ? islnm - 1 : 0;
8167
8168         /* if this was a logical name, ']' or '>' must be present */
8169         /* if not a logical name, then assume a device and hope. */
8170         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8171
8172         /* if log name and trailing '.' then rooted - treat as device */
8173         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8174
8175         /* Fix me, if not a logical name, a device lookup should be
8176          * done to see if the device is file structured.  If the device
8177          * is not file structured, the 6 zeros should not be put on.
8178          *
8179          * As it is, perl is occasionally looking for dev:[000000]tty.
8180          * which looks a little strange.
8181          *
8182          * Not that easy to detect as "/dev" may be file structured with
8183          * special device files.
8184          */
8185
8186         if ((add_6zero == 0) && (*nextslash == '/') &&
8187             (&nextslash[1] == unixend)) {
8188           /* No real directory present */
8189           add_6zero = 1;
8190         }
8191       }
8192
8193       /* Put the device delimiter on */
8194       *vmsptr++ = ':';
8195       vmslen++;
8196       unixptr = nextslash;
8197       unixptr++;
8198
8199       /* Start directory if needed */
8200       if (!islnm || add_6zero) {
8201         *vmsptr++ = '[';
8202         vmslen++;
8203         dir_start = 1;
8204       }
8205
8206       /* add fake 000000] if needed */
8207       if (add_6zero) {
8208         *vmsptr++ = '0';
8209         *vmsptr++ = '0';
8210         *vmsptr++ = '0';
8211         *vmsptr++ = '0';
8212         *vmsptr++ = '0';
8213         *vmsptr++ = '0';
8214         *vmsptr++ = ']';
8215         vmslen += 7;
8216         dir_start = 0;
8217       }
8218
8219     } /* non-POSIX translation */
8220     PerlMem_free(esa);
8221   } /* End of relative/absolute path handling */
8222
8223   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8224   int dash_flag;
8225   int in_cnt;
8226   int out_cnt;
8227
8228     dash_flag = 0;
8229
8230     if (dir_start != 0) {
8231
8232       /* First characters in a directory are handled special */
8233       while ((*unixptr == '/') ||
8234              ((*unixptr == '.') &&
8235               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8236                 (&unixptr[1]==unixend)))) {
8237       int loop_flag;
8238
8239         loop_flag = 0;
8240
8241         /* Skip redundant / in specification */
8242         while ((*unixptr == '/') && (dir_start != 0)) {
8243           loop_flag = 1;
8244           unixptr++;
8245           if (unixptr == lastslash)
8246             break;
8247         }
8248         if (unixptr == lastslash)
8249           break;
8250
8251         /* Skip redundant ./ characters */
8252         while ((*unixptr == '.') &&
8253                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8254           loop_flag = 1;
8255           unixptr++;
8256           if (unixptr == lastslash)
8257             break;
8258           if (*unixptr == '/')
8259             unixptr++;
8260         }
8261         if (unixptr == lastslash)
8262           break;
8263
8264         /* Skip redundant ../ characters */
8265         while ((*unixptr == '.') && (unixptr[1] == '.') &&
8266              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8267           /* Set the backing up flag */
8268           loop_flag = 1;
8269           dir_dot = 0;
8270           dash_flag = 1;
8271           *vmsptr++ = '-';
8272           vmslen++;
8273           unixptr++; /* first . */
8274           unixptr++; /* second . */
8275           if (unixptr == lastslash)
8276             break;
8277           if (*unixptr == '/') /* The slash */
8278             unixptr++;
8279         }
8280         if (unixptr == lastslash)
8281           break;
8282
8283         /* To do: Perl expects /.../ to be translated to [...] on VMS */
8284         /* Not needed when VMS is pretending to be UNIX. */
8285
8286         /* Is this loop stuck because of too many dots? */
8287         if (loop_flag == 0) {
8288           /* Exit the loop and pass the rest through */
8289           break;
8290         }
8291       }
8292
8293       /* Are we done with directories yet? */
8294       if (unixptr >= lastslash) {
8295
8296         /* Watch out for trailing dots */
8297         if (dir_dot != 0) {
8298             vmslen --;
8299             vmsptr--;
8300         }
8301         *vmsptr++ = ']';
8302         vmslen++;
8303         dash_flag = 0;
8304         dir_start = 0;
8305         if (*unixptr == '/')
8306           unixptr++;
8307       }
8308       else {
8309         /* Have we stopped backing up? */
8310         if (dash_flag) {
8311           *vmsptr++ = '.';
8312           vmslen++;
8313           dash_flag = 0;
8314           /* dir_start continues to be = 1 */
8315         }
8316         if (*unixptr == '-') {
8317           *vmsptr++ = '^';
8318           *vmsptr++ = *unixptr++;
8319           vmslen += 2;
8320           dir_start = 0;
8321
8322           /* Now are we done with directories yet? */
8323           if (unixptr >= lastslash) {
8324
8325             /* Watch out for trailing dots */
8326             if (dir_dot != 0) {
8327               vmslen --;
8328               vmsptr--;
8329             }
8330
8331             *vmsptr++ = ']';
8332             vmslen++;
8333             dash_flag = 0;
8334             dir_start = 0;
8335           }
8336         }
8337       }
8338     }
8339
8340     /* All done? */
8341     if (unixptr >= unixend)
8342       break;
8343
8344     /* Normal characters - More EFS work probably needed */
8345     dir_start = 0;
8346     dir_dot = 0;
8347
8348     switch(*unixptr) {
8349     case '/':
8350         /* remove multiple / */
8351         while (unixptr[1] == '/') {
8352            unixptr++;
8353         }
8354         if (unixptr == lastslash) {
8355           /* Watch out for trailing dots */
8356           if (dir_dot != 0) {
8357             vmslen --;
8358             vmsptr--;
8359           }
8360           *vmsptr++ = ']';
8361         }
8362         else {
8363           dir_start = 1;
8364           *vmsptr++ = '.';
8365           dir_dot = 1;
8366
8367           /* To do: Perl expects /.../ to be translated to [...] on VMS */
8368           /* Not needed when VMS is pretending to be UNIX. */
8369
8370         }
8371         dash_flag = 0;
8372         if (unixptr != unixend)
8373           unixptr++;
8374         vmslen++;
8375         break;
8376     case '.':
8377         if ((unixptr < lastdot) || (unixptr < lastslash) ||
8378             (&unixptr[1] == unixend)) {
8379           *vmsptr++ = '^';
8380           *vmsptr++ = '.';
8381           vmslen += 2;
8382           unixptr++;
8383
8384           /* trailing dot ==> '^..' on VMS */
8385           if (unixptr == unixend) {
8386             *vmsptr++ = '.';
8387             vmslen++;
8388             unixptr++;
8389           }
8390           break;
8391         }
8392
8393         *vmsptr++ = *unixptr++;
8394         vmslen ++;
8395         break;
8396     case '"':
8397         if (quoted && (&unixptr[1] == unixend)) {
8398             unixptr++;
8399             break;
8400         }
8401         in_cnt = copy_expand_unix_filename_escape
8402                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8403         vmsptr += out_cnt;
8404         unixptr += in_cnt;
8405         break;
8406     case '~':
8407     case ';':
8408     case '\\':
8409     case '?':
8410     case ' ':
8411     default:
8412         in_cnt = copy_expand_unix_filename_escape
8413                 (vmsptr, unixptr, &out_cnt, utf8_fl);
8414         vmsptr += out_cnt;
8415         unixptr += in_cnt;
8416         break;
8417     }
8418   }
8419
8420   /* Make sure directory is closed */
8421   if (unixptr == lastslash) {
8422     char *vmsptr2;
8423     vmsptr2 = vmsptr - 1;
8424
8425     if (*vmsptr2 != ']') {
8426       *vmsptr2--;
8427
8428       /* directories do not end in a dot bracket */
8429       if (*vmsptr2 == '.') {
8430         vmsptr2--;
8431
8432         /* ^. is allowed */
8433         if (*vmsptr2 != '^') {
8434           vmsptr--; /* back up over the dot */
8435         }
8436       }
8437       *vmsptr++ = ']';
8438     }
8439   }
8440   else {
8441     char *vmsptr2;
8442     /* Add a trailing dot if a file with no extension */
8443     vmsptr2 = vmsptr - 1;
8444     if ((vmslen > 1) &&
8445         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8446         (*vmsptr2 != ')') && (*lastdot != '.')) {
8447         *vmsptr++ = '.';
8448         vmslen++;
8449     }
8450   }
8451
8452   *vmsptr = '\0';
8453   return SS$_NORMAL;
8454 }
8455 #endif
8456
8457  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8458 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8459 {
8460 char * result;
8461 int utf8_flag;
8462
8463    /* If a UTF8 flag is being passed, honor it */
8464    utf8_flag = 0;
8465    if (utf8_fl != NULL) {
8466      utf8_flag = *utf8_fl;
8467     *utf8_fl = 0;
8468    }
8469
8470    if (utf8_flag) {
8471      /* If there is a possibility of UTF8, then if any UTF8 characters
8472         are present, then they must be converted to VTF-7
8473       */
8474      result = strcpy(rslt, path); /* FIX-ME */
8475    }
8476    else
8477      result = strcpy(rslt, path);
8478
8479    return result;
8480 }
8481
8482
8483
8484 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8485 static char *int_tovmsspec
8486    (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8487   char *dirend;
8488   char *lastdot;
8489   char *vms_delim;
8490   register char *cp1;
8491   const char *cp2;
8492   unsigned long int infront = 0, hasdir = 1;
8493   int rslt_len;
8494   int no_type_seen;
8495   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8496   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8497
8498   if (vms_debug_fileify) {
8499       if (path == NULL)
8500           fprintf(stderr, "int_tovmsspec: path = NULL\n");
8501       else
8502           fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8503   }
8504
8505   if (path == NULL) {
8506       /* If we fail, we should be setting errno */
8507       set_errno(EINVAL);
8508       set_vaxc_errno(SS$_BADPARAM);
8509       return NULL;
8510   }
8511   rslt_len = VMS_MAXRSS-1;
8512
8513   /* '.' and '..' are "[]" and "[-]" for a quick check */
8514   if (path[0] == '.') {
8515     if (path[1] == '\0') {
8516       strcpy(rslt,"[]");
8517       if (utf8_flag != NULL)
8518         *utf8_flag = 0;
8519       return rslt;
8520     }
8521     else {
8522       if (path[1] == '.' && path[2] == '\0') {
8523         strcpy(rslt,"[-]");
8524         if (utf8_flag != NULL)
8525            *utf8_flag = 0;
8526         return rslt;
8527       }
8528     }
8529   }
8530
8531    /* Posix specifications are now a native VMS format */
8532   /*--------------------------------------------------*/
8533 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8534   if (decc_posix_compliant_pathnames) {
8535     if (strncmp(path,"\"^UP^",5) == 0) {
8536       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8537       return rslt;
8538     }
8539   }
8540 #endif
8541
8542   /* This is really the only way to see if this is already in VMS format */
8543   sts = vms_split_path
8544        (path,
8545         &v_spec,
8546         &v_len,
8547         &r_spec,
8548         &r_len,
8549         &d_spec,
8550         &d_len,
8551         &n_spec,
8552         &n_len,
8553         &e_spec,
8554         &e_len,
8555         &vs_spec,
8556         &vs_len);
8557   if (sts == 0) {
8558     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8559        replacement, because the above parse just took care of most of
8560        what is needed to do vmspath when the specification is already
8561        in VMS format.
8562
8563        And if it is not already, it is easier to do the conversion as
8564        part of this routine than to call this routine and then work on
8565        the result.
8566      */
8567
8568     /* If VMS punctuation was found, it is already VMS format */
8569     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8570       if (utf8_flag != NULL)
8571         *utf8_flag = 0;
8572       strcpy(rslt, path);
8573       if (vms_debug_fileify) {
8574           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8575       }
8576       return rslt;
8577     }
8578     /* Now, what to do with trailing "." cases where there is no
8579        extension?  If this is a UNIX specification, and EFS characters
8580        are enabled, then the trailing "." should be converted to a "^.".
8581        But if this was already a VMS specification, then it should be
8582        left alone.
8583
8584        So in the case of ambiguity, leave the specification alone.
8585      */
8586
8587
8588     /* If there is a possibility of UTF8, then if any UTF8 characters
8589         are present, then they must be converted to VTF-7
8590      */
8591     if (utf8_flag != NULL)
8592       *utf8_flag = 0;
8593     strcpy(rslt, path);
8594     if (vms_debug_fileify) {
8595         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8596     }
8597     return rslt;
8598   }
8599
8600   dirend = strrchr(path,'/');
8601
8602   if (dirend == NULL) {
8603      char *macro_start;
8604      int has_macro;
8605
8606      /* If we get here with no UNIX directory delimiters, then this is
8607         not a complete file specification, either garbage a UNIX glob
8608         specification that can not be converted to a VMS wildcard, or
8609         it a UNIX shell macro.  MakeMaker wants shell macros passed
8610         through AS-IS,
8611
8612         utf8 flag setting needs to be preserved.
8613       */
8614       hasdir = 0;
8615
8616       has_macro = 0;
8617       macro_start = strchr(path,'$');
8618       if (macro_start != NULL) {
8619           if (macro_start[1] == '(') {
8620               has_macro = 1;
8621           }
8622       }
8623       if ((decc_efs_charset == 0) || (has_macro)) {
8624           strcpy(rslt, path);
8625           if (vms_debug_fileify) {
8626               fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8627           }
8628           return rslt;
8629       }
8630   }
8631
8632 /* If POSIX mode active, handle the conversion */
8633 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8634   if (decc_efs_charset) {
8635     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8636     if (vms_debug_fileify) {
8637         fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8638     }
8639     return rslt;
8640   }
8641 #endif
8642
8643   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
8644     if (!*(dirend+2)) dirend +=2;
8645     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8646     if (decc_efs_charset == 0) {
8647       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8648     }
8649   }
8650
8651   cp1 = rslt;
8652   cp2 = path;
8653   lastdot = strrchr(cp2,'.');
8654   if (*cp2 == '/') {
8655     char *trndev;
8656     int islnm, rooted;
8657     STRLEN trnend;
8658
8659     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8660     if (!*(cp2+1)) {
8661       if (decc_disable_posix_root) {
8662         strcpy(rslt,"sys$disk:[000000]");
8663       }
8664       else {
8665         strcpy(rslt,"sys$posix_root:[000000]");
8666       }
8667       if (utf8_flag != NULL)
8668         *utf8_flag = 0;
8669       if (vms_debug_fileify) {
8670           fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8671       }
8672       return rslt;
8673     }
8674     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8675     *cp1 = '\0';
8676     trndev = PerlMem_malloc(VMS_MAXRSS);
8677     if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8678     islnm =  simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8679
8680      /* DECC special handling */
8681     if (!islnm) {
8682       if (strcmp(rslt,"bin") == 0) {
8683         strcpy(rslt,"sys$system");
8684         cp1 = rslt + 10;
8685         *cp1 = 0;
8686         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8687       }
8688       else if (strcmp(rslt,"tmp") == 0) {
8689         strcpy(rslt,"sys$scratch");
8690         cp1 = rslt + 11;
8691         *cp1 = 0;
8692         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8693       }
8694       else if (!decc_disable_posix_root) {
8695         strcpy(rslt, "sys$posix_root");
8696         cp1 = rslt + 14;
8697         *cp1 = 0;
8698         cp2 = path;
8699         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8700         islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8701       }
8702       else if (strcmp(rslt,"dev") == 0) {
8703         if (strncmp(cp2,"/null", 5) == 0) {
8704           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8705             strcpy(rslt,"NLA0");
8706             cp1 = rslt + 4;
8707             *cp1 = 0;
8708             cp2 = cp2 + 5;
8709             islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8710           }
8711         }
8712       }
8713     }
8714
8715     trnend = islnm ? strlen(trndev) - 1 : 0;
8716     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8717     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8718     /* If the first element of the path is a logical name, determine
8719      * whether it has to be translated so we can add more directories. */
8720     if (!islnm || rooted) {
8721       *(cp1++) = ':';
8722       *(cp1++) = '[';
8723       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8724       else cp2++;
8725     }
8726     else {
8727       if (cp2 != dirend) {
8728         strcpy(rslt,trndev);
8729         cp1 = rslt + trnend;
8730         if (*cp2 != 0) {
8731           *(cp1++) = '.';
8732           cp2++;
8733         }
8734       }
8735       else {
8736         if (decc_disable_posix_root) {
8737           *(cp1++) = ':';
8738           hasdir = 0;
8739         }
8740       }
8741     }
8742     PerlMem_free(trndev);
8743   }
8744   else {
8745     *(cp1++) = '[';
8746     if (*cp2 == '.') {
8747       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8748         cp2 += 2;         /* skip over "./" - it's redundant */
8749         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8750       }
8751       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8752         *(cp1++) = '-';                                 /* "../" --> "-" */
8753         cp2 += 3;
8754       }
8755       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8756                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8757         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8758         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8759         cp2 += 4;
8760       }
8761       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8762         /* Escape the extra dots in EFS file specifications */
8763         *(cp1++) = '^';
8764       }
8765       if (cp2 > dirend) cp2 = dirend;
8766     }
8767     else *(cp1++) = '.';
8768   }
8769   for (; cp2 < dirend; cp2++) {
8770     if (*cp2 == '/') {
8771       if (*(cp2-1) == '/') continue;
8772       if (*(cp1-1) != '.') *(cp1++) = '.';
8773       infront = 0;
8774     }
8775     else if (!infront && *cp2 == '.') {
8776       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8777       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8778       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8779         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8780         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8781         else {  /* back up over previous directory name */
8782           cp1--;
8783           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8784           if (*(cp1-1) == '[') {
8785             memcpy(cp1,"000000.",7);
8786             cp1 += 7;
8787           }
8788         }
8789         cp2 += 2;
8790         if (cp2 == dirend) break;
8791       }
8792       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8793                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8794         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8795         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8796         if (!*(cp2+3)) {
8797           *(cp1++) = '.';  /* Simulate trailing '/' */
8798           cp2 += 2;  /* for loop will incr this to == dirend */
8799         }
8800         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8801       }
8802       else {
8803         if (decc_efs_charset == 0)
8804           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8805         else {
8806           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8807           *(cp1++) = '.';
8808         }
8809       }
8810     }
8811     else {
8812       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8813       if (*cp2 == '.') {
8814         if (decc_efs_charset == 0)
8815           *(cp1++) = '_';
8816         else {
8817           *(cp1++) = '^';
8818           *(cp1++) = '.';
8819         }
8820       }
8821       else                  *(cp1++) =  *cp2;
8822       infront = 1;
8823     }
8824   }
8825   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8826   if (hasdir) *(cp1++) = ']';
8827   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8828   /* fixme for ODS5 */
8829   no_type_seen = 0;
8830   if (cp2 > lastdot)
8831     no_type_seen = 1;
8832   while (*cp2) {
8833     switch(*cp2) {
8834     case '?':
8835         if (decc_efs_charset == 0)
8836           *(cp1++) = '%';
8837         else
8838           *(cp1++) = '?';
8839         cp2++;
8840     case ' ':
8841         *(cp1)++ = '^';
8842         *(cp1)++ = '_';
8843         cp2++;
8844         break;
8845     case '.':
8846         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8847             decc_readdir_dropdotnotype) {
8848           *(cp1)++ = '^';
8849           *(cp1)++ = '.';
8850           cp2++;
8851
8852           /* trailing dot ==> '^..' on VMS */
8853           if (*cp2 == '\0') {
8854             *(cp1++) = '.';
8855             no_type_seen = 0;
8856           }
8857         }
8858         else {
8859           *(cp1++) = *(cp2++);
8860           no_type_seen = 0;
8861         }
8862         break;
8863     case '$':
8864          /* This could be a macro to be passed through */
8865         *(cp1++) = *(cp2++);
8866         if (*cp2 == '(') {
8867         const char * save_cp2;
8868         char * save_cp1;
8869         int is_macro;
8870
8871             /* paranoid check */
8872             save_cp2 = cp2;
8873             save_cp1 = cp1;
8874             is_macro = 0;
8875
8876             /* Test through */
8877             *(cp1++) = *(cp2++);
8878             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8879                 *(cp1++) = *(cp2++);
8880                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8881                     *(cp1++) = *(cp2++);
8882                 }
8883                 if (*cp2 == ')') {
8884                     *(cp1++) = *(cp2++);
8885                     is_macro = 1;
8886                 }
8887             }
8888             if (is_macro == 0) {
8889                 /* Not really a macro - never mind */
8890                 cp2 = save_cp2;
8891                 cp1 = save_cp1;
8892             }
8893         }
8894         break;
8895     case '\"':
8896     case '~':
8897     case '`':
8898     case '!':
8899     case '#':
8900     case '%':
8901     case '^':
8902         /* Don't escape again if following character is
8903          * already something we escape.
8904          */
8905         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8906             *(cp1++) = *(cp2++);
8907             break;
8908         }
8909         /* But otherwise fall through and escape it. */
8910     case '&':
8911     case '(':
8912     case ')':
8913     case '=':
8914     case '+':
8915     case '\'':
8916     case '@':
8917     case '[':
8918     case ']':
8919     case '{':
8920     case '}':
8921     case ':':
8922     case '\\':
8923     case '|':
8924     case '<':
8925     case '>':
8926         *(cp1++) = '^';
8927         *(cp1++) = *(cp2++);
8928         break;
8929     case ';':
8930         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8931          * which is wrong.  UNIX notation should be ".dir." unless
8932          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8933          * changing this behavior could break more things at this time.
8934          * efs character set effectively does not allow "." to be a version
8935          * delimiter as a further complication about changing this.
8936          */
8937         if (decc_filename_unix_report != 0) {
8938           *(cp1++) = '^';
8939         }
8940         *(cp1++) = *(cp2++);
8941         break;
8942     default:
8943         *(cp1++) = *(cp2++);
8944     }
8945   }
8946   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8947   char *lcp1;
8948     lcp1 = cp1;
8949     lcp1--;
8950      /* Fix me for "^]", but that requires making sure that you do
8951       * not back up past the start of the filename
8952       */
8953     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8954       *cp1++ = '.';
8955   }
8956   *cp1 = '\0';
8957
8958   if (utf8_flag != NULL)
8959     *utf8_flag = 0;
8960   if (vms_debug_fileify) {
8961       fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8962   }
8963   return rslt;
8964
8965 }  /* end of int_tovmsspec() */
8966
8967
8968 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8969 static char *mp_do_tovmsspec
8970    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8971   static char __tovmsspec_retbuf[VMS_MAXRSS];
8972     char * vmsspec, *ret_spec, *ret_buf;
8973
8974     vmsspec = NULL;
8975     ret_buf = buf;
8976     if (ret_buf == NULL) {
8977         if (ts) {
8978             Newx(vmsspec, VMS_MAXRSS, char);
8979             if (vmsspec == NULL)
8980                 _ckvmssts(SS$_INSFMEM);
8981             ret_buf = vmsspec;
8982         } else {
8983             ret_buf = __tovmsspec_retbuf;
8984         }
8985     }
8986
8987     ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8988
8989     if (ret_spec == NULL) {
8990        /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8991        if (vmsspec)
8992            Safefree(vmsspec);
8993     }
8994
8995     return ret_spec;
8996
8997 }  /* end of mp_do_tovmsspec() */
8998 /*}}}*/
8999 /* External entry points */
9000 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
9001   { return do_tovmsspec(path,buf,0,NULL); }
9002 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
9003   { return do_tovmsspec(path,buf,1,NULL); }
9004 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9005   { return do_tovmsspec(path,buf,0,utf8_fl); }
9006 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9007   { return do_tovmsspec(path,buf,1,utf8_fl); }
9008
9009 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
9010 /* Internal routine for use with out an explict context present */
9011 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
9012
9013     char * ret_spec, *pathified;
9014
9015     if (path == NULL)
9016         return NULL;
9017
9018     pathified = PerlMem_malloc(VMS_MAXRSS);
9019     if (pathified == NULL)
9020         _ckvmssts_noperl(SS$_INSFMEM);
9021
9022     ret_spec = int_pathify_dirspec(path, pathified);
9023
9024     if (ret_spec == NULL) {
9025         PerlMem_free(pathified);
9026         return NULL;
9027     }
9028
9029     ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
9030
9031     PerlMem_free(pathified);
9032     return ret_spec;
9033
9034 }
9035
9036 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
9037 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9038   static char __tovmspath_retbuf[VMS_MAXRSS];
9039   int vmslen;
9040   char *pathified, *vmsified, *cp;
9041
9042   if (path == NULL) return NULL;
9043   pathified = PerlMem_malloc(VMS_MAXRSS);
9044   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9045   if (int_pathify_dirspec(path, pathified) == NULL) {
9046     PerlMem_free(pathified);
9047     return NULL;
9048   }
9049
9050   vmsified = NULL;
9051   if (buf == NULL)
9052      Newx(vmsified, VMS_MAXRSS, char);
9053   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
9054     PerlMem_free(pathified);
9055     if (vmsified) Safefree(vmsified);
9056     return NULL;
9057   }
9058   PerlMem_free(pathified);
9059   if (buf) {
9060     return buf;
9061   }
9062   else if (ts) {
9063     vmslen = strlen(vmsified);
9064     Newx(cp,vmslen+1,char);
9065     memcpy(cp,vmsified,vmslen);
9066     cp[vmslen] = '\0';
9067     Safefree(vmsified);
9068     return cp;
9069   }
9070   else {
9071     strcpy(__tovmspath_retbuf,vmsified);
9072     Safefree(vmsified);
9073     return __tovmspath_retbuf;
9074   }
9075
9076 }  /* end of do_tovmspath() */
9077 /*}}}*/
9078 /* External entry points */
9079 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
9080   { return do_tovmspath(path,buf,0, NULL); }
9081 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
9082   { return do_tovmspath(path,buf,1, NULL); }
9083 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
9084   { return do_tovmspath(path,buf,0,utf8_fl); }
9085 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
9086   { return do_tovmspath(path,buf,1,utf8_fl); }
9087
9088
9089 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
9090 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9091   static char __tounixpath_retbuf[VMS_MAXRSS];
9092   int unixlen;
9093   char *pathified, *unixified, *cp;
9094
9095   if (path == NULL) return NULL;
9096   pathified = PerlMem_malloc(VMS_MAXRSS);
9097   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9098   if (int_pathify_dirspec(path, pathified) == NULL) {
9099     PerlMem_free(pathified);
9100     return NULL;
9101   }
9102
9103   unixified = NULL;
9104   if (buf == NULL) {
9105       Newx(unixified, VMS_MAXRSS, char);
9106   }
9107   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
9108     PerlMem_free(pathified);
9109     if (unixified) Safefree(unixified);
9110     return NULL;
9111   }
9112   PerlMem_free(pathified);
9113   if (buf) {
9114     return buf;
9115   }
9116   else if (ts) {
9117     unixlen = strlen(unixified);
9118     Newx(cp,unixlen+1,char);
9119     memcpy(cp,unixified,unixlen);
9120     cp[unixlen] = '\0';
9121     Safefree(unixified);
9122     return cp;
9123   }
9124   else {
9125     strcpy(__tounixpath_retbuf,unixified);
9126     Safefree(unixified);
9127     return __tounixpath_retbuf;
9128   }
9129
9130 }  /* end of do_tounixpath() */
9131 /*}}}*/
9132 /* External entry points */
9133 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
9134   { return do_tounixpath(path,buf,0,NULL); }
9135 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9136   { return do_tounixpath(path,buf,1,NULL); }
9137 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9138   { return do_tounixpath(path,buf,0,utf8_fl); }
9139 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9140   { return do_tounixpath(path,buf,1,utf8_fl); }
9141
9142 /*
9143  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
9144  *
9145  *****************************************************************************
9146  *                                                                           *
9147  *  Copyright (C) 1989-1994, 2007 by                                         *
9148  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
9149  *                                                                           *
9150  *  Permission is hereby granted for the reproduction of this software       *
9151  *  on condition that this copyright notice is included in source            *
9152  *  distributions of the software.  The code may be modified and             *
9153  *  distributed under the same terms as Perl itself.                         *
9154  *                                                                           *
9155  *  27-Aug-1994 Modified for inclusion in perl5                              *
9156  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
9157  *****************************************************************************
9158  */
9159
9160 /*
9161  * getredirection() is intended to aid in porting C programs
9162  * to VMS (Vax-11 C).  The native VMS environment does not support
9163  * '>' and '<' I/O redirection, or command line wild card expansion,
9164  * or a command line pipe mechanism using the '|' AND background
9165  * command execution '&'.  All of these capabilities are provided to any
9166  * C program which calls this procedure as the first thing in the
9167  * main program.
9168  * The piping mechanism will probably work with almost any 'filter' type
9169  * of program.  With suitable modification, it may useful for other
9170  * portability problems as well.
9171  *
9172  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
9173  */
9174 struct list_item
9175     {
9176     struct list_item *next;
9177     char *value;
9178     };
9179
9180 static void add_item(struct list_item **head,
9181                      struct list_item **tail,
9182                      char *value,
9183                      int *count);
9184
9185 static void mp_expand_wild_cards(pTHX_ char *item,
9186                                 struct list_item **head,
9187                                 struct list_item **tail,
9188                                 int *count);
9189
9190 static int background_process(pTHX_ int argc, char **argv);
9191
9192 static void pipe_and_fork(pTHX_ char **cmargv);
9193
9194 /*{{{ void getredirection(int *ac, char ***av)*/
9195 static void
9196 mp_getredirection(pTHX_ int *ac, char ***av)
9197 /*
9198  * Process vms redirection arg's.  Exit if any error is seen.
9199  * If getredirection() processes an argument, it is erased
9200  * from the vector.  getredirection() returns a new argc and argv value.
9201  * In the event that a background command is requested (by a trailing "&"),
9202  * this routine creates a background subprocess, and simply exits the program.
9203  *
9204  * Warning: do not try to simplify the code for vms.  The code
9205  * presupposes that getredirection() is called before any data is
9206  * read from stdin or written to stdout.
9207  *
9208  * Normal usage is as follows:
9209  *
9210  *      main(argc, argv)
9211  *      int             argc;
9212  *      char            *argv[];
9213  *      {
9214  *              getredirection(&argc, &argv);
9215  *      }
9216  */
9217 {
9218     int                 argc = *ac;     /* Argument Count         */
9219     char                **argv = *av;   /* Argument Vector        */
9220     char                *ap;            /* Argument pointer       */
9221     int                 j;              /* argv[] index           */
9222     int                 item_count = 0; /* Count of Items in List */
9223     struct list_item    *list_head = 0; /* First Item in List       */
9224     struct list_item    *list_tail;     /* Last Item in List        */
9225     char                *in = NULL;     /* Input File Name          */
9226     char                *out = NULL;    /* Output File Name         */
9227     char                *outmode = "w"; /* Mode to Open Output File */
9228     char                *err = NULL;    /* Error File Name          */
9229     char                *errmode = "w"; /* Mode to Open Error File  */
9230     int                 cmargc = 0;     /* Piped Command Arg Count  */
9231     char                **cmargv = NULL;/* Piped Command Arg Vector */
9232
9233     /*
9234      * First handle the case where the last thing on the line ends with
9235      * a '&'.  This indicates the desire for the command to be run in a
9236      * subprocess, so we satisfy that desire.
9237      */
9238     ap = argv[argc-1];
9239     if (0 == strcmp("&", ap))
9240        exit(background_process(aTHX_ --argc, argv));
9241     if (*ap && '&' == ap[strlen(ap)-1])
9242         {
9243         ap[strlen(ap)-1] = '\0';
9244        exit(background_process(aTHX_ argc, argv));
9245         }
9246     /*
9247      * Now we handle the general redirection cases that involve '>', '>>',
9248      * '<', and pipes '|'.
9249      */
9250     for (j = 0; j < argc; ++j)
9251         {
9252         if (0 == strcmp("<", argv[j]))
9253             {
9254             if (j+1 >= argc)
9255                 {
9256                 fprintf(stderr,"No input file after < on command line");
9257                 exit(LIB$_WRONUMARG);
9258                 }
9259             in = argv[++j];
9260             continue;
9261             }
9262         if ('<' == *(ap = argv[j]))
9263             {
9264             in = 1 + ap;
9265             continue;
9266             }
9267         if (0 == strcmp(">", ap))
9268             {
9269             if (j+1 >= argc)
9270                 {
9271                 fprintf(stderr,"No output file after > on command line");
9272                 exit(LIB$_WRONUMARG);
9273                 }
9274             out = argv[++j];
9275             continue;
9276             }
9277         if ('>' == *ap)
9278             {
9279             if ('>' == ap[1])
9280                 {
9281                 outmode = "a";
9282                 if ('\0' == ap[2])
9283                     out = argv[++j];
9284                 else
9285                     out = 2 + ap;
9286                 }
9287             else
9288                 out = 1 + ap;
9289             if (j >= argc)
9290                 {
9291                 fprintf(stderr,"No output file after > or >> on command line");
9292                 exit(LIB$_WRONUMARG);
9293                 }
9294             continue;
9295             }
9296         if (('2' == *ap) && ('>' == ap[1]))
9297             {
9298             if ('>' == ap[2])
9299                 {
9300                 errmode = "a";
9301                 if ('\0' == ap[3])
9302                     err = argv[++j];
9303                 else
9304                     err = 3 + ap;
9305                 }
9306             else
9307                 if ('\0' == ap[2])
9308                     err = argv[++j];
9309                 else
9310                     err = 2 + ap;
9311             if (j >= argc)
9312                 {
9313                 fprintf(stderr,"No output file after 2> or 2>> on command line");
9314                 exit(LIB$_WRONUMARG);
9315                 }
9316             continue;
9317             }
9318         if (0 == strcmp("|", argv[j]))
9319             {
9320             if (j+1 >= argc)
9321                 {
9322                 fprintf(stderr,"No command into which to pipe on command line");
9323                 exit(LIB$_WRONUMARG);
9324                 }
9325             cmargc = argc-(j+1);
9326             cmargv = &argv[j+1];
9327             argc = j;
9328             continue;
9329             }
9330         if ('|' == *(ap = argv[j]))
9331             {
9332             ++argv[j];
9333             cmargc = argc-j;
9334             cmargv = &argv[j];
9335             argc = j;
9336             continue;
9337             }
9338         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9339         }
9340     /*
9341      * Allocate and fill in the new argument vector, Some Unix's terminate
9342      * the list with an extra null pointer.
9343      */
9344     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9345     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9346     *av = argv;
9347     for (j = 0; j < item_count; ++j, list_head = list_head->next)
9348         argv[j] = list_head->value;
9349     *ac = item_count;
9350     if (cmargv != NULL)
9351         {
9352         if (out != NULL)
9353             {
9354             fprintf(stderr,"'|' and '>' may not both be specified on command line");
9355             exit(LIB$_INVARGORD);
9356             }
9357         pipe_and_fork(aTHX_ cmargv);
9358         }
9359
9360     /* Check for input from a pipe (mailbox) */
9361
9362     if (in == NULL && 1 == isapipe(0))
9363         {
9364         char mbxname[L_tmpnam];
9365         long int bufsize;
9366         long int dvi_item = DVI$_DEVBUFSIZ;
9367         $DESCRIPTOR(mbxnam, "");
9368         $DESCRIPTOR(mbxdevnam, "");
9369
9370         /* Input from a pipe, reopen it in binary mode to disable       */
9371         /* carriage control processing.                                 */
9372
9373         fgetname(stdin, mbxname);
9374         mbxnam.dsc$a_pointer = mbxname;
9375         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9376         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9377         mbxdevnam.dsc$a_pointer = mbxname;
9378         mbxdevnam.dsc$w_length = sizeof(mbxname);
9379         dvi_item = DVI$_DEVNAM;
9380         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9381         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9382         set_errno(0);
9383         set_vaxc_errno(1);
9384         freopen(mbxname, "rb", stdin);
9385         if (errno != 0)
9386             {
9387             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9388             exit(vaxc$errno);
9389             }
9390         }
9391     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9392         {
9393         fprintf(stderr,"Can't open input file %s as stdin",in);
9394         exit(vaxc$errno);
9395         }
9396     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9397         {
9398         fprintf(stderr,"Can't open output file %s as stdout",out);
9399         exit(vaxc$errno);
9400         }
9401         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9402
9403     if (err != NULL) {
9404         if (strcmp(err,"&1") == 0) {
9405             dup2(fileno(stdout), fileno(stderr));
9406             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9407         } else {
9408         FILE *tmperr;
9409         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9410             {
9411             fprintf(stderr,"Can't open error file %s as stderr",err);
9412             exit(vaxc$errno);
9413             }
9414             fclose(tmperr);
9415            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9416                 {
9417                 exit(vaxc$errno);
9418                 }
9419             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9420         }
9421         }
9422 #ifdef ARGPROC_DEBUG
9423     PerlIO_printf(Perl_debug_log, "Arglist:\n");
9424     for (j = 0; j < *ac;  ++j)
9425         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9426 #endif
9427    /* Clear errors we may have hit expanding wildcards, so they don't
9428       show up in Perl's $! later */
9429    set_errno(0); set_vaxc_errno(1);
9430 }  /* end of getredirection() */
9431 /*}}}*/
9432
9433 static void add_item(struct list_item **head,
9434                      struct list_item **tail,
9435                      char *value,
9436                      int *count)
9437 {
9438     if (*head == 0)
9439         {
9440         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9441         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9442         *tail = *head;
9443         }
9444     else {
9445         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9446         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9447         *tail = (*tail)->next;
9448         }
9449     (*tail)->value = value;
9450     ++(*count);
9451 }
9452
9453 static void mp_expand_wild_cards(pTHX_ char *item,
9454                               struct list_item **head,
9455                               struct list_item **tail,
9456                               int *count)
9457 {
9458 int expcount = 0;
9459 unsigned long int context = 0;
9460 int isunix = 0;
9461 int item_len = 0;
9462 char *had_version;
9463 char *had_device;
9464 int had_directory;
9465 char *devdir,*cp;
9466 char *vmsspec;
9467 $DESCRIPTOR(filespec, "");
9468 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9469 $DESCRIPTOR(resultspec, "");
9470 unsigned long int lff_flags = 0;
9471 int sts;
9472 int rms_sts;
9473
9474 #ifdef VMS_LONGNAME_SUPPORT
9475     lff_flags = LIB$M_FIL_LONG_NAMES;
9476 #endif
9477
9478     for (cp = item; *cp; cp++) {
9479         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9480         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9481     }
9482     if (!*cp || isspace(*cp))
9483         {
9484         add_item(head, tail, item, count);
9485         return;
9486         }
9487     else
9488         {
9489      /* "double quoted" wild card expressions pass as is */
9490      /* From DCL that means using e.g.:                  */
9491      /* perl program """perl.*"""                        */
9492      item_len = strlen(item);
9493      if ( '"' == *item && '"' == item[item_len-1] )
9494        {
9495        item++;
9496        item[item_len-2] = '\0';
9497        add_item(head, tail, item, count);
9498        return;
9499        }
9500      }
9501     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9502     resultspec.dsc$b_class = DSC$K_CLASS_D;
9503     resultspec.dsc$a_pointer = NULL;
9504     vmsspec = PerlMem_malloc(VMS_MAXRSS);
9505     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9506     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9507       filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9508     if (!isunix || !filespec.dsc$a_pointer)
9509       filespec.dsc$a_pointer = item;
9510     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9511     /*
9512      * Only return version specs, if the caller specified a version
9513      */
9514     had_version = strchr(item, ';');
9515     /*
9516      * Only return device and directory specs, if the caller specifed either.
9517      */
9518     had_device = strchr(item, ':');
9519     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9520
9521     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9522                                  (&filespec, &resultspec, &context,
9523                                   &defaultspec, 0, &rms_sts, &lff_flags)))
9524         {
9525         char *string;
9526         char *c;
9527
9528         string = PerlMem_malloc(resultspec.dsc$w_length+1);
9529         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9530         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
9531         string[resultspec.dsc$w_length] = '\0';
9532         if (NULL == had_version)
9533             *(strrchr(string, ';')) = '\0';
9534         if ((!had_directory) && (had_device == NULL))
9535             {
9536             if (NULL == (devdir = strrchr(string, ']')))
9537                 devdir = strrchr(string, '>');
9538             strcpy(string, devdir + 1);
9539             }
9540         /*
9541          * Be consistent with what the C RTL has already done to the rest of
9542          * the argv items and lowercase all of these names.
9543          */
9544         if (!decc_efs_case_preserve) {
9545             for (c = string; *c; ++c)
9546             if (isupper(*c))
9547                 *c = tolower(*c);
9548         }
9549         if (isunix) trim_unixpath(string,item,1);
9550         add_item(head, tail, string, count);
9551         ++expcount;
9552     }
9553     PerlMem_free(vmsspec);
9554     if (sts != RMS$_NMF)
9555         {
9556         set_vaxc_errno(sts);
9557         switch (sts)
9558             {
9559             case RMS$_FNF: case RMS$_DNF:
9560                 set_errno(ENOENT); break;
9561             case RMS$_DIR:
9562                 set_errno(ENOTDIR); break;
9563             case RMS$_DEV:
9564                 set_errno(ENODEV); break;
9565             case RMS$_FNM: case RMS$_SYN:
9566                 set_errno(EINVAL); break;
9567             case RMS$_PRV:
9568                 set_errno(EACCES); break;
9569             default:
9570                 _ckvmssts_noperl(sts);
9571             }
9572         }
9573     if (expcount == 0)
9574         add_item(head, tail, item, count);
9575     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9576     _ckvmssts_noperl(lib$find_file_end(&context));
9577 }
9578
9579 static int child_st[2];/* Event Flag set when child process completes   */
9580
9581 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
9582
9583 static unsigned long int exit_handler(int *status)
9584 {
9585 short iosb[4];
9586
9587     if (0 == child_st[0])
9588         {
9589 #ifdef ARGPROC_DEBUG
9590         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9591 #endif
9592         fflush(stdout);     /* Have to flush pipe for binary data to    */
9593                             /* terminate properly -- <tp@mccall.com>    */
9594         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9595         sys$dassgn(child_chan);
9596         fclose(stdout);
9597         sys$synch(0, child_st);
9598         }
9599     return(1);
9600 }
9601
9602 static void sig_child(int chan)
9603 {
9604 #ifdef ARGPROC_DEBUG
9605     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9606 #endif
9607     if (child_st[0] == 0)
9608         child_st[0] = 1;
9609 }
9610
9611 static struct exit_control_block exit_block =
9612     {
9613     0,
9614     exit_handler,
9615     1,
9616     &exit_block.exit_status,
9617     0
9618     };
9619
9620 static void
9621 pipe_and_fork(pTHX_ char **cmargv)
9622 {
9623     PerlIO *fp;
9624     struct dsc$descriptor_s *vmscmd;
9625     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9626     int sts, j, l, ismcr, quote, tquote = 0;
9627
9628     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
9629     vms_execfree(vmscmd);
9630
9631     j = l = 0;
9632     p = subcmd;
9633     q = cmargv[0];
9634     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
9635               && toupper(*(q+2)) == 'R' && !*(q+3);
9636
9637     while (q && l < MAX_DCL_LINE_LENGTH) {
9638         if (!*q) {
9639             if (j > 0 && quote) {
9640                 *p++ = '"';
9641                 l++;
9642             }
9643             q = cmargv[++j];
9644             if (q) {
9645                 if (ismcr && j > 1) quote = 1;
9646                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
9647                 *p++ = ' ';
9648                 l++;
9649                 if (quote || tquote) {
9650                     *p++ = '"';
9651                     l++;
9652                 }
9653             }
9654         } else {
9655             if ((quote||tquote) && *q == '"') {
9656                 *p++ = '"';
9657                 l++;
9658             }
9659             *p++ = *q++;
9660             l++;
9661         }
9662     }
9663     *p = '\0';
9664
9665     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9666     if (fp == NULL) {
9667         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9668     }
9669 }
9670
9671 static int background_process(pTHX_ int argc, char **argv)
9672 {
9673 char command[MAX_DCL_SYMBOL + 1] = "$";
9674 $DESCRIPTOR(value, "");
9675 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9676 static $DESCRIPTOR(null, "NLA0:");
9677 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9678 char pidstring[80];
9679 $DESCRIPTOR(pidstr, "");
9680 int pid;
9681 unsigned long int flags = 17, one = 1, retsts;
9682 int len;
9683
9684     strcat(command, argv[0]);
9685     len = strlen(command);
9686     while (--argc && (len < MAX_DCL_SYMBOL))
9687         {
9688         strcat(command, " \"");
9689         strcat(command, *(++argv));
9690         strcat(command, "\"");
9691         len = strlen(command);
9692         }
9693     value.dsc$a_pointer = command;
9694     value.dsc$w_length = strlen(value.dsc$a_pointer);
9695     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9696     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9697     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9698         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9699     }
9700     else {
9701         _ckvmssts_noperl(retsts);
9702     }
9703 #ifdef ARGPROC_DEBUG
9704     PerlIO_printf(Perl_debug_log, "%s\n", command);
9705 #endif
9706     sprintf(pidstring, "%08X", pid);
9707     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9708     pidstr.dsc$a_pointer = pidstring;
9709     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9710     lib$set_symbol(&pidsymbol, &pidstr);
9711     return(SS$_NORMAL);
9712 }
9713 /*}}}*/
9714 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9715
9716
9717 /* OS-specific initialization at image activation (not thread startup) */
9718 /* Older VAXC header files lack these constants */
9719 #ifndef JPI$_RIGHTS_SIZE
9720 #  define JPI$_RIGHTS_SIZE 817
9721 #endif
9722 #ifndef KGB$M_SUBSYSTEM
9723 #  define KGB$M_SUBSYSTEM 0x8
9724 #endif
9725
9726 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9727
9728 /*{{{void vms_image_init(int *, char ***)*/
9729 void
9730 vms_image_init(int *argcp, char ***argvp)
9731 {
9732   int status;
9733   char eqv[LNM$C_NAMLENGTH+1] = "";
9734   unsigned int len, tabct = 8, tabidx = 0;
9735   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9736   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9737   unsigned short int dummy, rlen;
9738   struct dsc$descriptor_s **tabvec;
9739 #if defined(PERL_IMPLICIT_CONTEXT)
9740   pTHX = NULL;
9741 #endif
9742   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
9743                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
9744                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9745                                  {          0,                0,    0,      0} };
9746
9747 #ifdef KILL_BY_SIGPRC
9748     Perl_csighandler_init();
9749 #endif
9750
9751     /* This was moved from the pre-image init handler because on threaded */
9752     /* Perl it was always returning 0 for the default value. */
9753     status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9754     if (status > 0) {
9755         int s;
9756         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9757         if (s > 0) {
9758             int initial;
9759             initial = decc$feature_get_value(s, 4);
9760             if (initial > 0) {
9761                 /* initial is: 0 if nothing has set the feature */
9762                 /*            -1 if initialized to default */
9763                 /*             1 if set by logical name */
9764                 /*             2 if set by decc$feature_set_value */
9765                 decc_disable_posix_root = decc$feature_get_value(s, 1);
9766
9767                 /* If the value is not valid, force the feature off */
9768                 if (decc_disable_posix_root < 0) {
9769                     decc$feature_set_value(s, 1, 1);
9770                     decc_disable_posix_root = 1;
9771                 }
9772             }
9773             else {
9774                 /* Nothing has asked for it explicitly, so use our own default. */
9775                 decc_disable_posix_root = 1;
9776                 decc$feature_set_value(s, 1, 1);
9777             }
9778         }
9779     }
9780
9781
9782   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9783   _ckvmssts_noperl(iosb[0]);
9784   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9785     if (iprv[i]) {           /* Running image installed with privs? */
9786       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9787       will_taint = TRUE;
9788       break;
9789     }
9790   }
9791   /* Rights identifiers might trigger tainting as well. */
9792   if (!will_taint && (rlen || rsz)) {
9793     while (rlen < rsz) {
9794       /* We didn't get all the identifiers on the first pass.  Allocate a
9795        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9796        * were needed to hold all identifiers at time of last call; we'll
9797        * allocate that many unsigned long ints), and go back and get 'em.
9798        * If it gave us less than it wanted to despite ample buffer space,
9799        * something's broken.  Is your system missing a system identifier?
9800        */
9801       if (rsz <= jpilist[1].buflen) {
9802          /* Perl_croak accvios when used this early in startup. */
9803          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9804                          rsz, (unsigned long) jpilist[1].buflen,
9805                          "Check your rights database for corruption.\n");
9806          exit(SS$_ABORT);
9807       }
9808       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9809       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9810       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9811       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9812       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9813       _ckvmssts_noperl(iosb[0]);
9814     }
9815     mask = jpilist[1].bufadr;
9816     /* Check attribute flags for each identifier (2nd longword); protected
9817      * subsystem identifiers trigger tainting.
9818      */
9819     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9820       if (mask[i] & KGB$M_SUBSYSTEM) {
9821         will_taint = TRUE;
9822         break;
9823       }
9824     }
9825     if (mask != rlst) PerlMem_free(mask);
9826   }
9827
9828   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9829    * logical, some versions of the CRTL will add a phanthom /000000/
9830    * directory.  This needs to be removed.
9831    */
9832   if (decc_filename_unix_report) {
9833   char * zeros;
9834   int ulen;
9835     ulen = strlen(argvp[0][0]);
9836     if (ulen > 7) {
9837       zeros = strstr(argvp[0][0], "/000000/");
9838       if (zeros != NULL) {
9839         int mlen;
9840         mlen = ulen - (zeros - argvp[0][0]) - 7;
9841         memmove(zeros, &zeros[7], mlen);
9842         ulen = ulen - 7;
9843         argvp[0][0][ulen] = '\0';
9844       }
9845     }
9846     /* It also may have a trailing dot that needs to be removed otherwise
9847      * it will be converted to VMS mode incorrectly.
9848      */
9849     ulen--;
9850     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9851       argvp[0][0][ulen] = '\0';
9852   }
9853
9854   /* We need to use this hack to tell Perl it should run with tainting,
9855    * since its tainting flag may be part of the PL_curinterp struct, which
9856    * hasn't been allocated when vms_image_init() is called.
9857    */
9858   if (will_taint) {
9859     char **newargv, **oldargv;
9860     oldargv = *argvp;
9861     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9862     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9863     newargv[0] = oldargv[0];
9864     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9865     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9866     strcpy(newargv[1], "-T");
9867     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9868     (*argcp)++;
9869     newargv[*argcp] = NULL;
9870     /* We orphan the old argv, since we don't know where it's come from,
9871      * so we don't know how to free it.
9872      */
9873     *argvp = newargv;
9874   }
9875   else {  /* Did user explicitly request tainting? */
9876     int i;
9877     char *cp, **av = *argvp;
9878     for (i = 1; i < *argcp; i++) {
9879       if (*av[i] != '-') break;
9880       for (cp = av[i]+1; *cp; cp++) {
9881         if (*cp == 'T') { will_taint = 1; break; }
9882         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9883                   strchr("DFIiMmx",*cp)) break;
9884       }
9885       if (will_taint) break;
9886     }
9887   }
9888
9889   for (tabidx = 0;
9890        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9891        tabidx++) {
9892     if (!tabidx) {
9893       tabvec = (struct dsc$descriptor_s **)
9894             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9895       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9896     }
9897     else if (tabidx >= tabct) {
9898       tabct += 8;
9899       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9900       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9901     }
9902     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9903     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9904     tabvec[tabidx]->dsc$w_length  = 0;
9905     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9906     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9907     tabvec[tabidx]->dsc$a_pointer = NULL;
9908     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9909   }
9910   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9911
9912   getredirection(argcp,argvp);
9913 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9914   {
9915 # include <reentrancy.h>
9916   decc$set_reentrancy(C$C_MULTITHREAD);
9917   }
9918 #endif
9919   return;
9920 }
9921 /*}}}*/
9922
9923
9924 /* trim_unixpath()
9925  * Trim Unix-style prefix off filespec, so it looks like what a shell
9926  * glob expansion would return (i.e. from specified prefix on, not
9927  * full path).  Note that returned filespec is Unix-style, regardless
9928  * of whether input filespec was VMS-style or Unix-style.
9929  *
9930  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9931  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9932  * vector of options; at present, only bit 0 is used, and if set tells
9933  * trim unixpath to try the current default directory as a prefix when
9934  * presented with a possibly ambiguous ... wildcard.
9935  *
9936  * Returns !=0 on success, with trimmed filespec replacing contents of
9937  * fspec, and 0 on failure, with contents of fpsec unchanged.
9938  */
9939 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9940 int
9941 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9942 {
9943   char *unixified, *unixwild,
9944        *template, *base, *end, *cp1, *cp2;
9945   register int tmplen, reslen = 0, dirs = 0;
9946
9947   if (!wildspec || !fspec) return 0;
9948
9949   unixwild = PerlMem_malloc(VMS_MAXRSS);
9950   if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9951   template = unixwild;
9952   if (strpbrk(wildspec,"]>:") != NULL) {
9953     if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9954         PerlMem_free(unixwild);
9955         return 0;
9956     }
9957   }
9958   else {
9959     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9960     unixwild[VMS_MAXRSS-1] = 0;
9961   }
9962   unixified = PerlMem_malloc(VMS_MAXRSS);
9963   if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9964   if (strpbrk(fspec,"]>:") != NULL) {
9965     if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9966         PerlMem_free(unixwild);
9967         PerlMem_free(unixified);
9968         return 0;
9969     }
9970     else base = unixified;
9971     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9972      * check to see that final result fits into (isn't longer than) fspec */
9973     reslen = strlen(fspec);
9974   }
9975   else base = fspec;
9976
9977   /* No prefix or absolute path on wildcard, so nothing to remove */
9978   if (!*template || *template == '/') {
9979     PerlMem_free(unixwild);
9980     if (base == fspec) {
9981         PerlMem_free(unixified);
9982         return 1;
9983     }
9984     tmplen = strlen(unixified);
9985     if (tmplen > reslen) {
9986         PerlMem_free(unixified);
9987         return 0;  /* not enough space */
9988     }
9989     /* Copy unixified resultant, including trailing NUL */
9990     memmove(fspec,unixified,tmplen+1);
9991     PerlMem_free(unixified);
9992     return 1;
9993   }
9994
9995   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9996   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9997     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9998     for (cp1 = end ;cp1 >= base; cp1--)
9999       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
10000         { cp1++; break; }
10001     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
10002     PerlMem_free(unixified);
10003     PerlMem_free(unixwild);
10004     return 1;
10005   }
10006   else {
10007     char *tpl, *lcres;
10008     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
10009     int ells = 1, totells, segdirs, match;
10010     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
10011                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10012
10013     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
10014     totells = ells;
10015     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
10016     tpl = PerlMem_malloc(VMS_MAXRSS);
10017     if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10018     if (ellipsis == template && opts & 1) {
10019       /* Template begins with an ellipsis.  Since we can't tell how many
10020        * directory names at the front of the resultant to keep for an
10021        * arbitrary starting point, we arbitrarily choose the current
10022        * default directory as a starting point.  If it's there as a prefix,
10023        * clip it off.  If not, fall through and act as if the leading
10024        * ellipsis weren't there (i.e. return shortest possible path that
10025        * could match template).
10026        */
10027       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
10028           PerlMem_free(tpl);
10029           PerlMem_free(unixified);
10030           PerlMem_free(unixwild);
10031           return 0;
10032       }
10033       if (!decc_efs_case_preserve) {
10034         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10035           if (_tolower(*cp1) != _tolower(*cp2)) break;
10036       }
10037       segdirs = dirs - totells;  /* Min # of dirs we must have left */
10038       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
10039       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
10040         memmove(fspec,cp2+1,end - cp2);
10041         PerlMem_free(tpl);
10042         PerlMem_free(unixified);
10043         PerlMem_free(unixwild);
10044         return 1;
10045       }
10046     }
10047     /* First off, back up over constant elements at end of path */
10048     if (dirs) {
10049       for (front = end ; front >= base; front--)
10050          if (*front == '/' && !dirs--) { front++; break; }
10051     }
10052     lcres = PerlMem_malloc(VMS_MAXRSS);
10053     if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10054     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
10055          cp1++,cp2++) {
10056             if (!decc_efs_case_preserve) {
10057                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
10058             }
10059             else {
10060                 *cp2 = *cp1;
10061             }
10062     }
10063     if (cp1 != '\0') {
10064         PerlMem_free(tpl);
10065         PerlMem_free(unixified);
10066         PerlMem_free(unixwild);
10067         PerlMem_free(lcres);
10068         return 0;  /* Path too long. */
10069     }
10070     lcend = cp2;
10071     *cp2 = '\0';  /* Pick up with memcpy later */
10072     lcfront = lcres + (front - base);
10073     /* Now skip over each ellipsis and try to match the path in front of it. */
10074     while (ells--) {
10075       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
10076         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
10077             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
10078       if (cp1 < template) break; /* template started with an ellipsis */
10079       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
10080         ellipsis = cp1; continue;
10081       }
10082       wilddsc.dsc$a_pointer = tpl;
10083       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
10084       nextell = cp1;
10085       for (segdirs = 0, cp2 = tpl;
10086            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
10087            cp1++, cp2++) {
10088          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
10089          else {
10090             if (!decc_efs_case_preserve) {
10091               *cp2 = _tolower(*cp1);  /* else lowercase for match */
10092             }
10093             else {
10094               *cp2 = *cp1;  /* else preserve case for match */
10095             }
10096          }
10097          if (*cp2 == '/') segdirs++;
10098       }
10099       if (cp1 != ellipsis - 1) {
10100           PerlMem_free(tpl);
10101           PerlMem_free(unixified);
10102           PerlMem_free(unixwild);
10103           PerlMem_free(lcres);
10104           return 0; /* Path too long */
10105       }
10106       /* Back up at least as many dirs as in template before matching */
10107       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
10108         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
10109       for (match = 0; cp1 > lcres;) {
10110         resdsc.dsc$a_pointer = cp1;
10111         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
10112           match++;
10113           if (match == 1) lcfront = cp1;
10114         }
10115         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
10116       }
10117       if (!match) {
10118         PerlMem_free(tpl);
10119         PerlMem_free(unixified);
10120         PerlMem_free(unixwild);
10121         PerlMem_free(lcres);
10122         return 0;  /* Can't find prefix ??? */
10123       }
10124       if (match > 1 && opts & 1) {
10125         /* This ... wildcard could cover more than one set of dirs (i.e.
10126          * a set of similar dir names is repeated).  If the template
10127          * contains more than 1 ..., upstream elements could resolve the
10128          * ambiguity, but it's not worth a full backtracking setup here.
10129          * As a quick heuristic, clip off the current default directory
10130          * if it's present to find the trimmed spec, else use the
10131          * shortest string that this ... could cover.
10132          */
10133         char def[NAM$C_MAXRSS+1], *st;
10134
10135         if (getcwd(def, sizeof def,0) == NULL) {
10136             PerlMem_free(unixified);
10137             PerlMem_free(unixwild);
10138             PerlMem_free(lcres);
10139             PerlMem_free(tpl);
10140             return 0;
10141         }
10142         if (!decc_efs_case_preserve) {
10143           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10144             if (_tolower(*cp1) != _tolower(*cp2)) break;
10145         }
10146         segdirs = dirs - totells;  /* Min # of dirs we must have left */
10147         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10148         if (*cp1 == '\0' && *cp2 == '/') {
10149           memmove(fspec,cp2+1,end - cp2);
10150           PerlMem_free(tpl);
10151           PerlMem_free(unixified);
10152           PerlMem_free(unixwild);
10153           PerlMem_free(lcres);
10154           return 1;
10155         }
10156         /* Nope -- stick with lcfront from above and keep going. */
10157       }
10158     }
10159     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10160     PerlMem_free(tpl);
10161     PerlMem_free(unixified);
10162     PerlMem_free(unixwild);
10163     PerlMem_free(lcres);
10164     return 1;
10165     ellipsis = nextell;
10166   }
10167
10168 }  /* end of trim_unixpath() */
10169 /*}}}*/
10170
10171
10172 /*
10173  *  VMS readdir() routines.
10174  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10175  *
10176  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
10177  *  Minor modifications to original routines.
10178  */
10179
10180 /* readdir may have been redefined by reentr.h, so make sure we get
10181  * the local version for what we do here.
10182  */
10183 #ifdef readdir
10184 # undef readdir
10185 #endif
10186 #if !defined(PERL_IMPLICIT_CONTEXT)
10187 # define readdir Perl_readdir
10188 #else
10189 # define readdir(a) Perl_readdir(aTHX_ a)
10190 #endif
10191
10192     /* Number of elements in vms_versions array */
10193 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
10194
10195 /*
10196  *  Open a directory, return a handle for later use.
10197  */
10198 /*{{{ DIR *opendir(char*name) */
10199 DIR *
10200 Perl_opendir(pTHX_ const char *name)
10201 {
10202     DIR *dd;
10203     char *dir;
10204     Stat_t sb;
10205
10206     Newx(dir, VMS_MAXRSS, char);
10207     if (int_tovmspath(name, dir, NULL) == NULL) {
10208       Safefree(dir);
10209       return NULL;
10210     }
10211     /* Check access before stat; otherwise stat does not
10212      * accurately report whether it's a directory.
10213      */
10214     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10215       /* cando_by_name has already set errno */
10216       Safefree(dir);
10217       return NULL;
10218     }
10219     if (flex_stat(dir,&sb) == -1) return NULL;
10220     if (!S_ISDIR(sb.st_mode)) {
10221       Safefree(dir);
10222       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
10223       return NULL;
10224     }
10225     /* Get memory for the handle, and the pattern. */
10226     Newx(dd,1,DIR);
10227     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10228
10229     /* Fill in the fields; mainly playing with the descriptor. */
10230     sprintf(dd->pattern, "%s*.*",dir);
10231     Safefree(dir);
10232     dd->context = 0;
10233     dd->count = 0;
10234     dd->flags = 0;
10235     /* By saying we always want the result of readdir() in unix format, we
10236      * are really saying we want all the escapes removed.  Otherwise the caller,
10237      * having no way to know whether it's already in VMS format, might send it
10238      * through tovmsspec again, thus double escaping.
10239      */
10240     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
10241     dd->pat.dsc$a_pointer = dd->pattern;
10242     dd->pat.dsc$w_length = strlen(dd->pattern);
10243     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10244     dd->pat.dsc$b_class = DSC$K_CLASS_S;
10245 #if defined(USE_ITHREADS)
10246     Newx(dd->mutex,1,perl_mutex);
10247     MUTEX_INIT( (perl_mutex *) dd->mutex );
10248 #else
10249     dd->mutex = NULL;
10250 #endif
10251
10252     return dd;
10253 }  /* end of opendir() */
10254 /*}}}*/
10255
10256 /*
10257  *  Set the flag to indicate we want versions or not.
10258  */
10259 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10260 void
10261 vmsreaddirversions(DIR *dd, int flag)
10262 {
10263     if (flag)
10264         dd->flags |= PERL_VMSDIR_M_VERSIONS;
10265     else
10266         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10267 }
10268 /*}}}*/
10269
10270 /*
10271  *  Free up an opened directory.
10272  */
10273 /*{{{ void closedir(DIR *dd)*/
10274 void
10275 Perl_closedir(DIR *dd)
10276 {
10277     int sts;
10278
10279     sts = lib$find_file_end(&dd->context);
10280     Safefree(dd->pattern);
10281 #if defined(USE_ITHREADS)
10282     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10283     Safefree(dd->mutex);
10284 #endif
10285     Safefree(dd);
10286 }
10287 /*}}}*/
10288
10289 /*
10290  *  Collect all the version numbers for the current file.
10291  */
10292 static void
10293 collectversions(pTHX_ DIR *dd)
10294 {
10295     struct dsc$descriptor_s     pat;
10296     struct dsc$descriptor_s     res;
10297     struct dirent *e;
10298     char *p, *text, *buff;
10299     int i;
10300     unsigned long context, tmpsts;
10301
10302     /* Convenient shorthand. */
10303     e = &dd->entry;
10304
10305     /* Add the version wildcard, ignoring the "*.*" put on before */
10306     i = strlen(dd->pattern);
10307     Newx(text,i + e->d_namlen + 3,char);
10308     strcpy(text, dd->pattern);
10309     sprintf(&text[i - 3], "%s;*", e->d_name);
10310
10311     /* Set up the pattern descriptor. */
10312     pat.dsc$a_pointer = text;
10313     pat.dsc$w_length = i + e->d_namlen - 1;
10314     pat.dsc$b_dtype = DSC$K_DTYPE_T;
10315     pat.dsc$b_class = DSC$K_CLASS_S;
10316
10317     /* Set up result descriptor. */
10318     Newx(buff, VMS_MAXRSS, char);
10319     res.dsc$a_pointer = buff;
10320     res.dsc$w_length = VMS_MAXRSS - 1;
10321     res.dsc$b_dtype = DSC$K_DTYPE_T;
10322     res.dsc$b_class = DSC$K_CLASS_S;
10323
10324     /* Read files, collecting versions. */
10325     for (context = 0, e->vms_verscount = 0;
10326          e->vms_verscount < VERSIZE(e);
10327          e->vms_verscount++) {
10328         unsigned long rsts;
10329         unsigned long flags = 0;
10330
10331 #ifdef VMS_LONGNAME_SUPPORT
10332         flags = LIB$M_FIL_LONG_NAMES;
10333 #endif
10334         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10335         if (tmpsts == RMS$_NMF || context == 0) break;
10336         _ckvmssts(tmpsts);
10337         buff[VMS_MAXRSS - 1] = '\0';
10338         if ((p = strchr(buff, ';')))
10339             e->vms_versions[e->vms_verscount] = atoi(p + 1);
10340         else
10341             e->vms_versions[e->vms_verscount] = -1;
10342     }
10343
10344     _ckvmssts(lib$find_file_end(&context));
10345     Safefree(text);
10346     Safefree(buff);
10347
10348 }  /* end of collectversions() */
10349
10350 /*
10351  *  Read the next entry from the directory.
10352  */
10353 /*{{{ struct dirent *readdir(DIR *dd)*/
10354 struct dirent *
10355 Perl_readdir(pTHX_ DIR *dd)
10356 {
10357     struct dsc$descriptor_s     res;
10358     char *p, *buff;
10359     unsigned long int tmpsts;
10360     unsigned long rsts;
10361     unsigned long flags = 0;
10362     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10363     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10364
10365     /* Set up result descriptor, and get next file. */
10366     Newx(buff, VMS_MAXRSS, char);
10367     res.dsc$a_pointer = buff;
10368     res.dsc$w_length = VMS_MAXRSS - 1;
10369     res.dsc$b_dtype = DSC$K_DTYPE_T;
10370     res.dsc$b_class = DSC$K_CLASS_S;
10371
10372 #ifdef VMS_LONGNAME_SUPPORT
10373     flags = LIB$M_FIL_LONG_NAMES;
10374 #endif
10375
10376     tmpsts = lib$find_file
10377         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10378     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
10379     if (!(tmpsts & 1)) {
10380       set_vaxc_errno(tmpsts);
10381       switch (tmpsts) {
10382         case RMS$_PRV:
10383           set_errno(EACCES); break;
10384         case RMS$_DEV:
10385           set_errno(ENODEV); break;
10386         case RMS$_DIR:
10387           set_errno(ENOTDIR); break;
10388         case RMS$_FNF: case RMS$_DNF:
10389           set_errno(ENOENT); break;
10390         default:
10391           set_errno(EVMSERR);
10392       }
10393       Safefree(buff);
10394       return NULL;
10395     }
10396     dd->count++;
10397     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10398     buff[res.dsc$w_length] = '\0';
10399     p = buff + res.dsc$w_length;
10400     while (--p >= buff) if (!isspace(*p)) break;
10401     *p = '\0';
10402     if (!decc_efs_case_preserve) {
10403       for (p = buff; *p; p++) *p = _tolower(*p);
10404     }
10405
10406     /* Skip any directory component and just copy the name. */
10407     sts = vms_split_path
10408        (buff,
10409         &v_spec,
10410         &v_len,
10411         &r_spec,
10412         &r_len,
10413         &d_spec,
10414         &d_len,
10415         &n_spec,
10416         &n_len,
10417         &e_spec,
10418         &e_len,
10419         &vs_spec,
10420         &vs_len);
10421
10422     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10423
10424         /* In Unix report mode, remove the ".dir;1" from the name */
10425         /* if it is a real directory. */
10426         if (decc_filename_unix_report || decc_efs_charset) {
10427             if ((e_len == 4) && (vs_len == 2) && (vs_spec[1] == '1')) {
10428                 if ((toupper(e_spec[1]) == 'D') &&
10429                     (toupper(e_spec[2]) == 'I') &&
10430                     (toupper(e_spec[3]) == 'R')) {
10431                     Stat_t statbuf;
10432                     int ret_sts;
10433
10434                     ret_sts = stat(buff, &statbuf.crtl_stat);
10435                     if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10436                         e_len = 0;
10437                         e_spec[0] = 0;
10438                     }
10439                 }
10440             }
10441         }
10442
10443         /* Drop NULL extensions on UNIX file specification */
10444         if ((e_len == 1) && decc_readdir_dropdotnotype) {
10445             e_len = 0;
10446             e_spec[0] = '\0';
10447         }
10448     }
10449
10450     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
10451     dd->entry.d_name[n_len + e_len] = '\0';
10452     dd->entry.d_namlen = strlen(dd->entry.d_name);
10453
10454     /* Convert the filename to UNIX format if needed */
10455     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10456
10457         /* Translate the encoded characters. */
10458         /* Fixme: Unicode handling could result in embedded 0 characters */
10459         if (strchr(dd->entry.d_name, '^') != NULL) {
10460             char new_name[256];
10461             char * q;
10462             p = dd->entry.d_name;
10463             q = new_name;
10464             while (*p != 0) {
10465                 int inchars_read, outchars_added;
10466                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10467                 p += inchars_read;
10468                 q += outchars_added;
10469                 /* fix-me */
10470                 /* if outchars_added > 1, then this is a wide file specification */
10471                 /* Wide file specifications need to be passed in Perl */
10472                 /* counted strings apparently with a Unicode flag */
10473             }
10474             *q = 0;
10475             strcpy(dd->entry.d_name, new_name);
10476             dd->entry.d_namlen = strlen(dd->entry.d_name);
10477         }
10478     }
10479
10480     dd->entry.vms_verscount = 0;
10481     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10482     Safefree(buff);
10483     return &dd->entry;
10484
10485 }  /* end of readdir() */
10486 /*}}}*/
10487
10488 /*
10489  *  Read the next entry from the directory -- thread-safe version.
10490  */
10491 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10492 int
10493 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10494 {
10495     int retval;
10496
10497     MUTEX_LOCK( (perl_mutex *) dd->mutex );
10498
10499     entry = readdir(dd);
10500     *result = entry;
10501     retval = ( *result == NULL ? errno : 0 );
10502
10503     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10504
10505     return retval;
10506
10507 }  /* end of readdir_r() */
10508 /*}}}*/
10509
10510 /*
10511  *  Return something that can be used in a seekdir later.
10512  */
10513 /*{{{ long telldir(DIR *dd)*/
10514 long
10515 Perl_telldir(DIR *dd)
10516 {
10517     return dd->count;
10518 }
10519 /*}}}*/
10520
10521 /*
10522  *  Return to a spot where we used to be.  Brute force.
10523  */
10524 /*{{{ void seekdir(DIR *dd,long count)*/
10525 void
10526 Perl_seekdir(pTHX_ DIR *dd, long count)
10527 {
10528     int old_flags;
10529
10530     /* If we haven't done anything yet... */
10531     if (dd->count == 0)
10532         return;
10533
10534     /* Remember some state, and clear it. */
10535     old_flags = dd->flags;
10536     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10537     _ckvmssts(lib$find_file_end(&dd->context));
10538     dd->context = 0;
10539
10540     /* The increment is in readdir(). */
10541     for (dd->count = 0; dd->count < count; )
10542         readdir(dd);
10543
10544     dd->flags = old_flags;
10545
10546 }  /* end of seekdir() */
10547 /*}}}*/
10548
10549 /* VMS subprocess management
10550  *
10551  * my_vfork() - just a vfork(), after setting a flag to record that
10552  * the current script is trying a Unix-style fork/exec.
10553  *
10554  * vms_do_aexec() and vms_do_exec() are called in response to the
10555  * perl 'exec' function.  If this follows a vfork call, then they
10556  * call out the regular perl routines in doio.c which do an
10557  * execvp (for those who really want to try this under VMS).
10558  * Otherwise, they do exactly what the perl docs say exec should
10559  * do - terminate the current script and invoke a new command
10560  * (See below for notes on command syntax.)
10561  *
10562  * do_aspawn() and do_spawn() implement the VMS side of the perl
10563  * 'system' function.
10564  *
10565  * Note on command arguments to perl 'exec' and 'system': When handled
10566  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10567  * are concatenated to form a DCL command string.  If the first non-numeric
10568  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10569  * the command string is handed off to DCL directly.  Otherwise,
10570  * the first token of the command is taken as the filespec of an image
10571  * to run.  The filespec is expanded using a default type of '.EXE' and
10572  * the process defaults for device, directory, etc., and if found, the resultant
10573  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10574  * the command string as parameters.  This is perhaps a bit complicated,
10575  * but I hope it will form a happy medium between what VMS folks expect
10576  * from lib$spawn and what Unix folks expect from exec.
10577  */
10578
10579 static int vfork_called;
10580
10581 /*{{{int my_vfork()*/
10582 int
10583 my_vfork()
10584 {
10585   vfork_called++;
10586   return vfork();
10587 }
10588 /*}}}*/
10589
10590
10591 static void
10592 vms_execfree(struct dsc$descriptor_s *vmscmd)
10593 {
10594   if (vmscmd) {
10595       if (vmscmd->dsc$a_pointer) {
10596           PerlMem_free(vmscmd->dsc$a_pointer);
10597       }
10598       PerlMem_free(vmscmd);
10599   }
10600 }
10601
10602 static char *
10603 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10604 {
10605   char *junk, *tmps = NULL;
10606   register size_t cmdlen = 0;
10607   size_t rlen;
10608   register SV **idx;
10609   STRLEN n_a;
10610
10611   idx = mark;
10612   if (really) {
10613     tmps = SvPV(really,rlen);
10614     if (*tmps) {
10615       cmdlen += rlen + 1;
10616       idx++;
10617     }
10618   }
10619
10620   for (idx++; idx <= sp; idx++) {
10621     if (*idx) {
10622       junk = SvPVx(*idx,rlen);
10623       cmdlen += rlen ? rlen + 1 : 0;
10624     }
10625   }
10626   Newx(PL_Cmd, cmdlen+1, char);
10627
10628   if (tmps && *tmps) {
10629     strcpy(PL_Cmd,tmps);
10630     mark++;
10631   }
10632   else *PL_Cmd = '\0';
10633   while (++mark <= sp) {
10634     if (*mark) {
10635       char *s = SvPVx(*mark,n_a);
10636       if (!*s) continue;
10637       if (*PL_Cmd) strcat(PL_Cmd," ");
10638       strcat(PL_Cmd,s);
10639     }
10640   }
10641   return PL_Cmd;
10642
10643 }  /* end of setup_argstr() */
10644
10645
10646 static unsigned long int
10647 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10648                    struct dsc$descriptor_s **pvmscmd)
10649 {
10650   char * vmsspec;
10651   char * resspec;
10652   char image_name[NAM$C_MAXRSS+1];
10653   char image_argv[NAM$C_MAXRSS+1];
10654   $DESCRIPTOR(defdsc,".EXE");
10655   $DESCRIPTOR(defdsc2,".");
10656   struct dsc$descriptor_s resdsc;
10657   struct dsc$descriptor_s *vmscmd;
10658   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10659   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10660   register char *s, *rest, *cp, *wordbreak;
10661   char * cmd;
10662   int cmdlen;
10663   register int isdcl;
10664
10665   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10666   if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10667
10668   /* vmsspec is a DCL command buffer, not just a filename */
10669   vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10670   if (vmsspec == NULL)
10671       _ckvmssts_noperl(SS$_INSFMEM);
10672
10673   resspec = PerlMem_malloc(VMS_MAXRSS);
10674   if (resspec == NULL)
10675       _ckvmssts_noperl(SS$_INSFMEM);
10676
10677   /* Make a copy for modification */
10678   cmdlen = strlen(incmd);
10679   cmd = PerlMem_malloc(cmdlen+1);
10680   if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10681   strncpy(cmd, incmd, cmdlen);
10682   cmd[cmdlen] = 0;
10683   image_name[0] = 0;
10684   image_argv[0] = 0;
10685
10686   resdsc.dsc$a_pointer = resspec;
10687   resdsc.dsc$b_dtype  = DSC$K_DTYPE_T;
10688   resdsc.dsc$b_class  = DSC$K_CLASS_S;
10689   resdsc.dsc$w_length = VMS_MAXRSS - 1;
10690
10691   vmscmd->dsc$a_pointer = NULL;
10692   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
10693   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
10694   vmscmd->dsc$w_length = 0;
10695   if (pvmscmd) *pvmscmd = vmscmd;
10696
10697   if (suggest_quote) *suggest_quote = 0;
10698
10699   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10700     PerlMem_free(cmd);
10701     PerlMem_free(vmsspec);
10702     PerlMem_free(resspec);
10703     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
10704   }
10705
10706   s = cmd;
10707
10708   while (*s && isspace(*s)) s++;
10709
10710   if (*s == '@' || *s == '$') {
10711     vmsspec[0] = *s;  rest = s + 1;
10712     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10713   }
10714   else { cp = vmsspec; rest = s; }
10715   if (*rest == '.' || *rest == '/') {
10716     char *cp2;
10717     for (cp2 = resspec;
10718          *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10719          rest++, cp2++) *cp2 = *rest;
10720     *cp2 = '\0';
10721     if (int_tovmsspec(resspec, cp, 0, NULL)) {
10722       s = vmsspec;
10723
10724       /* When a UNIX spec with no file type is translated to VMS, */
10725       /* A trailing '.' is appended under ODS-5 rules.            */
10726       /* Here we do not want that trailing "." as it prevents     */
10727       /* Looking for a implied ".exe" type. */
10728       if (decc_efs_charset) {
10729           int i;
10730           i = strlen(vmsspec);
10731           if (vmsspec[i-1] == '.') {
10732               vmsspec[i-1] = '\0';
10733           }
10734       }
10735
10736       if (*rest) {
10737         for (cp2 = vmsspec + strlen(vmsspec);
10738              *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10739              rest++, cp2++) *cp2 = *rest;
10740         *cp2 = '\0';
10741       }
10742     }
10743   }
10744   /* Intuit whether verb (first word of cmd) is a DCL command:
10745    *   - if first nonspace char is '@', it's a DCL indirection
10746    * otherwise
10747    *   - if verb contains a filespec separator, it's not a DCL command
10748    *   - if it doesn't, caller tells us whether to default to a DCL
10749    *     command, or to a local image unless told it's DCL (by leading '$')
10750    */
10751   if (*s == '@') {
10752       isdcl = 1;
10753       if (suggest_quote) *suggest_quote = 1;
10754   } else {
10755     register char *filespec = strpbrk(s,":<[.;");
10756     rest = wordbreak = strpbrk(s," \"\t/");
10757     if (!wordbreak) wordbreak = s + strlen(s);
10758     if (*s == '$') check_img = 0;
10759     if (filespec && (filespec < wordbreak)) isdcl = 0;
10760     else isdcl = !check_img;
10761   }
10762
10763   if (!isdcl) {
10764     int rsts;
10765     imgdsc.dsc$a_pointer = s;
10766     imgdsc.dsc$w_length = wordbreak - s;
10767     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10768     if (!(retsts&1)) {
10769         _ckvmssts_noperl(lib$find_file_end(&cxt));
10770         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10771       if (!(retsts & 1) && *s == '$') {
10772         _ckvmssts_noperl(lib$find_file_end(&cxt));
10773         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10774         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10775         if (!(retsts&1)) {
10776           _ckvmssts_noperl(lib$find_file_end(&cxt));
10777           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10778         }
10779       }
10780     }
10781     _ckvmssts_noperl(lib$find_file_end(&cxt));
10782
10783     if (retsts & 1) {
10784       FILE *fp;
10785       s = resspec;
10786       while (*s && !isspace(*s)) s++;
10787       *s = '\0';
10788
10789       /* check that it's really not DCL with no file extension */
10790       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10791       if (fp) {
10792         char b[256] = {0,0,0,0};
10793         read(fileno(fp), b, 256);
10794         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10795         if (isdcl) {
10796           int shebang_len;
10797
10798           /* Check for script */
10799           shebang_len = 0;
10800           if ((b[0] == '#') && (b[1] == '!'))
10801              shebang_len = 2;
10802 #ifdef ALTERNATE_SHEBANG
10803           else {
10804             shebang_len = strlen(ALTERNATE_SHEBANG);
10805             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10806               char * perlstr;
10807                 perlstr = strstr("perl",b);
10808                 if (perlstr == NULL)
10809                   shebang_len = 0;
10810             }
10811             else
10812               shebang_len = 0;
10813           }
10814 #endif
10815
10816           if (shebang_len > 0) {
10817           int i;
10818           int j;
10819           char tmpspec[NAM$C_MAXRSS + 1];
10820
10821             i = shebang_len;
10822              /* Image is following after white space */
10823             /*--------------------------------------*/
10824             while (isprint(b[i]) && isspace(b[i]))
10825                 i++;
10826
10827             j = 0;
10828             while (isprint(b[i]) && !isspace(b[i])) {
10829                 tmpspec[j++] = b[i++];
10830                 if (j >= NAM$C_MAXRSS)
10831                    break;
10832             }
10833             tmpspec[j] = '\0';
10834
10835              /* There may be some default parameters to the image */
10836             /*---------------------------------------------------*/
10837             j = 0;
10838             while (isprint(b[i])) {
10839                 image_argv[j++] = b[i++];
10840                 if (j >= NAM$C_MAXRSS)
10841                    break;
10842             }
10843             while ((j > 0) && !isprint(image_argv[j-1]))
10844                 j--;
10845             image_argv[j] = 0;
10846
10847             /* It will need to be converted to VMS format and validated */
10848             if (tmpspec[0] != '\0') {
10849               char * iname;
10850
10851                /* Try to find the exact program requested to be run */
10852               /*---------------------------------------------------*/
10853               iname = int_rmsexpand
10854                  (tmpspec, image_name, ".exe",
10855                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10856               if (iname != NULL) {
10857                 if (cando_by_name_int
10858                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10859                   /* MCR prefix needed */
10860                   isdcl = 0;
10861                 }
10862                 else {
10863                    /* Try again with a null type */
10864                   /*----------------------------*/
10865                   iname = int_rmsexpand
10866                     (tmpspec, image_name, ".",
10867                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10868                   if (iname != NULL) {
10869                     if (cando_by_name_int
10870                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10871                       /* MCR prefix needed */
10872                       isdcl = 0;
10873                     }
10874                   }
10875                 }
10876
10877                  /* Did we find the image to run the script? */
10878                 /*------------------------------------------*/
10879                 if (isdcl) {
10880                   char *tchr;
10881
10882                    /* Assume DCL or foreign command exists */
10883                   /*--------------------------------------*/
10884                   tchr = strrchr(tmpspec, '/');
10885                   if (tchr != NULL) {
10886                     tchr++;
10887                   }
10888                   else {
10889                     tchr = tmpspec;
10890                   }
10891                   strcpy(image_name, tchr);
10892                 }
10893               }
10894             }
10895           }
10896         }
10897         fclose(fp);
10898       }
10899       if (check_img && isdcl) {
10900           PerlMem_free(cmd);
10901           PerlMem_free(resspec);
10902           PerlMem_free(vmsspec);
10903           return RMS$_FNF;
10904       }
10905
10906       if (cando_by_name(S_IXUSR,0,resspec)) {
10907         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10908         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10909         if (!isdcl) {
10910             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10911             if (image_name[0] != 0) {
10912                 strcat(vmscmd->dsc$a_pointer, image_name);
10913                 strcat(vmscmd->dsc$a_pointer, " ");
10914             }
10915         } else if (image_name[0] != 0) {
10916             strcpy(vmscmd->dsc$a_pointer, image_name);
10917             strcat(vmscmd->dsc$a_pointer, " ");
10918         } else {
10919             strcpy(vmscmd->dsc$a_pointer,"@");
10920         }
10921         if (suggest_quote) *suggest_quote = 1;
10922
10923         /* If there is an image name, use original command */
10924         if (image_name[0] == 0)
10925             strcat(vmscmd->dsc$a_pointer,resspec);
10926         else {
10927             rest = cmd;
10928             while (*rest && isspace(*rest)) rest++;
10929         }
10930
10931         if (image_argv[0] != 0) {
10932           strcat(vmscmd->dsc$a_pointer,image_argv);
10933           strcat(vmscmd->dsc$a_pointer, " ");
10934         }
10935         if (rest) {
10936            int rest_len;
10937            int vmscmd_len;
10938
10939            rest_len = strlen(rest);
10940            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10941            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10942               strcat(vmscmd->dsc$a_pointer,rest);
10943            else
10944              retsts = CLI$_BUFOVF;
10945         }
10946         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10947         PerlMem_free(cmd);
10948         PerlMem_free(vmsspec);
10949         PerlMem_free(resspec);
10950         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10951       }
10952       else
10953         retsts = RMS$_PRV;
10954     }
10955   }
10956   /* It's either a DCL command or we couldn't find a suitable image */
10957   vmscmd->dsc$w_length = strlen(cmd);
10958
10959   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10960   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10961   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10962
10963   PerlMem_free(cmd);
10964   PerlMem_free(resspec);
10965   PerlMem_free(vmsspec);
10966
10967   /* check if it's a symbol (for quoting purposes) */
10968   if (suggest_quote && !*suggest_quote) {
10969     int iss;
10970     char equiv[LNM$C_NAMLENGTH];
10971     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10972     eqvdsc.dsc$a_pointer = equiv;
10973
10974     iss = lib$get_symbol(vmscmd,&eqvdsc);
10975     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10976   }
10977   if (!(retsts & 1)) {
10978     /* just hand off status values likely to be due to user error */
10979     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10980         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10981        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10982     else { _ckvmssts_noperl(retsts); }
10983   }
10984
10985   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10986
10987 }  /* end of setup_cmddsc() */
10988
10989
10990 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10991 bool
10992 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10993 {
10994 bool exec_sts;
10995 char * cmd;
10996
10997   if (sp > mark) {
10998     if (vfork_called) {           /* this follows a vfork - act Unixish */
10999       vfork_called--;
11000       if (vfork_called < 0) {
11001         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11002         vfork_called = 0;
11003       }
11004       else return do_aexec(really,mark,sp);
11005     }
11006                                            /* no vfork - act VMSish */
11007     cmd = setup_argstr(aTHX_ really,mark,sp);
11008     exec_sts = vms_do_exec(cmd);
11009     Safefree(cmd);  /* Clean up from setup_argstr() */
11010     return exec_sts;
11011   }
11012
11013   return FALSE;
11014 }  /* end of vms_do_aexec() */
11015 /*}}}*/
11016
11017 /* {{{bool vms_do_exec(char *cmd) */
11018 bool
11019 Perl_vms_do_exec(pTHX_ const char *cmd)
11020 {
11021   struct dsc$descriptor_s *vmscmd;
11022
11023   if (vfork_called) {             /* this follows a vfork - act Unixish */
11024     vfork_called--;
11025     if (vfork_called < 0) {
11026       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11027       vfork_called = 0;
11028     }
11029     else return do_exec(cmd);
11030   }
11031
11032   {                               /* no vfork - act VMSish */
11033     unsigned long int retsts;
11034
11035     TAINT_ENV();
11036     TAINT_PROPER("exec");
11037     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
11038       retsts = lib$do_command(vmscmd);
11039
11040     switch (retsts) {
11041       case RMS$_FNF: case RMS$_DNF:
11042         set_errno(ENOENT); break;
11043       case RMS$_DIR:
11044         set_errno(ENOTDIR); break;
11045       case RMS$_DEV:
11046         set_errno(ENODEV); break;
11047       case RMS$_PRV:
11048         set_errno(EACCES); break;
11049       case RMS$_SYN:
11050         set_errno(EINVAL); break;
11051       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11052         set_errno(E2BIG); break;
11053       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11054         _ckvmssts_noperl(retsts); /* fall through */
11055       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11056         set_errno(EVMSERR);
11057     }
11058     set_vaxc_errno(retsts);
11059     if (ckWARN(WARN_EXEC)) {
11060       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
11061              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
11062     }
11063     vms_execfree(vmscmd);
11064   }
11065
11066   return FALSE;
11067
11068 }  /* end of vms_do_exec() */
11069 /*}}}*/
11070
11071 int do_spawn2(pTHX_ const char *, int);
11072
11073 int
11074 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
11075 {
11076 unsigned long int sts;
11077 char * cmd;
11078 int flags = 0;
11079
11080   if (sp > mark) {
11081
11082     /* We'll copy the (undocumented?) Win32 behavior and allow a
11083      * numeric first argument.  But the only value we'll support
11084      * through do_aspawn is a value of 1, which means spawn without
11085      * waiting for completion -- other values are ignored.
11086      */
11087     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
11088         ++mark;
11089         flags = SvIVx(*mark);
11090     }
11091
11092     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
11093         flags = CLI$M_NOWAIT;
11094     else
11095         flags = 0;
11096
11097     cmd = setup_argstr(aTHX_ really, mark, sp);
11098     sts = do_spawn2(aTHX_ cmd, flags);
11099     /* pp_sys will clean up cmd */
11100     return sts;
11101   }
11102   return SS$_ABORT;
11103 }  /* end of do_aspawn() */
11104 /*}}}*/
11105
11106
11107 /* {{{int do_spawn(char* cmd) */
11108 int
11109 Perl_do_spawn(pTHX_ char* cmd)
11110 {
11111     PERL_ARGS_ASSERT_DO_SPAWN;
11112
11113     return do_spawn2(aTHX_ cmd, 0);
11114 }
11115 /*}}}*/
11116
11117 /* {{{int do_spawn_nowait(char* cmd) */
11118 int
11119 Perl_do_spawn_nowait(pTHX_ char* cmd)
11120 {
11121     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11122
11123     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11124 }
11125 /*}}}*/
11126
11127 /* {{{int do_spawn2(char *cmd) */
11128 int
11129 do_spawn2(pTHX_ const char *cmd, int flags)
11130 {
11131   unsigned long int sts, substs;
11132
11133   /* The caller of this routine expects to Safefree(PL_Cmd) */
11134   Newx(PL_Cmd,10,char);
11135
11136   TAINT_ENV();
11137   TAINT_PROPER("spawn");
11138   if (!cmd || !*cmd) {
11139     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11140     if (!(sts & 1)) {
11141       switch (sts) {
11142         case RMS$_FNF:  case RMS$_DNF:
11143           set_errno(ENOENT); break;
11144         case RMS$_DIR:
11145           set_errno(ENOTDIR); break;
11146         case RMS$_DEV:
11147           set_errno(ENODEV); break;
11148         case RMS$_PRV:
11149           set_errno(EACCES); break;
11150         case RMS$_SYN:
11151           set_errno(EINVAL); break;
11152         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11153           set_errno(E2BIG); break;
11154         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11155           _ckvmssts_noperl(sts); /* fall through */
11156         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11157           set_errno(EVMSERR);
11158       }
11159       set_vaxc_errno(sts);
11160       if (ckWARN(WARN_EXEC)) {
11161         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11162                     Strerror(errno));
11163       }
11164     }
11165     sts = substs;
11166   }
11167   else {
11168     char mode[3];
11169     PerlIO * fp;
11170     if (flags & CLI$M_NOWAIT)
11171         strcpy(mode, "n");
11172     else
11173         strcpy(mode, "nW");
11174
11175     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11176     if (fp != NULL)
11177       my_pclose(fp);
11178     /* sts will be the pid in the nowait case */
11179   }
11180   return sts;
11181 }  /* end of do_spawn2() */
11182 /*}}}*/
11183
11184
11185 static unsigned int *sockflags, sockflagsize;
11186
11187 /*
11188  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11189  * routines found in some versions of the CRTL can't deal with sockets.
11190  * We don't shim the other file open routines since a socket isn't
11191  * likely to be opened by a name.
11192  */
11193 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11194 FILE *my_fdopen(int fd, const char *mode)
11195 {
11196   FILE *fp = fdopen(fd, mode);
11197
11198   if (fp) {
11199     unsigned int fdoff = fd / sizeof(unsigned int);
11200     Stat_t sbuf; /* native stat; we don't need flex_stat */
11201     if (!sockflagsize || fdoff > sockflagsize) {
11202       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
11203       else           Newx  (sockflags,fdoff+2,unsigned int);
11204       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11205       sockflagsize = fdoff + 2;
11206     }
11207     if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11208       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11209   }
11210   return fp;
11211
11212 }
11213 /*}}}*/
11214
11215
11216 /*
11217  * Clear the corresponding bit when the (possibly) socket stream is closed.
11218  * There still a small hole: we miss an implicit close which might occur
11219  * via freopen().  >> Todo
11220  */
11221 /*{{{ int my_fclose(FILE *fp)*/
11222 int my_fclose(FILE *fp) {
11223   if (fp) {
11224     unsigned int fd = fileno(fp);
11225     unsigned int fdoff = fd / sizeof(unsigned int);
11226
11227     if (sockflagsize && fdoff < sockflagsize)
11228       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11229   }
11230   return fclose(fp);
11231 }
11232 /*}}}*/
11233
11234
11235 /*
11236  * A simple fwrite replacement which outputs itmsz*nitm chars without
11237  * introducing record boundaries every itmsz chars.
11238  * We are using fputs, which depends on a terminating null.  We may
11239  * well be writing binary data, so we need to accommodate not only
11240  * data with nulls sprinkled in the middle but also data with no null
11241  * byte at the end.
11242  */
11243 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11244 int
11245 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11246 {
11247   register char *cp, *end, *cpd, *data;
11248   register unsigned int fd = fileno(dest);
11249   register unsigned int fdoff = fd / sizeof(unsigned int);
11250   int retval;
11251   int bufsize = itmsz * nitm + 1;
11252
11253   if (fdoff < sockflagsize &&
11254       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11255     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11256     return nitm;
11257   }
11258
11259   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11260   memcpy( data, src, itmsz*nitm );
11261   data[itmsz*nitm] = '\0';
11262
11263   end = data + itmsz * nitm;
11264   retval = (int) nitm; /* on success return # items written */
11265
11266   cpd = data;
11267   while (cpd <= end) {
11268     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11269     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11270     if (cp < end)
11271       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11272     cpd = cp + 1;
11273   }
11274
11275   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11276   return retval;
11277
11278 }  /* end of my_fwrite() */
11279 /*}}}*/
11280
11281 /*{{{ int my_flush(FILE *fp)*/
11282 int
11283 Perl_my_flush(pTHX_ FILE *fp)
11284 {
11285     int res;
11286     if ((res = fflush(fp)) == 0 && fp) {
11287 #ifdef VMS_DO_SOCKETS
11288         Stat_t s;
11289         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11290 #endif
11291             res = fsync(fileno(fp));
11292     }
11293 /*
11294  * If the flush succeeded but set end-of-file, we need to clear
11295  * the error because our caller may check ferror().  BTW, this
11296  * probably means we just flushed an empty file.
11297  */
11298     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11299
11300     return res;
11301 }
11302 /*}}}*/
11303
11304 /*
11305  * Here are replacements for the following Unix routines in the VMS environment:
11306  *      getpwuid    Get information for a particular UIC or UID
11307  *      getpwnam    Get information for a named user
11308  *      getpwent    Get information for each user in the rights database
11309  *      setpwent    Reset search to the start of the rights database
11310  *      endpwent    Finish searching for users in the rights database
11311  *
11312  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11313  * (defined in pwd.h), which contains the following fields:-
11314  *      struct passwd {
11315  *              char        *pw_name;    Username (in lower case)
11316  *              char        *pw_passwd;  Hashed password
11317  *              unsigned int pw_uid;     UIC
11318  *              unsigned int pw_gid;     UIC group  number
11319  *              char        *pw_unixdir; Default device/directory (VMS-style)
11320  *              char        *pw_gecos;   Owner name
11321  *              char        *pw_dir;     Default device/directory (Unix-style)
11322  *              char        *pw_shell;   Default CLI name (eg. DCL)
11323  *      };
11324  * If the specified user does not exist, getpwuid and getpwnam return NULL.
11325  *
11326  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11327  * not the UIC member number (eg. what's returned by getuid()),
11328  * getpwuid() can accept either as input (if uid is specified, the caller's
11329  * UIC group is used), though it won't recognise gid=0.
11330  *
11331  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11332  * information about other users in your group or in other groups, respectively.
11333  * If the required privilege is not available, then these routines fill only
11334  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11335  * string).
11336  *
11337  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11338  */
11339
11340 /* sizes of various UAF record fields */
11341 #define UAI$S_USERNAME 12
11342 #define UAI$S_IDENT    31
11343 #define UAI$S_OWNER    31
11344 #define UAI$S_DEFDEV   31
11345 #define UAI$S_DEFDIR   63
11346 #define UAI$S_DEFCLI   31
11347 #define UAI$S_PWD       8
11348
11349 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
11350                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11351                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
11352
11353 static char __empty[]= "";
11354 static struct passwd __passwd_empty=
11355     {(char *) __empty, (char *) __empty, 0, 0,
11356      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11357 static int contxt= 0;
11358 static struct passwd __pwdcache;
11359 static char __pw_namecache[UAI$S_IDENT+1];
11360
11361 /*
11362  * This routine does most of the work extracting the user information.
11363  */
11364 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11365 {
11366     static struct {
11367         unsigned char length;
11368         char pw_gecos[UAI$S_OWNER+1];
11369     } owner;
11370     static union uicdef uic;
11371     static struct {
11372         unsigned char length;
11373         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11374     } defdev;
11375     static struct {
11376         unsigned char length;
11377         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11378     } defdir;
11379     static struct {
11380         unsigned char length;
11381         char pw_shell[UAI$S_DEFCLI+1];
11382     } defcli;
11383     static char pw_passwd[UAI$S_PWD+1];
11384
11385     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11386     struct dsc$descriptor_s name_desc;
11387     unsigned long int sts;
11388
11389     static struct itmlst_3 itmlst[]= {
11390         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
11391         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
11392         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
11393         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
11394         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
11395         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
11396         {0,                0,           NULL,    NULL}};
11397
11398     name_desc.dsc$w_length=  strlen(name);
11399     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11400     name_desc.dsc$b_class=   DSC$K_CLASS_S;
11401     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11402
11403 /*  Note that sys$getuai returns many fields as counted strings. */
11404     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11405     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11406       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11407     }
11408     else { _ckvmssts(sts); }
11409     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
11410
11411     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
11412     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11413     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11414     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11415     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11416     owner.pw_gecos[lowner]=            '\0';
11417     defdev.pw_dir[ldefdev+ldefdir]= '\0';
11418     defcli.pw_shell[ldefcli]=          '\0';
11419     if (valid_uic(uic)) {
11420         pwd->pw_uid= uic.uic$l_uic;
11421         pwd->pw_gid= uic.uic$v_group;
11422     }
11423     else
11424       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11425     pwd->pw_passwd=  pw_passwd;
11426     pwd->pw_gecos=   owner.pw_gecos;
11427     pwd->pw_dir=     defdev.pw_dir;
11428     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11429     pwd->pw_shell=   defcli.pw_shell;
11430     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11431         int ldir;
11432         ldir= strlen(pwd->pw_unixdir) - 1;
11433         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11434     }
11435     else
11436         strcpy(pwd->pw_unixdir, pwd->pw_dir);
11437     if (!decc_efs_case_preserve)
11438         __mystrtolower(pwd->pw_unixdir);
11439     return 1;
11440 }
11441
11442 /*
11443  * Get information for a named user.
11444 */
11445 /*{{{struct passwd *getpwnam(char *name)*/
11446 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11447 {
11448     struct dsc$descriptor_s name_desc;
11449     union uicdef uic;
11450     unsigned long int status, sts;
11451
11452     __pwdcache = __passwd_empty;
11453     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11454       /* We still may be able to determine pw_uid and pw_gid */
11455       name_desc.dsc$w_length=  strlen(name);
11456       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
11457       name_desc.dsc$b_class=   DSC$K_CLASS_S;
11458       name_desc.dsc$a_pointer= (char *) name;
11459       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11460         __pwdcache.pw_uid= uic.uic$l_uic;
11461         __pwdcache.pw_gid= uic.uic$v_group;
11462       }
11463       else {
11464         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11465           set_vaxc_errno(sts);
11466           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11467           return NULL;
11468         }
11469         else { _ckvmssts(sts); }
11470       }
11471     }
11472     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
11473     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
11474     __pwdcache.pw_name= __pw_namecache;
11475     return &__pwdcache;
11476 }  /* end of my_getpwnam() */
11477 /*}}}*/
11478
11479 /*
11480  * Get information for a particular UIC or UID.
11481  * Called by my_getpwent with uid=-1 to list all users.
11482 */
11483 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11484 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11485 {
11486     const $DESCRIPTOR(name_desc,__pw_namecache);
11487     unsigned short lname;
11488     union uicdef uic;
11489     unsigned long int status;
11490
11491     if (uid == (unsigned int) -1) {
11492       do {
11493         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11494         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11495           set_vaxc_errno(status);
11496           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11497           my_endpwent();
11498           return NULL;
11499         }
11500         else { _ckvmssts(status); }
11501       } while (!valid_uic (uic));
11502     }
11503     else {
11504       uic.uic$l_uic= uid;
11505       if (!uic.uic$v_group)
11506         uic.uic$v_group= PerlProc_getgid();
11507       if (valid_uic(uic))
11508         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11509       else status = SS$_IVIDENT;
11510       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11511           status == RMS$_PRV) {
11512         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11513         return NULL;
11514       }
11515       else { _ckvmssts(status); }
11516     }
11517     __pw_namecache[lname]= '\0';
11518     __mystrtolower(__pw_namecache);
11519
11520     __pwdcache = __passwd_empty;
11521     __pwdcache.pw_name = __pw_namecache;
11522
11523 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11524     The identifier's value is usually the UIC, but it doesn't have to be,
11525     so if we can, we let fillpasswd update this. */
11526     __pwdcache.pw_uid =  uic.uic$l_uic;
11527     __pwdcache.pw_gid =  uic.uic$v_group;
11528
11529     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11530     return &__pwdcache;
11531
11532 }  /* end of my_getpwuid() */
11533 /*}}}*/
11534
11535 /*
11536  * Get information for next user.
11537 */
11538 /*{{{struct passwd *my_getpwent()*/
11539 struct passwd *Perl_my_getpwent(pTHX)
11540 {
11541     return (my_getpwuid((unsigned int) -1));
11542 }
11543 /*}}}*/
11544
11545 /*
11546  * Finish searching rights database for users.
11547 */
11548 /*{{{void my_endpwent()*/
11549 void Perl_my_endpwent(pTHX)
11550 {
11551     if (contxt) {
11552       _ckvmssts(sys$finish_rdb(&contxt));
11553       contxt= 0;
11554     }
11555 }
11556 /*}}}*/
11557
11558 #ifdef HOMEGROWN_POSIX_SIGNALS
11559   /* Signal handling routines, pulled into the core from POSIX.xs.
11560    *
11561    * We need these for threads, so they've been rolled into the core,
11562    * rather than left in POSIX.xs.
11563    *
11564    * (DRS, Oct 23, 1997)
11565    */
11566
11567   /* sigset_t is atomic under VMS, so these routines are easy */
11568 /*{{{int my_sigemptyset(sigset_t *) */
11569 int my_sigemptyset(sigset_t *set) {
11570     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11571     *set = 0; return 0;
11572 }
11573 /*}}}*/
11574
11575
11576 /*{{{int my_sigfillset(sigset_t *)*/
11577 int my_sigfillset(sigset_t *set) {
11578     int i;
11579     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11580     for (i = 0; i < NSIG; i++) *set |= (1 << i);
11581     return 0;
11582 }
11583 /*}}}*/
11584
11585
11586 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
11587 int my_sigaddset(sigset_t *set, int sig) {
11588     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11589     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11590     *set |= (1 << (sig - 1));
11591     return 0;
11592 }
11593 /*}}}*/
11594
11595
11596 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
11597 int my_sigdelset(sigset_t *set, int sig) {
11598     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11599     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11600     *set &= ~(1 << (sig - 1));
11601     return 0;
11602 }
11603 /*}}}*/
11604
11605
11606 /*{{{int my_sigismember(sigset_t *set, int sig)*/
11607 int my_sigismember(sigset_t *set, int sig) {
11608     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11609     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11610     return *set & (1 << (sig - 1));
11611 }
11612 /*}}}*/
11613
11614
11615 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
11616 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
11617     sigset_t tempmask;
11618
11619     /* If set and oset are both null, then things are badly wrong. Bail out. */
11620     if ((oset == NULL) && (set == NULL)) {
11621       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
11622       return -1;
11623     }
11624
11625     /* If set's null, then we're just handling a fetch. */
11626     if (set == NULL) {
11627         tempmask = sigblock(0);
11628     }
11629     else {
11630       switch (how) {
11631       case SIG_SETMASK:
11632         tempmask = sigsetmask(*set);
11633         break;
11634       case SIG_BLOCK:
11635         tempmask = sigblock(*set);
11636         break;
11637       case SIG_UNBLOCK:
11638         tempmask = sigblock(0);
11639         sigsetmask(*oset & ~tempmask);
11640         break;
11641       default:
11642         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11643         return -1;
11644       }
11645     }
11646
11647     /* Did they pass us an oset? If so, stick our holding mask into it */
11648     if (oset)
11649       *oset = tempmask;
11650
11651     return 0;
11652 }
11653 /*}}}*/
11654 #endif  /* HOMEGROWN_POSIX_SIGNALS */
11655
11656
11657 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11658  * my_utime(), and flex_stat(), all of which operate on UTC unless
11659  * VMSISH_TIMES is true.
11660  */
11661 /* method used to handle UTC conversions:
11662  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
11663  */
11664 static int gmtime_emulation_type;
11665 /* number of secs to add to UTC POSIX-style time to get local time */
11666 static long int utc_offset_secs;
11667
11668 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11669  * in vmsish.h.  #undef them here so we can call the CRTL routines
11670  * directly.
11671  */
11672 #undef gmtime
11673 #undef localtime
11674 #undef time
11675
11676
11677 /*
11678  * DEC C previous to 6.0 corrupts the behavior of the /prefix
11679  * qualifier with the extern prefix pragma.  This provisional
11680  * hack circumvents this prefix pragma problem in previous
11681  * precompilers.
11682  */
11683 #if defined(__VMS_VER) && __VMS_VER >= 70000000
11684 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11685 #    pragma __extern_prefix save
11686 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
11687 #    define gmtime decc$__utctz_gmtime
11688 #    define localtime decc$__utctz_localtime
11689 #    define time decc$__utc_time
11690 #    pragma __extern_prefix restore
11691
11692      struct tm *gmtime(), *localtime();
11693
11694 #  endif
11695 #endif
11696
11697
11698 static time_t toutc_dst(time_t loc) {
11699   struct tm *rsltmp;
11700
11701   if ((rsltmp = localtime(&loc)) == NULL) return -1;
11702   loc -= utc_offset_secs;
11703   if (rsltmp->tm_isdst) loc -= 3600;
11704   return loc;
11705 }
11706 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11707        ((gmtime_emulation_type || my_time(NULL)), \
11708        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11709        ((secs) - utc_offset_secs))))
11710
11711 static time_t toloc_dst(time_t utc) {
11712   struct tm *rsltmp;
11713
11714   utc += utc_offset_secs;
11715   if ((rsltmp = localtime(&utc)) == NULL) return -1;
11716   if (rsltmp->tm_isdst) utc += 3600;
11717   return utc;
11718 }
11719 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
11720        ((gmtime_emulation_type || my_time(NULL)), \
11721        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11722        ((secs) + utc_offset_secs))))
11723
11724 #ifndef RTL_USES_UTC
11725 /*
11726
11727     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
11728         DST starts on 1st sun of april      at 02:00  std time
11729             ends on last sun of october     at 02:00  dst time
11730     see the UCX management command reference, SET CONFIG TIMEZONE
11731     for formatting info.
11732
11733     No, it's not as general as it should be, but then again, NOTHING
11734     will handle UK times in a sensible way.
11735 */
11736
11737
11738 /*
11739     parse the DST start/end info:
11740     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11741 */
11742
11743 static char *
11744 tz_parse_startend(char *s, struct tm *w, int *past)
11745 {
11746     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11747     int ly, dozjd, d, m, n, hour, min, sec, j, k;
11748     time_t g;
11749
11750     if (!s)    return 0;
11751     if (!w) return 0;
11752     if (!past) return 0;
11753
11754     ly = 0;
11755     if (w->tm_year % 4        == 0) ly = 1;
11756     if (w->tm_year % 100      == 0) ly = 0;
11757     if (w->tm_year+1900 % 400 == 0) ly = 1;
11758     if (ly) dinm[1]++;
11759
11760     dozjd = isdigit(*s);
11761     if (*s == 'J' || *s == 'j' || dozjd) {
11762         if (!dozjd && !isdigit(*++s)) return 0;
11763         d = *s++ - '0';
11764         if (isdigit(*s)) {
11765             d = d*10 + *s++ - '0';
11766             if (isdigit(*s)) {
11767                 d = d*10 + *s++ - '0';
11768             }
11769         }
11770         if (d == 0) return 0;
11771         if (d > 366) return 0;
11772         d--;
11773         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
11774         g = d * 86400;
11775         dozjd = 1;
11776     } else if (*s == 'M' || *s == 'm') {
11777         if (!isdigit(*++s)) return 0;
11778         m = *s++ - '0';
11779         if (isdigit(*s)) m = 10*m + *s++ - '0';
11780         if (*s != '.') return 0;
11781         if (!isdigit(*++s)) return 0;
11782         n = *s++ - '0';
11783         if (n < 1 || n > 5) return 0;
11784         if (*s != '.') return 0;
11785         if (!isdigit(*++s)) return 0;
11786         d = *s++ - '0';
11787         if (d > 6) return 0;
11788     }
11789
11790     if (*s == '/') {
11791         if (!isdigit(*++s)) return 0;
11792         hour = *s++ - '0';
11793         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11794         if (*s == ':') {
11795             if (!isdigit(*++s)) return 0;
11796             min = *s++ - '0';
11797             if (isdigit(*s)) min = 10*min + *s++ - '0';
11798             if (*s == ':') {
11799                 if (!isdigit(*++s)) return 0;
11800                 sec = *s++ - '0';
11801                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11802             }
11803         }
11804     } else {
11805         hour = 2;
11806         min = 0;
11807         sec = 0;
11808     }
11809
11810     if (dozjd) {
11811         if (w->tm_yday < d) goto before;
11812         if (w->tm_yday > d) goto after;
11813     } else {
11814         if (w->tm_mon+1 < m) goto before;
11815         if (w->tm_mon+1 > m) goto after;
11816
11817         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
11818         k = d - j; /* mday of first d */
11819         if (k <= 0) k += 7;
11820         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
11821         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11822         if (w->tm_mday < k) goto before;
11823         if (w->tm_mday > k) goto after;
11824     }
11825
11826     if (w->tm_hour < hour) goto before;
11827     if (w->tm_hour > hour) goto after;
11828     if (w->tm_min  < min)  goto before;
11829     if (w->tm_min  > min)  goto after;
11830     if (w->tm_sec  < sec)  goto before;
11831     goto after;
11832
11833 before:
11834     *past = 0;
11835     return s;
11836 after:
11837     *past = 1;
11838     return s;
11839 }
11840
11841
11842
11843
11844 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
11845
11846 static char *
11847 tz_parse_offset(char *s, int *offset)
11848 {
11849     int hour = 0, min = 0, sec = 0;
11850     int neg = 0;
11851     if (!s) return 0;
11852     if (!offset) return 0;
11853
11854     if (*s == '-') {neg++; s++;}
11855     if (*s == '+') s++;
11856     if (!isdigit(*s)) return 0;
11857     hour = *s++ - '0';
11858     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11859     if (hour > 24) return 0;
11860     if (*s == ':') {
11861         if (!isdigit(*++s)) return 0;
11862         min = *s++ - '0';
11863         if (isdigit(*s)) min = min*10 + (*s++ - '0');
11864         if (min > 59) return 0;
11865         if (*s == ':') {
11866             if (!isdigit(*++s)) return 0;
11867             sec = *s++ - '0';
11868             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11869             if (sec > 59) return 0;
11870         }
11871     }
11872
11873     *offset = (hour*60+min)*60 + sec;
11874     if (neg) *offset = -*offset;
11875     return s;
11876 }
11877
11878 /*
11879     input time is w, whatever type of time the CRTL localtime() uses.
11880     sets dst, the zone, and the gmtoff (seconds)
11881
11882     caches the value of TZ and UCX$TZ env variables; note that
11883     my_setenv looks for these and sets a flag if they're changed
11884     for efficiency.
11885
11886     We have to watch out for the "australian" case (dst starts in
11887     october, ends in april)...flagged by "reverse" and checked by
11888     scanning through the months of the previous year.
11889
11890 */
11891
11892 static int
11893 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11894 {
11895     time_t when;
11896     struct tm *w2;
11897     char *s,*s2;
11898     char *dstzone, *tz, *s_start, *s_end;
11899     int std_off, dst_off, isdst;
11900     int y, dststart, dstend;
11901     static char envtz[1025];  /* longer than any logical, symbol, ... */
11902     static char ucxtz[1025];
11903     static char reversed = 0;
11904
11905     if (!w) return 0;
11906
11907     if (tz_updated) {
11908         tz_updated = 0;
11909         reversed = -1;  /* flag need to check  */
11910         envtz[0] = ucxtz[0] = '\0';
11911         tz = my_getenv("TZ",0);
11912         if (tz) strcpy(envtz, tz);
11913         tz = my_getenv("UCX$TZ",0);
11914         if (tz) strcpy(ucxtz, tz);
11915         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
11916     }
11917     tz = envtz;
11918     if (!*tz) tz = ucxtz;
11919
11920     s = tz;
11921     while (isalpha(*s)) s++;
11922     s = tz_parse_offset(s, &std_off);
11923     if (!s) return 0;
11924     if (!*s) {                  /* no DST, hurray we're done! */
11925         isdst = 0;
11926         goto done;
11927     }
11928
11929     dstzone = s;
11930     while (isalpha(*s)) s++;
11931     s2 = tz_parse_offset(s, &dst_off);
11932     if (s2) {
11933         s = s2;
11934     } else {
11935         dst_off = std_off - 3600;
11936     }
11937
11938     if (!*s) {      /* default dst start/end?? */
11939         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
11940             s = strchr(ucxtz,',');
11941         }
11942         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
11943     }
11944     if (*s != ',') return 0;
11945
11946     when = *w;
11947     when = _toutc(when);      /* convert to utc */
11948     when = when - std_off;    /* convert to pseudolocal time*/
11949
11950     w2 = localtime(&when);
11951     y = w2->tm_year;
11952     s_start = s+1;
11953     s = tz_parse_startend(s_start,w2,&dststart);
11954     if (!s) return 0;
11955     if (*s != ',') return 0;
11956
11957     when = *w;
11958     when = _toutc(when);      /* convert to utc */
11959     when = when - dst_off;    /* convert to pseudolocal time*/
11960     w2 = localtime(&when);
11961     if (w2->tm_year != y) {   /* spans a year, just check one time */
11962         when += dst_off - std_off;
11963         w2 = localtime(&when);
11964     }
11965     s_end = s+1;
11966     s = tz_parse_startend(s_end,w2,&dstend);
11967     if (!s) return 0;
11968
11969     if (reversed == -1) {  /* need to check if start later than end */
11970         int j, ds, de;
11971
11972         when = *w;
11973         if (when < 2*365*86400) {
11974             when += 2*365*86400;
11975         } else {
11976             when -= 365*86400;
11977         }
11978         w2 =localtime(&when);
11979         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
11980
11981         for (j = 0; j < 12; j++) {
11982             w2 =localtime(&when);
11983             tz_parse_startend(s_start,w2,&ds);
11984             tz_parse_startend(s_end,w2,&de);
11985             if (ds != de) break;
11986             when += 30*86400;
11987         }
11988         reversed = 0;
11989         if (de && !ds) reversed = 1;
11990     }
11991
11992     isdst = dststart && !dstend;
11993     if (reversed) isdst = dststart  || !dstend;
11994
11995 done:
11996     if (dst)    *dst = isdst;
11997     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11998     if (isdst)  tz = dstzone;
11999     if (zone) {
12000         while(isalpha(*tz))  *zone++ = *tz++;
12001         *zone = '\0';
12002     }
12003     return 1;
12004 }
12005
12006 #endif /* !RTL_USES_UTC */
12007
12008 /* my_time(), my_localtime(), my_gmtime()
12009  * By default traffic in UTC time values, using CRTL gmtime() or
12010  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
12011  * Note: We need to use these functions even when the CRTL has working
12012  * UTC support, since they also handle C<use vmsish qw(times);>
12013  *
12014  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
12015  * Modified by Charles Bailey <bailey@newman.upenn.edu>
12016  */
12017
12018 /*{{{time_t my_time(time_t *timep)*/
12019 time_t Perl_my_time(pTHX_ time_t *timep)
12020 {
12021   time_t when;
12022   struct tm *tm_p;
12023
12024   if (gmtime_emulation_type == 0) {
12025     int dstnow;
12026     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
12027                               /* results of calls to gmtime() and localtime() */
12028                               /* for same &base */
12029
12030     gmtime_emulation_type++;
12031     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
12032       char off[LNM$C_NAMLENGTH+1];;
12033
12034       gmtime_emulation_type++;
12035       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
12036         gmtime_emulation_type++;
12037         utc_offset_secs = 0;
12038         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
12039       }
12040       else { utc_offset_secs = atol(off); }
12041     }
12042     else { /* We've got a working gmtime() */
12043       struct tm gmt, local;
12044
12045       gmt = *tm_p;
12046       tm_p = localtime(&base);
12047       local = *tm_p;
12048       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
12049       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
12050       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
12051       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
12052     }
12053   }
12054
12055   when = time(NULL);
12056 # ifdef VMSISH_TIME
12057 # ifdef RTL_USES_UTC
12058   if (VMSISH_TIME) when = _toloc(when);
12059 # else
12060   if (!VMSISH_TIME) when = _toutc(when);
12061 # endif
12062 # endif
12063   if (timep != NULL) *timep = when;
12064   return when;
12065
12066 }  /* end of my_time() */
12067 /*}}}*/
12068
12069
12070 /*{{{struct tm *my_gmtime(const time_t *timep)*/
12071 struct tm *
12072 Perl_my_gmtime(pTHX_ const time_t *timep)
12073 {
12074   char *p;
12075   time_t when;
12076   struct tm *rsltmp;
12077
12078   if (timep == NULL) {
12079     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12080     return NULL;
12081   }
12082   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
12083
12084   when = *timep;
12085 # ifdef VMSISH_TIME
12086   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
12087 #  endif
12088 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
12089   return gmtime(&when);
12090 # else
12091   /* CRTL localtime() wants local time as input, so does no tz correction */
12092   rsltmp = localtime(&when);
12093   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
12094   return rsltmp;
12095 #endif
12096 }  /* end of my_gmtime() */
12097 /*}}}*/
12098
12099
12100 /*{{{struct tm *my_localtime(const time_t *timep)*/
12101 struct tm *
12102 Perl_my_localtime(pTHX_ const time_t *timep)
12103 {
12104   time_t when, whenutc;
12105   struct tm *rsltmp;
12106   int dst, offset;
12107
12108   if (timep == NULL) {
12109     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12110     return NULL;
12111   }
12112   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
12113   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
12114
12115   when = *timep;
12116 # ifdef RTL_USES_UTC
12117 # ifdef VMSISH_TIME
12118   if (VMSISH_TIME) when = _toutc(when);
12119 # endif
12120   /* CRTL localtime() wants UTC as input, does tz correction itself */
12121   return localtime(&when);
12122
12123 # else /* !RTL_USES_UTC */
12124   whenutc = when;
12125 # ifdef VMSISH_TIME
12126   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
12127   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
12128 # endif
12129   dst = -1;
12130 #ifndef RTL_USES_UTC
12131   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
12132       when = whenutc - offset;                   /* pseudolocal time*/
12133   }
12134 # endif
12135   /* CRTL localtime() wants local time as input, so does no tz correction */
12136   rsltmp = localtime(&when);
12137   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
12138   return rsltmp;
12139 # endif
12140
12141 } /*  end of my_localtime() */
12142 /*}}}*/
12143
12144 /* Reset definitions for later calls */
12145 #define gmtime(t)    my_gmtime(t)
12146 #define localtime(t) my_localtime(t)
12147 #define time(t)      my_time(t)
12148
12149
12150 /* my_utime - update modification/access time of a file
12151  *
12152  * VMS 7.3 and later implementation
12153  * Only the UTC translation is home-grown. The rest is handled by the
12154  * CRTL utime(), which will take into account the relevant feature
12155  * logicals and ODS-5 volume characteristics for true access times.
12156  *
12157  * pre VMS 7.3 implementation:
12158  * The calling sequence is identical to POSIX utime(), but under
12159  * VMS with ODS-2, only the modification time is changed; ODS-2 does
12160  * not maintain access times.  Restrictions differ from the POSIX
12161  * definition in that the time can be changed as long as the
12162  * caller has permission to execute the necessary IO$_MODIFY $QIO;
12163  * no separate checks are made to insure that the caller is the
12164  * owner of the file or has special privs enabled.
12165  * Code here is based on Joe Meadows' FILE utility.
12166  *
12167  */
12168
12169 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
12170  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
12171  * in 100 ns intervals.
12172  */
12173 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
12174
12175 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
12176 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
12177 {
12178 #if __CRTL_VER >= 70300000
12179   struct utimbuf utc_utimes, *utc_utimesp;
12180
12181   if (utimes != NULL) {
12182     utc_utimes.actime = utimes->actime;
12183     utc_utimes.modtime = utimes->modtime;
12184 # ifdef VMSISH_TIME
12185     /* If input was local; convert to UTC for sys svc */
12186     if (VMSISH_TIME) {
12187       utc_utimes.actime = _toutc(utimes->actime);
12188       utc_utimes.modtime = _toutc(utimes->modtime);
12189     }
12190 # endif
12191     utc_utimesp = &utc_utimes;
12192   }
12193   else {
12194     utc_utimesp = NULL;
12195   }
12196
12197   return utime(file, utc_utimesp);
12198
12199 #else /* __CRTL_VER < 70300000 */
12200
12201   register int i;
12202   int sts;
12203   long int bintime[2], len = 2, lowbit, unixtime,
12204            secscale = 10000000; /* seconds --> 100 ns intervals */
12205   unsigned long int chan, iosb[2], retsts;
12206   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
12207   struct FAB myfab = cc$rms_fab;
12208   struct NAM mynam = cc$rms_nam;
12209 #if defined (__DECC) && defined (__VAX)
12210   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
12211    * at least through VMS V6.1, which causes a type-conversion warning.
12212    */
12213 #  pragma message save
12214 #  pragma message disable cvtdiftypes
12215 #endif
12216   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
12217   struct fibdef myfib;
12218 #if defined (__DECC) && defined (__VAX)
12219   /* This should be right after the declaration of myatr, but due
12220    * to a bug in VAX DEC C, this takes effect a statement early.
12221    */
12222 #  pragma message restore
12223 #endif
12224   /* cast ok for read only parameter */
12225   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
12226                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
12227                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
12228
12229   if (file == NULL || *file == '\0') {
12230     SETERRNO(ENOENT, LIB$_INVARG);
12231     return -1;
12232   }
12233
12234   /* Convert to VMS format ensuring that it will fit in 255 characters */
12235   if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
12236       SETERRNO(ENOENT, LIB$_INVARG);
12237       return -1;
12238   }
12239   if (utimes != NULL) {
12240     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
12241      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
12242      * Since time_t is unsigned long int, and lib$emul takes a signed long int
12243      * as input, we force the sign bit to be clear by shifting unixtime right
12244      * one bit, then multiplying by an extra factor of 2 in lib$emul().
12245      */
12246     lowbit = (utimes->modtime & 1) ? secscale : 0;
12247     unixtime = (long int) utimes->modtime;
12248 #   ifdef VMSISH_TIME
12249     /* If input was UTC; convert to local for sys svc */
12250     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
12251 #   endif
12252     unixtime >>= 1;  secscale <<= 1;
12253     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
12254     if (!(retsts & 1)) {
12255       SETERRNO(EVMSERR, retsts);
12256       return -1;
12257     }
12258     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
12259     if (!(retsts & 1)) {
12260       SETERRNO(EVMSERR, retsts);
12261       return -1;
12262     }
12263   }
12264   else {
12265     /* Just get the current time in VMS format directly */
12266     retsts = sys$gettim(bintime);
12267     if (!(retsts & 1)) {
12268       SETERRNO(EVMSERR, retsts);
12269       return -1;
12270     }
12271   }
12272
12273   myfab.fab$l_fna = vmsspec;
12274   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
12275   myfab.fab$l_nam = &mynam;
12276   mynam.nam$l_esa = esa;
12277   mynam.nam$b_ess = (unsigned char) sizeof esa;
12278   mynam.nam$l_rsa = rsa;
12279   mynam.nam$b_rss = (unsigned char) sizeof rsa;
12280   if (decc_efs_case_preserve)
12281       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
12282
12283   /* Look for the file to be affected, letting RMS parse the file
12284    * specification for us as well.  I have set errno using only
12285    * values documented in the utime() man page for VMS POSIX.
12286    */
12287   retsts = sys$parse(&myfab,0,0);
12288   if (!(retsts & 1)) {
12289     set_vaxc_errno(retsts);
12290     if      (retsts == RMS$_PRV) set_errno(EACCES);
12291     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
12292     else                         set_errno(EVMSERR);
12293     return -1;
12294   }
12295   retsts = sys$search(&myfab,0,0);
12296   if (!(retsts & 1)) {
12297     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12298     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12299     set_vaxc_errno(retsts);
12300     if      (retsts == RMS$_PRV) set_errno(EACCES);
12301     else if (retsts == RMS$_FNF) set_errno(ENOENT);
12302     else                         set_errno(EVMSERR);
12303     return -1;
12304   }
12305
12306   devdsc.dsc$w_length = mynam.nam$b_dev;
12307   /* cast ok for read only parameter */
12308   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
12309
12310   retsts = sys$assign(&devdsc,&chan,0,0);
12311   if (!(retsts & 1)) {
12312     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12313     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12314     set_vaxc_errno(retsts);
12315     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
12316     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
12317     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
12318     else                               set_errno(EVMSERR);
12319     return -1;
12320   }
12321
12322   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
12323   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
12324
12325   memset((void *) &myfib, 0, sizeof myfib);
12326 #if defined(__DECC) || defined(__DECCXX)
12327   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
12328   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
12329   /* This prevents the revision time of the file being reset to the current
12330    * time as a result of our IO$_MODIFY $QIO. */
12331   myfib.fib$l_acctl = FIB$M_NORECORD;
12332 #else
12333   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
12334   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
12335   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
12336 #endif
12337   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
12338   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
12339   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
12340   _ckvmssts(sys$dassgn(chan));
12341   if (retsts & 1) retsts = iosb[0];
12342   if (!(retsts & 1)) {
12343     set_vaxc_errno(retsts);
12344     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12345     else                      set_errno(EVMSERR);
12346     return -1;
12347   }
12348
12349   return 0;
12350
12351 #endif /* #if __CRTL_VER >= 70300000 */
12352
12353 }  /* end of my_utime() */
12354 /*}}}*/
12355
12356 /*
12357  * flex_stat, flex_lstat, flex_fstat
12358  * basic stat, but gets it right when asked to stat
12359  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
12360  */
12361
12362 #ifndef _USE_STD_STAT
12363 /* encode_dev packs a VMS device name string into an integer to allow
12364  * simple comparisons. This can be used, for example, to check whether two
12365  * files are located on the same device, by comparing their encoded device
12366  * names. Even a string comparison would not do, because stat() reuses the
12367  * device name buffer for each call; so without encode_dev, it would be
12368  * necessary to save the buffer and use strcmp (this would mean a number of
12369  * changes to the standard Perl code, to say nothing of what a Perl script
12370  * would have to do.
12371  *
12372  * The device lock id, if it exists, should be unique (unless perhaps compared
12373  * with lock ids transferred from other nodes). We have a lock id if the disk is
12374  * mounted cluster-wide, which is when we tend to get long (host-qualified)
12375  * device names. Thus we use the lock id in preference, and only if that isn't
12376  * available, do we try to pack the device name into an integer (flagged by
12377  * the sign bit (LOCKID_MASK) being set).
12378  *
12379  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
12380  * name and its encoded form, but it seems very unlikely that we will find
12381  * two files on different disks that share the same encoded device names,
12382  * and even more remote that they will share the same file id (if the test
12383  * is to check for the same file).
12384  *
12385  * A better method might be to use sys$device_scan on the first call, and to
12386  * search for the device, returning an index into the cached array.
12387  * The number returned would be more intelligible.
12388  * This is probably not worth it, and anyway would take quite a bit longer
12389  * on the first call.
12390  */
12391 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
12392 static mydev_t encode_dev (pTHX_ const char *dev)
12393 {
12394   int i;
12395   unsigned long int f;
12396   mydev_t enc;
12397   char c;
12398   const char *q;
12399
12400   if (!dev || !dev[0]) return 0;
12401
12402 #if LOCKID_MASK
12403   {
12404     struct dsc$descriptor_s dev_desc;
12405     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
12406
12407     /* For cluster-mounted disks, the disk lock identifier is unique, so we
12408        can try that first. */
12409     dev_desc.dsc$w_length =  strlen (dev);
12410     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
12411     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
12412     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
12413     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
12414     if (!$VMS_STATUS_SUCCESS(status)) {
12415       switch (status) {
12416         case SS$_NOSUCHDEV:
12417           SETERRNO(ENODEV, status);
12418           return 0;
12419         default:
12420           _ckvmssts(status);
12421       }
12422     }
12423     if (lockid) return (lockid & ~LOCKID_MASK);
12424   }
12425 #endif
12426
12427   /* Otherwise we try to encode the device name */
12428   enc = 0;
12429   f = 1;
12430   i = 0;
12431   for (q = dev + strlen(dev); q--; q >= dev) {
12432     if (*q == ':')
12433         break;
12434     if (isdigit (*q))
12435       c= (*q) - '0';
12436     else if (isalpha (toupper (*q)))
12437       c= toupper (*q) - 'A' + (char)10;
12438     else
12439       continue; /* Skip '$'s */
12440     i++;
12441     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
12442     if (i>1) f *= 36;
12443     enc += f * (unsigned long int) c;
12444   }
12445   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
12446
12447 }  /* end of encode_dev() */
12448 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12449         device_no = encode_dev(aTHX_ devname)
12450 #else
12451 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12452         device_no = new_dev_no
12453 #endif
12454
12455 static int
12456 is_null_device(name)
12457     const char *name;
12458 {
12459   if (decc_bug_devnull != 0) {
12460     if (strncmp("/dev/null", name, 9) == 0)
12461       return 1;
12462   }
12463     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
12464        The underscore prefix, controller letter, and unit number are
12465        independently optional; for our purposes, the colon punctuation
12466        is not.  The colon can be trailed by optional directory and/or
12467        filename, but two consecutive colons indicates a nodename rather
12468        than a device.  [pr]  */
12469   if (*name == '_') ++name;
12470   if (tolower(*name++) != 'n') return 0;
12471   if (tolower(*name++) != 'l') return 0;
12472   if (tolower(*name) == 'a') ++name;
12473   if (*name == '0') ++name;
12474   return (*name++ == ':') && (*name != ':');
12475 }
12476
12477 static int
12478 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
12479
12480 static I32
12481 Perl_cando_by_name_int
12482    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
12483 {
12484   char usrname[L_cuserid];
12485   struct dsc$descriptor_s usrdsc =
12486          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
12487   char *vmsname = NULL, *fileified = NULL;
12488   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
12489   unsigned short int retlen, trnlnm_iter_count;
12490   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12491   union prvdef curprv;
12492   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
12493          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
12494          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
12495   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
12496          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
12497          {0,0,0,0}};
12498   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
12499          {0,0,0,0}};
12500   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12501   Stat_t st;
12502   static int profile_context = -1;
12503
12504   if (!fname || !*fname) return FALSE;
12505
12506   /* Make sure we expand logical names, since sys$check_access doesn't */
12507   fileified = PerlMem_malloc(VMS_MAXRSS);
12508   if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12509   if (!strpbrk(fname,"/]>:")) {
12510       strcpy(fileified,fname);
12511       trnlnm_iter_count = 0;
12512       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
12513         trnlnm_iter_count++;
12514         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
12515       }
12516       fname = fileified;
12517   }
12518
12519   vmsname = PerlMem_malloc(VMS_MAXRSS);
12520   if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12521   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
12522     /* Don't know if already in VMS format, so make sure */
12523     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
12524       PerlMem_free(fileified);
12525       PerlMem_free(vmsname);
12526       return FALSE;
12527     }
12528   }
12529   else {
12530     strcpy(vmsname,fname);
12531   }
12532
12533   /* sys$check_access needs a file spec, not a directory spec.
12534    * flex_stat now will handle a null thread context during startup.
12535    */
12536
12537   retlen = namdsc.dsc$w_length = strlen(vmsname);
12538   if (vmsname[retlen-1] == ']'
12539       || vmsname[retlen-1] == '>'
12540       || vmsname[retlen-1] == ':'
12541       || (!Perl_flex_stat_int(NULL, vmsname, &st, 1) &&
12542           S_ISDIR(st.st_mode))) {
12543
12544       if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
12545         PerlMem_free(fileified);
12546         PerlMem_free(vmsname);
12547         return FALSE;
12548       }
12549       fname = fileified;
12550   }
12551   else {
12552       fname = vmsname;
12553   }
12554
12555   retlen = namdsc.dsc$w_length = strlen(fname);
12556   namdsc.dsc$a_pointer = (char *)fname;
12557
12558   switch (bit) {
12559     case S_IXUSR: case S_IXGRP: case S_IXOTH:
12560       access = ARM$M_EXECUTE;
12561       flags = CHP$M_READ;
12562       break;
12563     case S_IRUSR: case S_IRGRP: case S_IROTH:
12564       access = ARM$M_READ;
12565       flags = CHP$M_READ | CHP$M_USEREADALL;
12566       break;
12567     case S_IWUSR: case S_IWGRP: case S_IWOTH:
12568       access = ARM$M_WRITE;
12569       flags = CHP$M_READ | CHP$M_WRITE;
12570       break;
12571     case S_IDUSR: case S_IDGRP: case S_IDOTH:
12572       access = ARM$M_DELETE;
12573       flags = CHP$M_READ | CHP$M_WRITE;
12574       break;
12575     default:
12576       if (fileified != NULL)
12577         PerlMem_free(fileified);
12578       if (vmsname != NULL)
12579         PerlMem_free(vmsname);
12580       return FALSE;
12581   }
12582
12583   /* Before we call $check_access, create a user profile with the current
12584    * process privs since otherwise it just uses the default privs from the
12585    * UAF and might give false positives or negatives.  This only works on
12586    * VMS versions v6.0 and later since that's when sys$create_user_profile
12587    * became available.
12588    */
12589
12590   /* get current process privs and username */
12591   _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12592   _ckvmssts_noperl(iosb[0]);
12593
12594 #if defined(__VMS_VER) && __VMS_VER >= 60000000
12595
12596   /* find out the space required for the profile */
12597   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12598                                     &usrprodsc.dsc$w_length,&profile_context));
12599
12600   /* allocate space for the profile and get it filled in */
12601   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
12602   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12603   _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12604                                     &usrprodsc.dsc$w_length,&profile_context));
12605
12606   /* use the profile to check access to the file; free profile & analyze results */
12607   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12608   PerlMem_free(usrprodsc.dsc$a_pointer);
12609   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12610
12611 #else
12612
12613   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
12614
12615 #endif
12616
12617   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
12618       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12619       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12620     set_vaxc_errno(retsts);
12621     if (retsts == SS$_NOPRIV) set_errno(EACCES);
12622     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12623     else set_errno(ENOENT);
12624     if (fileified != NULL)
12625       PerlMem_free(fileified);
12626     if (vmsname != NULL)
12627       PerlMem_free(vmsname);
12628     return FALSE;
12629   }
12630   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12631     if (fileified != NULL)
12632       PerlMem_free(fileified);
12633     if (vmsname != NULL)
12634       PerlMem_free(vmsname);
12635     return TRUE;
12636   }
12637   _ckvmssts_noperl(retsts);
12638
12639   if (fileified != NULL)
12640     PerlMem_free(fileified);
12641   if (vmsname != NULL)
12642     PerlMem_free(vmsname);
12643   return FALSE;  /* Should never get here */
12644
12645 }
12646
12647 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
12648 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12649  * subset of the applicable information.
12650  */
12651 bool
12652 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12653 {
12654   return cando_by_name_int
12655         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12656 }  /* end of cando() */
12657 /*}}}*/
12658
12659
12660 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12661 I32
12662 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12663 {
12664    return cando_by_name_int(bit, effective, fname, 0);
12665
12666 }  /* end of cando_by_name() */
12667 /*}}}*/
12668
12669
12670 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12671 int
12672 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12673 {
12674   if (!fstat(fd, &statbufp->crtl_stat)) {
12675     char *cptr;
12676     char *vms_filename;
12677     vms_filename = PerlMem_malloc(VMS_MAXRSS);
12678     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12679
12680     /* Save name for cando by name in VMS format */
12681     cptr = getname(fd, vms_filename, 1);
12682
12683     /* This should not happen, but just in case */
12684     if (cptr == NULL) {
12685         statbufp->st_devnam[0] = 0;
12686     }
12687     else {
12688         /* Make sure that the saved name fits in 255 characters */
12689         cptr = int_rmsexpand_vms
12690                        (vms_filename,
12691                         statbufp->st_devnam,
12692                         0);
12693         if (cptr == NULL)
12694             statbufp->st_devnam[0] = 0;
12695     }
12696     PerlMem_free(vms_filename);
12697
12698     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12699     VMS_DEVICE_ENCODE
12700         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12701
12702 #   ifdef RTL_USES_UTC
12703 #   ifdef VMSISH_TIME
12704     if (VMSISH_TIME) {
12705       statbufp->st_mtime = _toloc(statbufp->st_mtime);
12706       statbufp->st_atime = _toloc(statbufp->st_atime);
12707       statbufp->st_ctime = _toloc(statbufp->st_ctime);
12708     }
12709 #   endif
12710 #   else
12711 #   ifdef VMSISH_TIME
12712     if (!VMSISH_TIME) { /* Return UTC instead of local time */
12713 #   else
12714     if (1) {
12715 #   endif
12716       statbufp->st_mtime = _toutc(statbufp->st_mtime);
12717       statbufp->st_atime = _toutc(statbufp->st_atime);
12718       statbufp->st_ctime = _toutc(statbufp->st_ctime);
12719     }
12720 #endif
12721     return 0;
12722   }
12723   return -1;
12724
12725 }  /* end of flex_fstat() */
12726 /*}}}*/
12727
12728 #if !defined(__VAX) && __CRTL_VER >= 80200000
12729 #ifdef lstat
12730 #undef lstat
12731 #endif
12732 #else
12733 #ifdef lstat
12734 #undef lstat
12735 #endif
12736 #define lstat(_x, _y) stat(_x, _y)
12737 #endif
12738
12739 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
12740
12741 static int
12742 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12743 {
12744     char *fileified;
12745     char *temp_fspec;
12746     const char *save_spec;
12747     char *ret_spec;
12748     int retval = -1;
12749     int efs_hack = 0;
12750     dSAVEDERRNO;
12751
12752     if (!fspec) {
12753         errno = EINVAL;
12754         return retval;
12755     }
12756
12757     if (decc_bug_devnull != 0) {
12758       if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12759         memset(statbufp,0,sizeof *statbufp);
12760         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12761         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12762         statbufp->st_uid = 0x00010001;
12763         statbufp->st_gid = 0x0001;
12764         time((time_t *)&statbufp->st_mtime);
12765         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12766         return 0;
12767       }
12768     }
12769
12770     /* Try for a directory name first.  If fspec contains a filename without
12771      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12772      * and sea:[wine.dark]water. exist, we prefer the directory here.
12773      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12774      * not sea:[wine.dark]., if the latter exists.  If the intended target is
12775      * the file with null type, specify this by calling flex_stat() with
12776      * a '.' at the end of fspec.
12777      *
12778      * If we are in Posix filespec mode, accept the filename as is.
12779      */
12780
12781
12782     fileified = PerlMem_malloc(VMS_MAXRSS);
12783     if (fileified == NULL)
12784         _ckvmssts_noperl(SS$_INSFMEM);
12785
12786     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
12787     if (temp_fspec == NULL)
12788         _ckvmssts_noperl(SS$_INSFMEM);
12789
12790     strcpy(temp_fspec, fspec);
12791
12792     SAVE_ERRNO;
12793
12794 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12795   if (decc_posix_compliant_pathnames == 0) {
12796 #endif
12797
12798     /* We may be able to optimize this, but in order for fileify_dirspec to
12799      * always return a usuable answer, we have to call vmspath first to
12800      * make sure that it is in VMS directory format, as stat/lstat on 8.3
12801      * can not handle directories in unix format that it does not have read
12802      * access to.  Vmspath handles the case where a bare name which could be
12803      * a logical name gets passed.
12804      */
12805     ret_spec = int_tovmspath(fspec, temp_fspec, NULL);
12806     if (ret_spec != NULL) {
12807         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
12808         if (ret_spec != NULL) {
12809             if (lstat_flag == 0)
12810                 retval = stat(fileified, &statbufp->crtl_stat);
12811             else
12812                 retval = lstat(fileified, &statbufp->crtl_stat);
12813             save_spec = fileified;
12814         }
12815     }
12816
12817     if (retval && vms_bug_stat_filename) {
12818
12819         /* We should try again as a vmsified file specification */
12820         /* However Perl traditionally has not done this, which  */
12821         /* causes problems with existing tests */
12822
12823         ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12824         if (ret_spec != NULL) {
12825             if (lstat_flag == 0)
12826                 retval = stat(temp_fspec, &statbufp->crtl_stat);
12827             else
12828                 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12829             save_spec = temp_fspec;
12830         }
12831     }
12832
12833     if (retval) {
12834         /* Last chance - allow multiple dots with out EFS CHARSET */
12835         /* The CRTL stat() falls down hard on multi-dot filenames in unix
12836          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12837          * enable it if it isn't already.
12838          */
12839 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12840         if (!decc_efs_charset && (decc_efs_charset_index > 0))
12841             decc$feature_set_value(decc_efs_charset_index, 1, 1);
12842 #endif
12843         if (lstat_flag == 0)
12844             retval = stat(fspec, &statbufp->crtl_stat);
12845         else
12846             retval = lstat(fspec, &statbufp->crtl_stat);
12847         save_spec = fspec;
12848 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12849         if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12850             decc$feature_set_value(decc_efs_charset_index, 1, 0);
12851             efs_hack = 1;
12852         }
12853 #endif
12854     }
12855
12856 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12857   } else {
12858     if (lstat_flag == 0)
12859       retval = stat(temp_fspec, &statbufp->crtl_stat);
12860     else
12861       retval = lstat(temp_fspec, &statbufp->crtl_stat);
12862       save_spec = temp_fspec;
12863   }
12864 #endif
12865
12866 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12867   /* As you were... */
12868   if (!decc_efs_charset)
12869     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12870 #endif
12871
12872     if (!retval) {
12873     char * cptr;
12874     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12875
12876       /* If this is an lstat, do not follow the link */
12877       if (lstat_flag)
12878         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12879
12880 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12881       /* If we used the efs_hack above, we must also use it here for */
12882       /* perl_cando to work */
12883       if (efs_hack && (decc_efs_charset_index > 0)) {
12884           decc$feature_set_value(decc_efs_charset_index, 1, 1);
12885       }
12886 #endif
12887       cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags);
12888 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12889       if (efs_hack && (decc_efs_charset_index > 0)) {
12890           decc$feature_set_value(decc_efs_charset, 1, 0);
12891       }
12892 #endif
12893
12894       /* Fix me: If this is NULL then stat found a file, and we could */
12895       /* not convert the specification to VMS - Should never happen */
12896       if (cptr == NULL)
12897         statbufp->st_devnam[0] = 0;
12898
12899       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12900       VMS_DEVICE_ENCODE
12901         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12902 #     ifdef RTL_USES_UTC
12903 #     ifdef VMSISH_TIME
12904       if (VMSISH_TIME) {
12905         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12906         statbufp->st_atime = _toloc(statbufp->st_atime);
12907         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12908       }
12909 #     endif
12910 #     else
12911 #     ifdef VMSISH_TIME
12912       if (!VMSISH_TIME) { /* Return UTC instead of local time */
12913 #     else
12914       if (1) {
12915 #     endif
12916         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12917         statbufp->st_atime = _toutc(statbufp->st_atime);
12918         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12919       }
12920 #     endif
12921     }
12922     /* If we were successful, leave errno where we found it */
12923     if (retval == 0) RESTORE_ERRNO;
12924     return retval;
12925
12926 }  /* end of flex_stat_int() */
12927
12928
12929 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12930 int
12931 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12932 {
12933    return flex_stat_int(fspec, statbufp, 0);
12934 }
12935 /*}}}*/
12936
12937 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12938 int
12939 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12940 {
12941    return flex_stat_int(fspec, statbufp, 1);
12942 }
12943 /*}}}*/
12944
12945
12946 /*{{{char *my_getlogin()*/
12947 /* VMS cuserid == Unix getlogin, except calling sequence */
12948 char *
12949 my_getlogin(void)
12950 {
12951     static char user[L_cuserid];
12952     return cuserid(user);
12953 }
12954 /*}}}*/
12955
12956
12957 /*  rmscopy - copy a file using VMS RMS routines
12958  *
12959  *  Copies contents and attributes of spec_in to spec_out, except owner
12960  *  and protection information.  Name and type of spec_in are used as
12961  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12962  *  should try to propagate timestamps from the input file to the output file.
12963  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12964  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12965  *  propagated to the output file at creation iff the output file specification
12966  *  did not contain an explicit name or type, and the revision date is always
12967  *  updated at the end of the copy operation.  If it is greater than 0, then
12968  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12969  *  other than the revision date should be propagated, and bit 1 indicates
12970  *  that the revision date should be propagated.
12971  *
12972  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12973  *
12974  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12975  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12976  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12977  * as part of the Perl standard distribution under the terms of the
12978  * GNU General Public License or the Perl Artistic License.  Copies
12979  * of each may be found in the Perl standard distribution.
12980  */ /* FIXME */
12981 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12982 int
12983 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12984 {
12985     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12986          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12987     unsigned long int i, sts, sts2;
12988     int dna_len;
12989     struct FAB fab_in, fab_out;
12990     struct RAB rab_in, rab_out;
12991     rms_setup_nam(nam);
12992     rms_setup_nam(nam_out);
12993     struct XABDAT xabdat;
12994     struct XABFHC xabfhc;
12995     struct XABRDT xabrdt;
12996     struct XABSUM xabsum;
12997
12998     vmsin = PerlMem_malloc(VMS_MAXRSS);
12999     if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13000     vmsout = PerlMem_malloc(VMS_MAXRSS);
13001     if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13002     if (!spec_in  || !*spec_in  || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
13003         !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
13004       PerlMem_free(vmsin);
13005       PerlMem_free(vmsout);
13006       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13007       return 0;
13008     }
13009
13010     esa = PerlMem_malloc(VMS_MAXRSS);
13011     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13012     esal = NULL;
13013 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13014     esal = PerlMem_malloc(VMS_MAXRSS);
13015     if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13016 #endif
13017     fab_in = cc$rms_fab;
13018     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
13019     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
13020     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
13021     fab_in.fab$l_fop = FAB$M_SQO;
13022     rms_bind_fab_nam(fab_in, nam);
13023     fab_in.fab$l_xab = (void *) &xabdat;
13024
13025     rsa = PerlMem_malloc(VMS_MAXRSS);
13026     if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13027     rsal = NULL;
13028 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13029     rsal = PerlMem_malloc(VMS_MAXRSS);
13030     if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13031 #endif
13032     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
13033     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
13034     rms_nam_esl(nam) = 0;
13035     rms_nam_rsl(nam) = 0;
13036     rms_nam_esll(nam) = 0;
13037     rms_nam_rsll(nam) = 0;
13038 #ifdef NAM$M_NO_SHORT_UPCASE
13039     if (decc_efs_case_preserve)
13040         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
13041 #endif
13042
13043     xabdat = cc$rms_xabdat;        /* To get creation date */
13044     xabdat.xab$l_nxt = (void *) &xabfhc;
13045
13046     xabfhc = cc$rms_xabfhc;        /* To get record length */
13047     xabfhc.xab$l_nxt = (void *) &xabsum;
13048
13049     xabsum = cc$rms_xabsum;        /* To get key and area information */
13050
13051     if (!((sts = sys$open(&fab_in)) & 1)) {
13052       PerlMem_free(vmsin);
13053       PerlMem_free(vmsout);
13054       PerlMem_free(esa);
13055       if (esal != NULL)
13056         PerlMem_free(esal);
13057       PerlMem_free(rsa);
13058       if (rsal != NULL)
13059         PerlMem_free(rsal);
13060       set_vaxc_errno(sts);
13061       switch (sts) {
13062         case RMS$_FNF: case RMS$_DNF:
13063           set_errno(ENOENT); break;
13064         case RMS$_DIR:
13065           set_errno(ENOTDIR); break;
13066         case RMS$_DEV:
13067           set_errno(ENODEV); break;
13068         case RMS$_SYN:
13069           set_errno(EINVAL); break;
13070         case RMS$_PRV:
13071           set_errno(EACCES); break;
13072         default:
13073           set_errno(EVMSERR);
13074       }
13075       return 0;
13076     }
13077
13078     nam_out = nam;
13079     fab_out = fab_in;
13080     fab_out.fab$w_ifi = 0;
13081     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
13082     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
13083     fab_out.fab$l_fop = FAB$M_SQO;
13084     rms_bind_fab_nam(fab_out, nam_out);
13085     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
13086     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
13087     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
13088     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13089     if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13090     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13091     if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13092     esal_out = NULL;
13093     rsal_out = NULL;
13094 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13095     esal_out = PerlMem_malloc(VMS_MAXRSS);
13096     if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13097     rsal_out = PerlMem_malloc(VMS_MAXRSS);
13098     if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13099 #endif
13100     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
13101     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
13102
13103     if (preserve_dates == 0) {  /* Act like DCL COPY */
13104       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
13105       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
13106       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
13107         PerlMem_free(vmsin);
13108         PerlMem_free(vmsout);
13109         PerlMem_free(esa);
13110         if (esal != NULL)
13111             PerlMem_free(esal);
13112         PerlMem_free(rsa);
13113         if (rsal != NULL)
13114             PerlMem_free(rsal);
13115         PerlMem_free(esa_out);
13116         if (esal_out != NULL)
13117             PerlMem_free(esal_out);
13118         PerlMem_free(rsa_out);
13119         if (rsal_out != NULL)
13120             PerlMem_free(rsal_out);
13121         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
13122         set_vaxc_errno(sts);
13123         return 0;
13124       }
13125       fab_out.fab$l_xab = (void *) &xabdat;
13126       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
13127         preserve_dates = 1;
13128     }
13129     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
13130       preserve_dates =0;      /* bitmask from this point forward   */
13131
13132     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
13133     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
13134       PerlMem_free(vmsin);
13135       PerlMem_free(vmsout);
13136       PerlMem_free(esa);
13137       if (esal != NULL)
13138           PerlMem_free(esal);
13139       PerlMem_free(rsa);
13140       if (rsal != NULL)
13141           PerlMem_free(rsal);
13142       PerlMem_free(esa_out);
13143       if (esal_out != NULL)
13144           PerlMem_free(esal_out);
13145       PerlMem_free(rsa_out);
13146       if (rsal_out != NULL)
13147           PerlMem_free(rsal_out);
13148       set_vaxc_errno(sts);
13149       switch (sts) {
13150         case RMS$_DNF:
13151           set_errno(ENOENT); break;
13152         case RMS$_DIR:
13153           set_errno(ENOTDIR); break;
13154         case RMS$_DEV:
13155           set_errno(ENODEV); break;
13156         case RMS$_SYN:
13157           set_errno(EINVAL); break;
13158         case RMS$_PRV:
13159           set_errno(EACCES); break;
13160         default:
13161           set_errno(EVMSERR);
13162       }
13163       return 0;
13164     }
13165     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
13166     if (preserve_dates & 2) {
13167       /* sys$close() will process xabrdt, not xabdat */
13168       xabrdt = cc$rms_xabrdt;
13169 #ifndef __GNUC__
13170       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
13171 #else
13172       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
13173        * is unsigned long[2], while DECC & VAXC use a struct */
13174       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
13175 #endif
13176       fab_out.fab$l_xab = (void *) &xabrdt;
13177     }
13178
13179     ubf = PerlMem_malloc(32256);
13180     if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13181     rab_in = cc$rms_rab;
13182     rab_in.rab$l_fab = &fab_in;
13183     rab_in.rab$l_rop = RAB$M_BIO;
13184     rab_in.rab$l_ubf = ubf;
13185     rab_in.rab$w_usz = 32256;
13186     if (!((sts = sys$connect(&rab_in)) & 1)) {
13187       sys$close(&fab_in); sys$close(&fab_out);
13188       PerlMem_free(vmsin);
13189       PerlMem_free(vmsout);
13190       PerlMem_free(ubf);
13191       PerlMem_free(esa);
13192       if (esal != NULL)
13193           PerlMem_free(esal);
13194       PerlMem_free(rsa);
13195       if (rsal != NULL)
13196           PerlMem_free(rsal);
13197       PerlMem_free(esa_out);
13198       if (esal_out != NULL)
13199           PerlMem_free(esal_out);
13200       PerlMem_free(rsa_out);
13201       if (rsal_out != NULL)
13202           PerlMem_free(rsal_out);
13203       set_errno(EVMSERR); set_vaxc_errno(sts);
13204       return 0;
13205     }
13206
13207     rab_out = cc$rms_rab;
13208     rab_out.rab$l_fab = &fab_out;
13209     rab_out.rab$l_rbf = ubf;
13210     if (!((sts = sys$connect(&rab_out)) & 1)) {
13211       sys$close(&fab_in); sys$close(&fab_out);
13212       PerlMem_free(vmsin);
13213       PerlMem_free(vmsout);
13214       PerlMem_free(ubf);
13215       PerlMem_free(esa);
13216       if (esal != NULL)
13217           PerlMem_free(esal);
13218       PerlMem_free(rsa);
13219       if (rsal != NULL)
13220           PerlMem_free(rsal);
13221       PerlMem_free(esa_out);
13222       if (esal_out != NULL)
13223           PerlMem_free(esal_out);
13224       PerlMem_free(rsa_out);
13225       if (rsal_out != NULL)
13226           PerlMem_free(rsal_out);
13227       set_errno(EVMSERR); set_vaxc_errno(sts);
13228       return 0;
13229     }
13230
13231     while ((sts = sys$read(&rab_in))) {  /* always true  */
13232       if (sts == RMS$_EOF) break;
13233       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
13234       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
13235         sys$close(&fab_in); sys$close(&fab_out);
13236         PerlMem_free(vmsin);
13237         PerlMem_free(vmsout);
13238         PerlMem_free(ubf);
13239         PerlMem_free(esa);
13240         if (esal != NULL)
13241             PerlMem_free(esal);
13242         PerlMem_free(rsa);
13243         if (rsal != NULL)
13244             PerlMem_free(rsal);
13245         PerlMem_free(esa_out);
13246         if (esal_out != NULL)
13247             PerlMem_free(esal_out);
13248         PerlMem_free(rsa_out);
13249         if (rsal_out != NULL)
13250             PerlMem_free(rsal_out);
13251         set_errno(EVMSERR); set_vaxc_errno(sts);
13252         return 0;
13253       }
13254     }
13255
13256
13257     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
13258     sys$close(&fab_in);  sys$close(&fab_out);
13259     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
13260
13261     PerlMem_free(vmsin);
13262     PerlMem_free(vmsout);
13263     PerlMem_free(ubf);
13264     PerlMem_free(esa);
13265     if (esal != NULL)
13266         PerlMem_free(esal);
13267     PerlMem_free(rsa);
13268     if (rsal != NULL)
13269         PerlMem_free(rsal);
13270     PerlMem_free(esa_out);
13271     if (esal_out != NULL)
13272         PerlMem_free(esal_out);
13273     PerlMem_free(rsa_out);
13274     if (rsal_out != NULL)
13275         PerlMem_free(rsal_out);
13276
13277     if (!(sts & 1)) {
13278       set_errno(EVMSERR); set_vaxc_errno(sts);
13279       return 0;
13280     }
13281
13282     return 1;
13283
13284 }  /* end of rmscopy() */
13285 /*}}}*/
13286
13287
13288 /***  The following glue provides 'hooks' to make some of the routines
13289  * from this file available from Perl.  These routines are sufficiently
13290  * basic, and are required sufficiently early in the build process,
13291  * that's it's nice to have them available to miniperl as well as the
13292  * full Perl, so they're set up here instead of in an extension.  The
13293  * Perl code which handles importation of these names into a given
13294  * package lives in [.VMS]Filespec.pm in @INC.
13295  */
13296
13297 void
13298 rmsexpand_fromperl(pTHX_ CV *cv)
13299 {
13300   dXSARGS;
13301   char *fspec, *defspec = NULL, *rslt;
13302   STRLEN n_a;
13303   int fs_utf8, dfs_utf8;
13304
13305   fs_utf8 = 0;
13306   dfs_utf8 = 0;
13307   if (!items || items > 2)
13308     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
13309   fspec = SvPV(ST(0),n_a);
13310   fs_utf8 = SvUTF8(ST(0));
13311   if (!fspec || !*fspec) XSRETURN_UNDEF;
13312   if (items == 2) {
13313     defspec = SvPV(ST(1),n_a);
13314     dfs_utf8 = SvUTF8(ST(1));
13315   }
13316   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
13317   ST(0) = sv_newmortal();
13318   if (rslt != NULL) {
13319     sv_usepvn(ST(0),rslt,strlen(rslt));
13320     if (fs_utf8) {
13321         SvUTF8_on(ST(0));
13322     }
13323   }
13324   XSRETURN(1);
13325 }
13326
13327 void
13328 vmsify_fromperl(pTHX_ CV *cv)
13329 {
13330   dXSARGS;
13331   char *vmsified;
13332   STRLEN n_a;
13333   int utf8_fl;
13334
13335   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
13336   utf8_fl = SvUTF8(ST(0));
13337   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13338   ST(0) = sv_newmortal();
13339   if (vmsified != NULL) {
13340     sv_usepvn(ST(0),vmsified,strlen(vmsified));
13341     if (utf8_fl) {
13342         SvUTF8_on(ST(0));
13343     }
13344   }
13345   XSRETURN(1);
13346 }
13347
13348 void
13349 unixify_fromperl(pTHX_ CV *cv)
13350 {
13351   dXSARGS;
13352   char *unixified;
13353   STRLEN n_a;
13354   int utf8_fl;
13355
13356   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
13357   utf8_fl = SvUTF8(ST(0));
13358   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13359   ST(0) = sv_newmortal();
13360   if (unixified != NULL) {
13361     sv_usepvn(ST(0),unixified,strlen(unixified));
13362     if (utf8_fl) {
13363         SvUTF8_on(ST(0));
13364     }
13365   }
13366   XSRETURN(1);
13367 }
13368
13369 void
13370 fileify_fromperl(pTHX_ CV *cv)
13371 {
13372   dXSARGS;
13373   char *fileified;
13374   STRLEN n_a;
13375   int utf8_fl;
13376
13377   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
13378   utf8_fl = SvUTF8(ST(0));
13379   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13380   ST(0) = sv_newmortal();
13381   if (fileified != NULL) {
13382     sv_usepvn(ST(0),fileified,strlen(fileified));
13383     if (utf8_fl) {
13384         SvUTF8_on(ST(0));
13385     }
13386   }
13387   XSRETURN(1);
13388 }
13389
13390 void
13391 pathify_fromperl(pTHX_ CV *cv)
13392 {
13393   dXSARGS;
13394   char *pathified;
13395   STRLEN n_a;
13396   int utf8_fl;
13397
13398   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
13399   utf8_fl = SvUTF8(ST(0));
13400   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13401   ST(0) = sv_newmortal();
13402   if (pathified != NULL) {
13403     sv_usepvn(ST(0),pathified,strlen(pathified));
13404     if (utf8_fl) {
13405         SvUTF8_on(ST(0));
13406     }
13407   }
13408   XSRETURN(1);
13409 }
13410
13411 void
13412 vmspath_fromperl(pTHX_ CV *cv)
13413 {
13414   dXSARGS;
13415   char *vmspath;
13416   STRLEN n_a;
13417   int utf8_fl;
13418
13419   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
13420   utf8_fl = SvUTF8(ST(0));
13421   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13422   ST(0) = sv_newmortal();
13423   if (vmspath != NULL) {
13424     sv_usepvn(ST(0),vmspath,strlen(vmspath));
13425     if (utf8_fl) {
13426         SvUTF8_on(ST(0));
13427     }
13428   }
13429   XSRETURN(1);
13430 }
13431
13432 void
13433 unixpath_fromperl(pTHX_ CV *cv)
13434 {
13435   dXSARGS;
13436   char *unixpath;
13437   STRLEN n_a;
13438   int utf8_fl;
13439
13440   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
13441   utf8_fl = SvUTF8(ST(0));
13442   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13443   ST(0) = sv_newmortal();
13444   if (unixpath != NULL) {
13445     sv_usepvn(ST(0),unixpath,strlen(unixpath));
13446     if (utf8_fl) {
13447         SvUTF8_on(ST(0));
13448     }
13449   }
13450   XSRETURN(1);
13451 }
13452
13453 void
13454 candelete_fromperl(pTHX_ CV *cv)
13455 {
13456   dXSARGS;
13457   char *fspec, *fsp;
13458   SV *mysv;
13459   IO *io;
13460   STRLEN n_a;
13461
13462   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
13463
13464   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13465   Newx(fspec, VMS_MAXRSS, char);
13466   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
13467   if (SvTYPE(mysv) == SVt_PVGV) {
13468     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
13469       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13470       ST(0) = &PL_sv_no;
13471       Safefree(fspec);
13472       XSRETURN(1);
13473     }
13474     fsp = fspec;
13475   }
13476   else {
13477     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
13478       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13479       ST(0) = &PL_sv_no;
13480       Safefree(fspec);
13481       XSRETURN(1);
13482     }
13483   }
13484
13485   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
13486   Safefree(fspec);
13487   XSRETURN(1);
13488 }
13489
13490 void
13491 rmscopy_fromperl(pTHX_ CV *cv)
13492 {
13493   dXSARGS;
13494   char *inspec, *outspec, *inp, *outp;
13495   int date_flag;
13496   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
13497                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13498   unsigned long int sts;
13499   SV *mysv;
13500   IO *io;
13501   STRLEN n_a;
13502
13503   if (items < 2 || items > 3)
13504     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
13505
13506   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13507   Newx(inspec, VMS_MAXRSS, char);
13508   if (SvTYPE(mysv) == SVt_PVGV) {
13509     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
13510       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13511       ST(0) = &PL_sv_no;
13512       Safefree(inspec);
13513       XSRETURN(1);
13514     }
13515     inp = inspec;
13516   }
13517   else {
13518     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
13519       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13520       ST(0) = &PL_sv_no;
13521       Safefree(inspec);
13522       XSRETURN(1);
13523     }
13524   }
13525   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
13526   Newx(outspec, VMS_MAXRSS, char);
13527   if (SvTYPE(mysv) == SVt_PVGV) {
13528     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
13529       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13530       ST(0) = &PL_sv_no;
13531       Safefree(inspec);
13532       Safefree(outspec);
13533       XSRETURN(1);
13534     }
13535     outp = outspec;
13536   }
13537   else {
13538     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
13539       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13540       ST(0) = &PL_sv_no;
13541       Safefree(inspec);
13542       Safefree(outspec);
13543       XSRETURN(1);
13544     }
13545   }
13546   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
13547
13548   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
13549   Safefree(inspec);
13550   Safefree(outspec);
13551   XSRETURN(1);
13552 }
13553
13554 /* The mod2fname is limited to shorter filenames by design, so it should
13555  * not be modified to support longer EFS pathnames
13556  */
13557 void
13558 mod2fname(pTHX_ CV *cv)
13559 {
13560   dXSARGS;
13561   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13562        workbuff[NAM$C_MAXRSS*1 + 1];
13563   int total_namelen = 3, counter, num_entries;
13564   /* ODS-5 ups this, but we want to be consistent, so... */
13565   int max_name_len = 39;
13566   AV *in_array = (AV *)SvRV(ST(0));
13567
13568   num_entries = av_len(in_array);
13569
13570   /* All the names start with PL_. */
13571   strcpy(ultimate_name, "PL_");
13572
13573   /* Clean up our working buffer */
13574   Zero(work_name, sizeof(work_name), char);
13575
13576   /* Run through the entries and build up a working name */
13577   for(counter = 0; counter <= num_entries; counter++) {
13578     /* If it's not the first name then tack on a __ */
13579     if (counter) {
13580       strcat(work_name, "__");
13581     }
13582     strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
13583   }
13584
13585   /* Check to see if we actually have to bother...*/
13586   if (strlen(work_name) + 3 <= max_name_len) {
13587     strcat(ultimate_name, work_name);
13588   } else {
13589     /* It's too darned big, so we need to go strip. We use the same */
13590     /* algorithm as xsubpp does. First, strip out doubled __ */
13591     char *source, *dest, last;
13592     dest = workbuff;
13593     last = 0;
13594     for (source = work_name; *source; source++) {
13595       if (last == *source && last == '_') {
13596         continue;
13597       }
13598       *dest++ = *source;
13599       last = *source;
13600     }
13601     /* Go put it back */
13602     strcpy(work_name, workbuff);
13603     /* Is it still too big? */
13604     if (strlen(work_name) + 3 > max_name_len) {
13605       /* Strip duplicate letters */
13606       last = 0;
13607       dest = workbuff;
13608       for (source = work_name; *source; source++) {
13609         if (last == toupper(*source)) {
13610         continue;
13611         }
13612         *dest++ = *source;
13613         last = toupper(*source);
13614       }
13615       strcpy(work_name, workbuff);
13616     }
13617
13618     /* Is it *still* too big? */
13619     if (strlen(work_name) + 3 > max_name_len) {
13620       /* Too bad, we truncate */
13621       work_name[max_name_len - 2] = 0;
13622     }
13623     strcat(ultimate_name, work_name);
13624   }
13625
13626   /* Okay, return it */
13627   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13628   XSRETURN(1);
13629 }
13630
13631 void
13632 hushexit_fromperl(pTHX_ CV *cv)
13633 {
13634     dXSARGS;
13635
13636     if (items > 0) {
13637         VMSISH_HUSHED = SvTRUE(ST(0));
13638     }
13639     ST(0) = boolSV(VMSISH_HUSHED);
13640     XSRETURN(1);
13641 }
13642
13643
13644 PerlIO *
13645 Perl_vms_start_glob
13646    (pTHX_ SV *tmpglob,
13647     IO *io)
13648 {
13649     PerlIO *fp;
13650     struct vs_str_st *rslt;
13651     char *vmsspec;
13652     char *rstr;
13653     char *begin, *cp;
13654     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13655     PerlIO *tmpfp;
13656     STRLEN i;
13657     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13658     struct dsc$descriptor_vs rsdsc;
13659     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13660     unsigned long hasver = 0, isunix = 0;
13661     unsigned long int lff_flags = 0;
13662     int rms_sts;
13663     int vms_old_glob = 1;
13664
13665     if (!SvOK(tmpglob)) {
13666         SETERRNO(ENOENT,RMS$_FNF);
13667         return NULL;
13668     }
13669
13670     vms_old_glob = !decc_filename_unix_report;
13671
13672 #ifdef VMS_LONGNAME_SUPPORT
13673     lff_flags = LIB$M_FIL_LONG_NAMES;
13674 #endif
13675     /* The Newx macro will not allow me to assign a smaller array
13676      * to the rslt pointer, so we will assign it to the begin char pointer
13677      * and then copy the value into the rslt pointer.
13678      */
13679     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13680     rslt = (struct vs_str_st *)begin;
13681     rslt->length = 0;
13682     rstr = &rslt->str[0];
13683     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13684     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13685     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13686     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13687
13688     Newx(vmsspec, VMS_MAXRSS, char);
13689
13690         /* We could find out if there's an explicit dev/dir or version
13691            by peeking into lib$find_file's internal context at
13692            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13693            but that's unsupported, so I don't want to do it now and
13694            have it bite someone in the future. */
13695         /* Fix-me: vms_split_path() is the only way to do this, the
13696            existing method will fail with many legal EFS or UNIX specifications
13697          */
13698
13699     cp = SvPV(tmpglob,i);
13700
13701     for (; i; i--) {
13702         if (cp[i] == ';') hasver = 1;
13703         if (cp[i] == '.') {
13704             if (sts) hasver = 1;
13705             else sts = 1;
13706         }
13707         if (cp[i] == '/') {
13708             hasdir = isunix = 1;
13709             break;
13710         }
13711         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13712             hasdir = 1;
13713             break;
13714         }
13715     }
13716
13717     /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13718     if ((hasdir == 0) && decc_filename_unix_report) {
13719         isunix = 1;
13720     }
13721
13722     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13723         char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13724         int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13725         int wildstar = 0;
13726         int wildquery = 0;
13727         int found = 0;
13728         Stat_t st;
13729         int stat_sts;
13730         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13731         if (!stat_sts && S_ISDIR(st.st_mode)) {
13732             char * vms_dir;
13733             const char * fname;
13734             STRLEN fname_len;
13735
13736             /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13737             /* path delimiter of ':>]', if so, then the old behavior has */
13738             /* obviously been specificially requested */
13739
13740             fname = SvPVX_const(tmpglob);
13741             fname_len = strlen(fname);
13742             vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13743             if (vms_old_glob || (vms_dir != NULL)) {
13744                 wilddsc.dsc$a_pointer = tovmspath_utf8(
13745                                             SvPVX(tmpglob),vmsspec,NULL);
13746                 ok = (wilddsc.dsc$a_pointer != NULL);
13747                 /* maybe passed 'foo' rather than '[.foo]', thus not
13748                    detected above */
13749                 hasdir = 1;
13750             } else {
13751                 /* Operate just on the directory, the special stat/fstat for */
13752                 /* leaves the fileified  specification in the st_devnam */
13753                 /* member. */
13754                 wilddsc.dsc$a_pointer = st.st_devnam;
13755                 ok = 1;
13756             }
13757         }
13758         else {
13759             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13760             ok = (wilddsc.dsc$a_pointer != NULL);
13761         }
13762         if (ok)
13763             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13764
13765         /* If not extended character set, replace ? with % */
13766         /* With extended character set, ? is a wildcard single character */
13767         for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13768             if (*cp == '?') {
13769                 wildquery = 1;
13770                 if (!decc_efs_case_preserve)
13771                     *cp = '%';
13772             } else if (*cp == '%') {
13773                 wildquery = 1;
13774             } else if (*cp == '*') {
13775                 wildstar = 1;
13776             }
13777         }
13778
13779         if (ok) {
13780             wv_sts = vms_split_path(
13781                 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13782                 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13783                 &wvs_spec, &wvs_len);
13784         } else {
13785             wn_spec = NULL;
13786             wn_len = 0;
13787             we_spec = NULL;
13788             we_len = 0;
13789         }
13790
13791         sts = SS$_NORMAL;
13792         while (ok && $VMS_STATUS_SUCCESS(sts)) {
13793          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13794          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13795          int valid_find;
13796
13797             valid_find = 0;
13798             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13799                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
13800             if (!$VMS_STATUS_SUCCESS(sts))
13801                 break;
13802
13803             /* with varying string, 1st word of buffer contains result length */
13804             rstr[rslt->length] = '\0';
13805
13806              /* Find where all the components are */
13807              v_sts = vms_split_path
13808                        (rstr,
13809                         &v_spec,
13810                         &v_len,
13811                         &r_spec,
13812                         &r_len,
13813                         &d_spec,
13814                         &d_len,
13815                         &n_spec,
13816                         &n_len,
13817                         &e_spec,
13818                         &e_len,
13819                         &vs_spec,
13820                         &vs_len);
13821
13822             /* If no version on input, truncate the version on output */
13823             if (!hasver && (vs_len > 0)) {
13824                 *vs_spec = '\0';
13825                 vs_len = 0;
13826             }
13827
13828             if (isunix) {
13829
13830                 /* In Unix report mode, remove the ".dir;1" from the name */
13831                 /* if it is a real directory */
13832                 if (decc_filename_unix_report || decc_efs_charset) {
13833                     if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13834                         Stat_t statbuf;
13835                         int ret_sts;
13836
13837                         ret_sts = flex_lstat(rstr, &statbuf);
13838                         if ((ret_sts == 0) &&
13839                             S_ISDIR(statbuf.st_mode)) {
13840                             e_len = 0;
13841                             e_spec[0] = 0;
13842                         }
13843                     }
13844                 }
13845
13846                 /* No version & a null extension on UNIX handling */
13847                 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13848                     e_len = 0;
13849                     *e_spec = '\0';
13850                 }
13851             }
13852
13853             if (!decc_efs_case_preserve) {
13854                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13855             }
13856
13857             /* Find File treats a Null extension as return all extensions */
13858             /* This is contrary to Perl expectations */
13859
13860             if (wildstar || wildquery || vms_old_glob) {
13861                 /* really need to see if the returned file name matched */
13862                 /* but for now will assume that it matches */
13863                 valid_find = 1;
13864             } else {
13865                 /* Exact Match requested */
13866                 /* How are directories handled? - like a file */
13867                 if ((e_len == we_len) && (n_len == wn_len)) {
13868                     int t1;
13869                     t1 = e_len;
13870                     if (t1 > 0)
13871                         t1 = strncmp(e_spec, we_spec, e_len);
13872                     if (t1 == 0) {
13873                        t1 = n_len;
13874                        if (t1 > 0)
13875                            t1 = strncmp(n_spec, we_spec, n_len);
13876                        if (t1 == 0)
13877                            valid_find = 1;
13878                     }
13879                 }
13880             }
13881
13882             if (valid_find) {
13883                 found++;
13884
13885                 if (hasdir) {
13886                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13887                     begin = rstr;
13888                 }
13889                 else {
13890                     /* Start with the name */
13891                     begin = n_spec;
13892                 }
13893                 strcat(begin,"\n");
13894                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13895             }
13896         }
13897         if (cxt) (void)lib$find_file_end(&cxt);
13898
13899         if (!found) {
13900             /* Be POSIXish: return the input pattern when no matches */
13901             strcpy(rstr,SvPVX(tmpglob));
13902             strcat(rstr,"\n");
13903             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13904         }
13905
13906         if (ok && sts != RMS$_NMF &&
13907             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13908         if (!ok) {
13909             if (!(sts & 1)) {
13910                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13911             }
13912             PerlIO_close(tmpfp);
13913             fp = NULL;
13914         }
13915         else {
13916             PerlIO_rewind(tmpfp);
13917             IoTYPE(io) = IoTYPE_RDONLY;
13918             IoIFP(io) = fp = tmpfp;
13919             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
13920         }
13921     }
13922     Safefree(vmsspec);
13923     Safefree(rslt);
13924     return fp;
13925 }
13926
13927
13928 static char *
13929 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13930                    int *utf8_fl);
13931
13932 void
13933 unixrealpath_fromperl(pTHX_ CV *cv)
13934 {
13935     dXSARGS;
13936     char *fspec, *rslt_spec, *rslt;
13937     STRLEN n_a;
13938
13939     if (!items || items != 1)
13940         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13941
13942     fspec = SvPV(ST(0),n_a);
13943     if (!fspec || !*fspec) XSRETURN_UNDEF;
13944
13945     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13946     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13947
13948     ST(0) = sv_newmortal();
13949     if (rslt != NULL)
13950         sv_usepvn(ST(0),rslt,strlen(rslt));
13951     else
13952         Safefree(rslt_spec);
13953         XSRETURN(1);
13954 }
13955
13956 static char *
13957 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13958                    int *utf8_fl);
13959
13960 void
13961 vmsrealpath_fromperl(pTHX_ CV *cv)
13962 {
13963     dXSARGS;
13964     char *fspec, *rslt_spec, *rslt;
13965     STRLEN n_a;
13966
13967     if (!items || items != 1)
13968         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13969
13970     fspec = SvPV(ST(0),n_a);
13971     if (!fspec || !*fspec) XSRETURN_UNDEF;
13972
13973     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13974     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13975
13976     ST(0) = sv_newmortal();
13977     if (rslt != NULL)
13978         sv_usepvn(ST(0),rslt,strlen(rslt));
13979     else
13980         Safefree(rslt_spec);
13981         XSRETURN(1);
13982 }
13983
13984 #ifdef HAS_SYMLINK
13985 /*
13986  * A thin wrapper around decc$symlink to make sure we follow the
13987  * standard and do not create a symlink with a zero-length name.
13988  *
13989  * Also in ODS-2 mode, existing tests assume that the link target
13990  * will be converted to UNIX format.
13991  */
13992 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13993 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
13994   if (!link_name || !*link_name) {
13995     SETERRNO(ENOENT, SS$_NOSUCHFILE);
13996     return -1;
13997   }
13998
13999   if (decc_efs_charset) {
14000       return symlink(contents, link_name);
14001   } else {
14002       int sts;
14003       char * utarget;
14004
14005       /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
14006       /* because in order to work, the symlink target must be in UNIX format */
14007
14008       /* As symbolic links can hold things other than files, we will only do */
14009       /* the conversion in in ODS-2 mode */
14010
14011       Newx(utarget, VMS_MAXRSS + 1, char);
14012       if (int_tounixspec(contents, utarget, NULL) == NULL) {
14013
14014           /* This should not fail, as an untranslatable filename */
14015           /* should be passed through */
14016           utarget = (char *)contents;
14017       }
14018       sts = symlink(utarget, link_name);
14019       Safefree(utarget);
14020       return sts;
14021   }
14022
14023 }
14024 /*}}}*/
14025
14026 #endif /* HAS_SYMLINK */
14027
14028 int do_vms_case_tolerant(void);
14029
14030 void
14031 case_tolerant_process_fromperl(pTHX_ CV *cv)
14032 {
14033   dXSARGS;
14034   ST(0) = boolSV(do_vms_case_tolerant());
14035   XSRETURN(1);
14036 }
14037
14038 #ifdef USE_ITHREADS
14039
14040 void
14041 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
14042                           struct interp_intern *dst)
14043 {
14044     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
14045
14046     memcpy(dst,src,sizeof(struct interp_intern));
14047 }
14048
14049 #endif
14050
14051 void
14052 Perl_sys_intern_clear(pTHX)
14053 {
14054 }
14055
14056 void
14057 Perl_sys_intern_init(pTHX)
14058 {
14059     unsigned int ix = RAND_MAX;
14060     double x;
14061
14062     VMSISH_HUSHED = 0;
14063
14064     MY_POSIX_EXIT = vms_posix_exit;
14065
14066     x = (float)ix;
14067     MY_INV_RAND_MAX = 1./x;
14068 }
14069
14070 void
14071 init_os_extras(void)
14072 {
14073   dTHX;
14074   char* file = __FILE__;
14075   if (decc_disable_to_vms_logname_translation) {
14076     no_translate_barewords = TRUE;
14077   } else {
14078     no_translate_barewords = FALSE;
14079   }
14080
14081   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
14082   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
14083   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
14084   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
14085   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
14086   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
14087   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
14088   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
14089   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
14090   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
14091   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
14092   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
14093   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
14094   newXSproto("VMS::Filespec::case_tolerant_process",
14095       case_tolerant_process_fromperl,file,"");
14096
14097   store_pipelocs(aTHX);         /* will redo any earlier attempts */
14098
14099   return;
14100 }
14101
14102 #if __CRTL_VER == 80200000
14103 /* This missed getting in to the DECC SDK for 8.2 */
14104 char *realpath(const char *file_name, char * resolved_name, ...);
14105 #endif
14106
14107 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
14108 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
14109  * The perl fallback routine to provide realpath() is not as efficient
14110  * on OpenVMS.
14111  */
14112
14113 /* Hack, use old stat() as fastest way of getting ino_t and device */
14114 int decc$stat(const char *name, void * statbuf);
14115 #if !defined(__VAX) && __CRTL_VER >= 80200000
14116 int decc$lstat(const char *name, void * statbuf);
14117 #else
14118 #define decc$lstat decc$stat
14119 #endif
14120
14121
14122 /* Realpath is fragile.  In 8.3 it does not work if the feature
14123  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
14124  * links are implemented in RMS, not the CRTL. It also can fail if the
14125  * user does not have read/execute access to some of the directories.
14126  * So in order for Do What I Mean mode to work, if realpath() fails,
14127  * fall back to looking up the filename by the device name and FID.
14128  */
14129
14130 int vms_fid_to_name(char * outname, int outlen,
14131                     const char * name, int lstat_flag, mode_t * mode)
14132 {
14133 #pragma message save
14134 #pragma message disable MISALGNDSTRCT
14135 #pragma message disable MISALGNDMEM
14136 #pragma member_alignment save
14137 #pragma nomember_alignment
14138 struct statbuf_t {
14139     char           * st_dev;
14140     unsigned short st_ino[3];
14141     unsigned short old_st_mode;
14142     unsigned long  padl[30];  /* plenty of room */
14143 } statbuf;
14144 #pragma message restore
14145 #pragma member_alignment restore
14146
14147     int sts;
14148     struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14149     struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14150     char *fileified;
14151     char *temp_fspec;
14152     char *ret_spec;
14153
14154     /* Need to follow the mostly the same rules as flex_stat_int, or we may get
14155      * unexpected answers
14156      */
14157
14158     fileified = PerlMem_malloc(VMS_MAXRSS);
14159     if (fileified == NULL)
14160         _ckvmssts_noperl(SS$_INSFMEM);
14161
14162     temp_fspec = PerlMem_malloc(VMS_MAXRSS);
14163     if (temp_fspec == NULL)
14164         _ckvmssts_noperl(SS$_INSFMEM);
14165
14166     sts = -1;
14167     /* First need to try as a directory */
14168     ret_spec = int_tovmspath(name, temp_fspec, NULL);
14169     if (ret_spec != NULL) {
14170         ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
14171         if (ret_spec != NULL) {
14172             if (lstat_flag == 0)
14173                 sts = decc$stat(fileified, &statbuf);
14174             else
14175                 sts = decc$lstat(fileified, &statbuf);
14176         }
14177     }
14178
14179     /* Then as a VMS file spec */
14180     if (sts != 0) {
14181         ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
14182         if (ret_spec != NULL) {
14183             if (lstat_flag == 0) {
14184                 sts = decc$stat(temp_fspec, &statbuf);
14185             } else {
14186                 sts = decc$lstat(temp_fspec, &statbuf);
14187             }
14188         }
14189     }
14190
14191     if (sts) {
14192         /* Next try - allow multiple dots with out EFS CHARSET */
14193         /* The CRTL stat() falls down hard on multi-dot filenames in unix
14194          * format unless * DECC$EFS_CHARSET is in effect, so temporarily
14195          * enable it if it isn't already.
14196          */
14197 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14198         if (!decc_efs_charset && (decc_efs_charset_index > 0))
14199             decc$feature_set_value(decc_efs_charset_index, 1, 1);
14200 #endif
14201         ret_spec = int_tovmspath(name, temp_fspec, NULL);
14202         if (lstat_flag == 0) {
14203             sts = decc$stat(name, &statbuf);
14204         } else {
14205             sts = decc$lstat(name, &statbuf);
14206         }
14207 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14208         if (!decc_efs_charset && (decc_efs_charset_index > 0))
14209             decc$feature_set_value(decc_efs_charset_index, 1, 0);
14210 #endif
14211     }
14212
14213
14214     /* and then because the Perl Unix to VMS conversion is not perfect */
14215     /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
14216     /* characters from filenames so we need to try it as-is */
14217     if (sts) {
14218         if (lstat_flag == 0) {
14219             sts = decc$stat(name, &statbuf);
14220         } else {
14221             sts = decc$lstat(name, &statbuf);
14222         }
14223     }
14224
14225     if (sts == 0) {
14226         int vms_sts;
14227
14228         dvidsc.dsc$a_pointer=statbuf.st_dev;
14229         dvidsc.dsc$w_length=strlen(statbuf.st_dev);
14230
14231         specdsc.dsc$a_pointer = outname;
14232         specdsc.dsc$w_length = outlen-1;
14233
14234         vms_sts = lib$fid_to_name
14235             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
14236         if ($VMS_STATUS_SUCCESS(vms_sts)) {
14237             outname[specdsc.dsc$w_length] = 0;
14238
14239             /* Return the mode */
14240             if (mode) {
14241                 *mode = statbuf.old_st_mode;
14242             }
14243             return 0;
14244         }
14245     }
14246     return sts;
14247 }
14248
14249
14250
14251 static char *
14252 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
14253                    int *utf8_fl)
14254 {
14255     char * rslt = NULL;
14256
14257 #ifdef HAS_SYMLINK
14258     if (decc_posix_compliant_pathnames > 0 ) {
14259         /* realpath currently only works if posix compliant pathnames are
14260          * enabled.  It may start working when they are not, but in that
14261          * case we still want the fallback behavior for backwards compatibility
14262          */
14263         rslt = realpath(filespec, outbuf);
14264     }
14265 #endif
14266
14267     if (rslt == NULL) {
14268         char * vms_spec;
14269         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14270         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14271         int file_len;
14272         mode_t my_mode;
14273
14274         /* Fall back to fid_to_name */
14275
14276         Newx(vms_spec, VMS_MAXRSS + 1, char);
14277
14278         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
14279         if (sts == 0) {
14280
14281
14282             /* Now need to trim the version off */
14283             sts = vms_split_path
14284                   (vms_spec,
14285                    &v_spec,
14286                    &v_len,
14287                    &r_spec,
14288                    &r_len,
14289                    &d_spec,
14290                    &d_len,
14291                    &n_spec,
14292                    &n_len,
14293                    &e_spec,
14294                    &e_len,
14295                    &vs_spec,
14296                    &vs_len);
14297
14298
14299                 if (sts == 0) {
14300                     int haslower = 0;
14301                     const char *cp;
14302
14303                     /* Trim off the version */
14304                     int file_len = v_len + r_len + d_len + n_len + e_len;
14305                     vms_spec[file_len] = 0;
14306
14307                     /* The result is expected to be in UNIX format */
14308                     rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
14309
14310                     /* Downcase if input had any lower case letters and
14311                      * case preservation is not in effect.
14312                      */
14313                     if (!decc_efs_case_preserve) {
14314                         for (cp = filespec; *cp; cp++)
14315                             if (islower(*cp)) { haslower = 1; break; }
14316
14317                         if (haslower) __mystrtolower(rslt);
14318                     }
14319                 }
14320         } else {
14321
14322             /* Now for some hacks to deal with backwards and forward */
14323             /* compatibilty */
14324             if (!decc_efs_charset) {
14325
14326                 /* 1. ODS-2 mode wants to do a syntax only translation */
14327                 rslt = int_rmsexpand(filespec, outbuf,
14328                                     NULL, 0, NULL, utf8_fl);
14329
14330             } else {
14331                 if (decc_filename_unix_report) {
14332                     char * dir_name;
14333                     char * vms_dir_name;
14334                     char * file_name;
14335
14336                     /* 2. ODS-5 / UNIX report mode should return a failure */
14337                     /*    if the parent directory also does not exist */
14338                     /*    Otherwise, get the real path for the parent */
14339                     /*    and add the child to it.
14340
14341                     /* basename / dirname only available for VMS 7.0+ */
14342                     /* So we may need to implement them as common routines */
14343
14344                     Newx(dir_name, VMS_MAXRSS + 1, char);
14345                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
14346                     dir_name[0] = '\0';
14347                     file_name = NULL;
14348
14349                     /* First try a VMS parse */
14350                     sts = vms_split_path
14351                           (filespec,
14352                            &v_spec,
14353                            &v_len,
14354                            &r_spec,
14355                            &r_len,
14356                            &d_spec,
14357                            &d_len,
14358                            &n_spec,
14359                            &n_len,
14360                            &e_spec,
14361                            &e_len,
14362                            &vs_spec,
14363                            &vs_len);
14364
14365                     if (sts == 0) {
14366                         /* This is VMS */
14367
14368                         int dir_len = v_len + r_len + d_len + n_len;
14369                         if (dir_len > 0) {
14370                            strncpy(dir_name, filespec, dir_len);
14371                            dir_name[dir_len] = '\0';
14372                            file_name = (char *)&filespec[dir_len + 1];
14373                         }
14374                     } else {
14375                         /* This must be UNIX */
14376                         char * tchar;
14377
14378                         tchar = strrchr(filespec, '/');
14379
14380                         if (tchar != NULL) {
14381                             int dir_len = tchar - filespec;
14382                             strncpy(dir_name, filespec, dir_len);
14383                             dir_name[dir_len] = '\0';
14384                             file_name = (char *) &filespec[dir_len + 1];
14385                         }
14386                     }
14387
14388                     /* Dir name is defaulted */
14389                     if (dir_name[0] == 0) {
14390                         dir_name[0] = '.';
14391                         dir_name[1] = '\0';
14392                     }
14393
14394                     /* Need realpath for the directory */
14395                     sts = vms_fid_to_name(vms_dir_name,
14396                                           VMS_MAXRSS + 1,
14397                                           dir_name, 0, NULL);
14398
14399                     if (sts == 0) {
14400                         /* Now need to pathify it.
14401                         char *tdir = int_pathify_dirspec(vms_dir_name,
14402                                                          outbuf);
14403
14404                         /* And now add the original filespec to it */
14405                         if (file_name != NULL) {
14406                             strcat(outbuf, file_name);
14407                         }
14408                         return outbuf;
14409                     }
14410                     Safefree(vms_dir_name);
14411                     Safefree(dir_name);
14412                 }
14413             }
14414         }
14415         Safefree(vms_spec);
14416     }
14417     return rslt;
14418 }
14419
14420 static char *
14421 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
14422                    int *utf8_fl)
14423 {
14424     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14425     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14426     int file_len;
14427
14428     /* Fall back to fid_to_name */
14429
14430     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
14431     if (sts != 0) {
14432         return NULL;
14433     }
14434     else {
14435
14436
14437         /* Now need to trim the version off */
14438         sts = vms_split_path
14439                   (outbuf,
14440                    &v_spec,
14441                    &v_len,
14442                    &r_spec,
14443                    &r_len,
14444                    &d_spec,
14445                    &d_len,
14446                    &n_spec,
14447                    &n_len,
14448                    &e_spec,
14449                    &e_len,
14450                    &vs_spec,
14451                    &vs_len);
14452
14453
14454         if (sts == 0) {
14455             int haslower = 0;
14456             const char *cp;
14457
14458             /* Trim off the version */
14459             int file_len = v_len + r_len + d_len + n_len + e_len;
14460             outbuf[file_len] = 0;
14461
14462             /* Downcase if input had any lower case letters and
14463              * case preservation is not in effect.
14464              */
14465             if (!decc_efs_case_preserve) {
14466                 for (cp = filespec; *cp; cp++)
14467                     if (islower(*cp)) { haslower = 1; break; }
14468
14469                 if (haslower) __mystrtolower(outbuf);
14470             }
14471         }
14472     }
14473     return outbuf;
14474 }
14475
14476
14477 /*}}}*/
14478 /* External entry points */
14479 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14480 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
14481
14482 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14483 { return do_vms_realname(filespec, outbuf, utf8_fl); }
14484
14485 /* case_tolerant */
14486
14487 /*{{{int do_vms_case_tolerant(void)*/
14488 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
14489  * controlled by a process setting.
14490  */
14491 int do_vms_case_tolerant(void)
14492 {
14493     return vms_process_case_tolerant;
14494 }
14495 /*}}}*/
14496 /* External entry points */
14497 #if __CRTL_VER >= 70301000 && !defined(__VAX)
14498 int Perl_vms_case_tolerant(void)
14499 { return do_vms_case_tolerant(); }
14500 #else
14501 int Perl_vms_case_tolerant(void)
14502 { return vms_process_case_tolerant; }
14503 #endif
14504
14505
14506  /* Start of DECC RTL Feature handling */
14507
14508 static int sys_trnlnm
14509    (const char * logname,
14510     char * value,
14511     int value_len)
14512 {
14513     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
14514     const unsigned long attr = LNM$M_CASE_BLIND;
14515     struct dsc$descriptor_s name_dsc;
14516     int status;
14517     unsigned short result;
14518     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
14519                                 {0, 0, 0, 0}};
14520
14521     name_dsc.dsc$w_length = strlen(logname);
14522     name_dsc.dsc$a_pointer = (char *)logname;
14523     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14524     name_dsc.dsc$b_class = DSC$K_CLASS_S;
14525
14526     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
14527
14528     if ($VMS_STATUS_SUCCESS(status)) {
14529
14530          /* Null terminate and return the string */
14531         /*--------------------------------------*/
14532         value[result] = 0;
14533     }
14534
14535     return status;
14536 }
14537
14538 static int sys_crelnm
14539    (const char * logname,
14540     const char * value)
14541 {
14542     int ret_val;
14543     const char * proc_table = "LNM$PROCESS_TABLE";
14544     struct dsc$descriptor_s proc_table_dsc;
14545     struct dsc$descriptor_s logname_dsc;
14546     struct itmlst_3 item_list[2];
14547
14548     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
14549     proc_table_dsc.dsc$w_length = strlen(proc_table);
14550     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14551     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
14552
14553     logname_dsc.dsc$a_pointer = (char *) logname;
14554     logname_dsc.dsc$w_length = strlen(logname);
14555     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14556     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
14557
14558     item_list[0].buflen = strlen(value);
14559     item_list[0].itmcode = LNM$_STRING;
14560     item_list[0].bufadr = (char *)value;
14561     item_list[0].retlen = NULL;
14562
14563     item_list[1].buflen = 0;
14564     item_list[1].itmcode = 0;
14565
14566     ret_val = sys$crelnm
14567                        (NULL,
14568                         (const struct dsc$descriptor_s *)&proc_table_dsc,
14569                         (const struct dsc$descriptor_s *)&logname_dsc,
14570                         NULL,
14571                         (const struct item_list_3 *) item_list);
14572
14573     return ret_val;
14574 }
14575
14576 /* C RTL Feature settings */
14577
14578 static int set_features
14579    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
14580     int (* cli_routine)(void),  /* Not documented */
14581     void *image_info)           /* Not documented */
14582 {
14583     int status;
14584     int s;
14585     char* str;
14586     char val_str[10];
14587 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
14588     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
14589     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
14590     unsigned long case_perm;
14591     unsigned long case_image;
14592 #endif
14593
14594     /* Allow an exception to bring Perl into the VMS debugger */
14595     vms_debug_on_exception = 0;
14596     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
14597     if ($VMS_STATUS_SUCCESS(status)) {
14598        val_str[0] = _toupper(val_str[0]);
14599        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14600          vms_debug_on_exception = 1;
14601        else
14602          vms_debug_on_exception = 0;
14603     }
14604
14605     /* Debug unix/vms file translation routines */
14606     vms_debug_fileify = 0;
14607     status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14608     if ($VMS_STATUS_SUCCESS(status)) {
14609         val_str[0] = _toupper(val_str[0]);
14610         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14611             vms_debug_fileify = 1;
14612         else
14613             vms_debug_fileify = 0;
14614     }
14615
14616
14617     /* Historically PERL has been doing vmsify / stat differently than */
14618     /* the CRTL.  In particular, under some conditions the CRTL will   */
14619     /* remove some illegal characters like spaces from filenames       */
14620     /* resulting in some differences.  The stat()/lstat() wrapper has  */
14621     /* been reporting such file names as invalid and fails to stat them */
14622     /* fixing this bug so that stat()/lstat() accept these like the     */
14623     /* CRTL does will result in several tests failing.                  */
14624     /* This should really be fixed, but for now, set up a feature to    */
14625     /* enable it so that the impact can be studied.                     */
14626     vms_bug_stat_filename = 0;
14627     status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14628     if ($VMS_STATUS_SUCCESS(status)) {
14629         val_str[0] = _toupper(val_str[0]);
14630         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14631             vms_bug_stat_filename = 1;
14632         else
14633             vms_bug_stat_filename = 0;
14634     }
14635
14636
14637     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14638     vms_vtf7_filenames = 0;
14639     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14640     if ($VMS_STATUS_SUCCESS(status)) {
14641        val_str[0] = _toupper(val_str[0]);
14642        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14643          vms_vtf7_filenames = 1;
14644        else
14645          vms_vtf7_filenames = 0;
14646     }
14647
14648     /* unlink all versions on unlink() or rename() */
14649     vms_unlink_all_versions = 0;
14650     status = sys_trnlnm
14651         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14652     if ($VMS_STATUS_SUCCESS(status)) {
14653        val_str[0] = _toupper(val_str[0]);
14654        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14655          vms_unlink_all_versions = 1;
14656        else
14657          vms_unlink_all_versions = 0;
14658     }
14659
14660     /* Dectect running under GNV Bash or other UNIX like shell */
14661 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14662     gnv_unix_shell = 0;
14663     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14664     if ($VMS_STATUS_SUCCESS(status)) {
14665          gnv_unix_shell = 1;
14666          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14667          set_feature_default("DECC$EFS_CHARSET", 1);
14668          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14669          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14670          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14671          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14672          vms_unlink_all_versions = 1;
14673          vms_posix_exit = 1;
14674     }
14675 #endif
14676
14677     /* hacks to see if known bugs are still present for testing */
14678
14679     /* PCP mode requires creating /dev/null special device file */
14680     decc_bug_devnull = 0;
14681     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14682     if ($VMS_STATUS_SUCCESS(status)) {
14683        val_str[0] = _toupper(val_str[0]);
14684        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14685           decc_bug_devnull = 1;
14686        else
14687           decc_bug_devnull = 0;
14688     }
14689
14690     /* UNIX directory names with no paths are broken in a lot of places */
14691     decc_dir_barename = 1;
14692     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14693     if ($VMS_STATUS_SUCCESS(status)) {
14694       val_str[0] = _toupper(val_str[0]);
14695       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14696         decc_dir_barename = 1;
14697       else
14698         decc_dir_barename = 0;
14699     }
14700
14701 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14702     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14703     if (s >= 0) {
14704         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14705         if (decc_disable_to_vms_logname_translation < 0)
14706             decc_disable_to_vms_logname_translation = 0;
14707     }
14708
14709     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14710     if (s >= 0) {
14711         decc_efs_case_preserve = decc$feature_get_value(s, 1);
14712         if (decc_efs_case_preserve < 0)
14713             decc_efs_case_preserve = 0;
14714     }
14715
14716     s = decc$feature_get_index("DECC$EFS_CHARSET");
14717     decc_efs_charset_index = s;
14718     if (s >= 0) {
14719         decc_efs_charset = decc$feature_get_value(s, 1);
14720         if (decc_efs_charset < 0)
14721             decc_efs_charset = 0;
14722     }
14723
14724     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14725     if (s >= 0) {
14726         decc_filename_unix_report = decc$feature_get_value(s, 1);
14727         if (decc_filename_unix_report > 0) {
14728             decc_filename_unix_report = 1;
14729             vms_posix_exit = 1;
14730         }
14731         else
14732             decc_filename_unix_report = 0;
14733     }
14734
14735     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14736     if (s >= 0) {
14737         decc_filename_unix_only = decc$feature_get_value(s, 1);
14738         if (decc_filename_unix_only > 0) {
14739             decc_filename_unix_only = 1;
14740         }
14741         else {
14742             decc_filename_unix_only = 0;
14743         }
14744     }
14745
14746     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14747     if (s >= 0) {
14748         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14749         if (decc_filename_unix_no_version < 0)
14750             decc_filename_unix_no_version = 0;
14751     }
14752
14753     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14754     if (s >= 0) {
14755         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14756         if (decc_readdir_dropdotnotype < 0)
14757             decc_readdir_dropdotnotype = 0;
14758     }
14759
14760 #if __CRTL_VER >= 80200000
14761     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14762     if (s >= 0) {
14763         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14764         if (decc_posix_compliant_pathnames < 0)
14765             decc_posix_compliant_pathnames = 0;
14766         if (decc_posix_compliant_pathnames > 4)
14767             decc_posix_compliant_pathnames = 0;
14768     }
14769
14770 #endif
14771 #else
14772     status = sys_trnlnm
14773         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", 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            decc_disable_to_vms_logname_translation = 1;
14778         }
14779     }
14780
14781 #ifndef __VAX
14782     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14783     if ($VMS_STATUS_SUCCESS(status)) {
14784         val_str[0] = _toupper(val_str[0]);
14785         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14786            decc_efs_case_preserve = 1;
14787         }
14788     }
14789 #endif
14790
14791     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14792     if ($VMS_STATUS_SUCCESS(status)) {
14793         val_str[0] = _toupper(val_str[0]);
14794         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14795            decc_filename_unix_report = 1;
14796         }
14797     }
14798     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14799     if ($VMS_STATUS_SUCCESS(status)) {
14800         val_str[0] = _toupper(val_str[0]);
14801         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14802            decc_filename_unix_only = 1;
14803            decc_filename_unix_report = 1;
14804         }
14805     }
14806     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14807     if ($VMS_STATUS_SUCCESS(status)) {
14808         val_str[0] = _toupper(val_str[0]);
14809         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14810            decc_filename_unix_no_version = 1;
14811         }
14812     }
14813     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14814     if ($VMS_STATUS_SUCCESS(status)) {
14815         val_str[0] = _toupper(val_str[0]);
14816         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14817            decc_readdir_dropdotnotype = 1;
14818         }
14819     }
14820 #endif
14821
14822 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14823
14824      /* Report true case tolerance */
14825     /*----------------------------*/
14826     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14827     if (!$VMS_STATUS_SUCCESS(status))
14828         case_perm = PPROP$K_CASE_BLIND;
14829     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14830     if (!$VMS_STATUS_SUCCESS(status))
14831         case_image = PPROP$K_CASE_BLIND;
14832     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14833         (case_image == PPROP$K_CASE_SENSITIVE))
14834         vms_process_case_tolerant = 0;
14835
14836 #endif
14837
14838     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
14839     /* for strict backward compatibilty */
14840     status = sys_trnlnm
14841         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14842     if ($VMS_STATUS_SUCCESS(status)) {
14843        val_str[0] = _toupper(val_str[0]);
14844        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14845          vms_posix_exit = 1;
14846        else
14847          vms_posix_exit = 0;
14848     }
14849
14850
14851     /* CRTL can be initialized past this point, but not before. */
14852 /*    DECC$CRTL_INIT(); */
14853
14854     return SS$_NORMAL;
14855 }
14856
14857 #ifdef __DECC
14858 #pragma nostandard
14859 #pragma extern_model save
14860 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14861         const __align (LONGWORD) int spare[8] = {0};
14862
14863 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14864 #if __DECC_VER >= 60560002
14865 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14866 #else
14867 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14868 #endif
14869 #endif /* __DECC */
14870
14871 const long vms_cc_features = (const long)set_features;
14872
14873 /*
14874 ** Force a reference to LIB$INITIALIZE to ensure it
14875 ** exists in the image.
14876 */
14877 int lib$initialize(void);
14878 #ifdef __DECC
14879 #pragma extern_model strict_refdef
14880 #endif
14881     int lib_init_ref = (int) lib$initialize;
14882
14883 #ifdef __DECC
14884 #pragma extern_model restore
14885 #pragma standard
14886 #endif
14887
14888 /*  End of vms.c */