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 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 300 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 301
 302 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 303  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 304  * the Perl facility.
 305  */
 306 #define PERL_LNM_MAX_ITER 10
 307
 308   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 309 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 310 #define MAX_DCL_SYMBOL          (8192)
 311 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 312 #else
 313 #define MAX_DCL_SYMBOL          (1024)
 314 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 315 #endif
 316
 317 static char *__mystrtolower(char *str)
 318 {
 319   if (str) for (; *str; ++str) *str= tolower(*str);
 320   return str;
 321 }
 322
 323 static struct dsc$descriptor_s fildevdsc =
 324   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 325 static struct dsc$descriptor_s crtlenvdsc =
 326   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 327 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 328 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 329 static struct dsc$descriptor_s **env_tables = defenv;
 330 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 331
 332 /* True if we shouldn't treat barewords as logicals during directory */
 333 /* munching */
 334 static int no_translate_barewords;
 335
 336 #ifndef RTL_USES_UTC
 337 static int tz_updated = 1;
 338 #endif
 339
 340 /* DECC Features that may need to affect how Perl interprets
 341  * displays filename information
 342  */
 343 static int decc_disable_to_vms_logname_translation = 1;
 344 static int decc_disable_posix_root = 1;
 345 int decc_efs_case_preserve = 0;
 346 static int decc_efs_charset = 0;
 347 static int decc_filename_unix_no_version = 0;
 348 static int decc_filename_unix_only = 0;
 349 int decc_filename_unix_report = 0;
 350 int decc_posix_compliant_pathnames = 0;
 351 int decc_readdir_dropdotnotype = 0;
 352 static int vms_process_case_tolerant = 1;
 353 int vms_vtf7_filenames = 0;
 354 int gnv_unix_shell = 0;
 355 static int vms_unlink_all_versions = 0;
 356 static int vms_posix_exit = 0;
 357
 358 /* bug workarounds if needed */
 359 int decc_bug_readdir_efs1 = 0;
 360 int decc_bug_devnull = 1;
 361 int decc_bug_fgetname = 0;
 362 int decc_dir_barename = 0;
 363
 364 static int vms_debug_on_exception = 0;
 365
 366 /* Is this a UNIX file specification?
 367  *   No longer a simple check with EFS file specs
 368  *   For now, not a full check, but need to
 369  *   handle POSIX ^UP^ specifications
 370  *   Fixing to handle ^/ cases would require
 371  *   changes to many other conversion routines.
 372  */
 373
 374 static int is_unix_filespec(const char *path)
 375 {
 376 int ret_val;
 377 const char * pch1;
 378
 379     ret_val = 0;
 380     if (strncmp(path,"\"^UP^",5) != 0) {
 381         pch1 = strchr(path, '/');
 382         if (pch1 != NULL)
 383             ret_val = 1;
 384         else {
 385
 386             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 387             if (decc_filename_unix_report || decc_filename_unix_only) {
 388             if (strcmp(path,".") == 0)
 389                 ret_val = 1;
 390             }
 391         }
 392     }
 393     return ret_val;
 394 }
 395
 396 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 397  */
 398
 399 static void ucs2_to_vtf7
 400    (char *outspec,
 401     unsigned long ucs2_char,
 402     int * output_cnt)
 403 {
 404 unsigned char * ucs_ptr;
 405 int hex;
 406
 407     ucs_ptr = (unsigned char *)&ucs2_char;
 408
 409     outspec[0] = '^';
 410     outspec[1] = 'U';
 411     hex = (ucs_ptr[1] >> 4) & 0xf;
 412     if (hex < 0xA)
 413         outspec[2] = hex + '0';
 414     else
 415         outspec[2] = (hex - 9) + 'A';
 416     hex = ucs_ptr[1] & 0xF;
 417     if (hex < 0xA)
 418         outspec[3] = hex + '0';
 419     else {
 420         outspec[3] = (hex - 9) + 'A';
 421     }
 422     hex = (ucs_ptr[0] >> 4) & 0xf;
 423     if (hex < 0xA)
 424         outspec[4] = hex + '0';
 425     else
 426         outspec[4] = (hex - 9) + 'A';
 427     hex = ucs_ptr[1] & 0xF;
 428     if (hex < 0xA)
 429         outspec[5] = hex + '0';
 430     else {
 431         outspec[5] = (hex - 9) + 'A';
 432     }
 433     *output_cnt = 6;
 434 }
 435
 436
 437 /* This handles the conversion of a UNIX extended character set to a ^
 438  * escaped VMS character.
 439  * in a UNIX file specification.
 440  *
 441  * The output count variable contains the number of characters added
 442  * to the output string.
 443  *
 444  * The return value is the number of characters read from the input string
 445  */
 446 static int copy_expand_unix_filename_escape
 447   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 448 {
 449 int count;
 450 int scnt;
 451 int utf8_flag;
 452
 453     utf8_flag = 0;
 454     if (utf8_fl)
 455       utf8_flag = *utf8_fl;
 456
 457     count = 0;
 458     *output_cnt = 0;
 459     if (*inspec >= 0x80) {
 460         if (utf8_fl && vms_vtf7_filenames) {
 461         unsigned long ucs_char;
 462
 463             ucs_char = 0;
 464
 465             if ((*inspec & 0xE0) == 0xC0) {
 466                 /* 2 byte Unicode */
 467                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 468                 if (ucs_char >= 0x80) {
 469                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 470                     return 2;
 471                 }
 472             } else if ((*inspec & 0xF0) == 0xE0) {
 473                 /* 3 byte Unicode */
 474                 ucs_char = ((inspec[0] & 0xF) << 12) +
 475                    ((inspec[1] & 0x3f) << 6) +
 476                    (inspec[2] & 0x3f);
 477                 if (ucs_char >= 0x800) {
 478                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 479                     return 3;
 480                 }
 481
 482 #if 0 /* I do not see longer sequences supported by OpenVMS */
 483       /* Maybe some one can fix this later */
 484             } else if ((*inspec & 0xF8) == 0xF0) {
 485                 /* 4 byte Unicode */
 486                 /* UCS-4 to UCS-2 */
 487             } else if ((*inspec & 0xFC) == 0xF8) {
 488                 /* 5 byte Unicode */
 489                 /* UCS-4 to UCS-2 */
 490             } else if ((*inspec & 0xFE) == 0xFC) {
 491                 /* 6 byte Unicode */
 492                 /* UCS-4 to UCS-2 */
 493 #endif
 494             }
 495         }
 496
 497         /* High bit set, but not a Unicode character! */
 498
 499         /* Non printing DECMCS or ISO Latin-1 character? */
 500         if (*inspec <= 0x9F) {
 501         int hex;
 502             outspec[0] = '^';
 503             outspec++;
 504             hex = (*inspec >> 4) & 0xF;
 505             if (hex < 0xA)
 506                 outspec[1] = hex + '0';
 507             else {
 508                 outspec[1] = (hex - 9) + 'A';
 509             }
 510             hex = *inspec & 0xF;
 511             if (hex < 0xA)
 512                 outspec[2] = hex + '0';
 513             else {
 514                 outspec[2] = (hex - 9) + 'A';
 515             }
 516             *output_cnt = 3;
 517             return 1;
 518         } else if (*inspec == 0xA0) {
 519             outspec[0] = '^';
 520             outspec[1] = 'A';
 521             outspec[2] = '0';
 522             *output_cnt = 3;
 523             return 1;
 524         } else if (*inspec == 0xFF) {
 525             outspec[0] = '^';
 526             outspec[1] = 'F';
 527             outspec[2] = 'F';
 528             *output_cnt = 3;
 529             return 1;
 530         }
 531         *outspec = *inspec;
 532         *output_cnt = 1;
 533         return 1;
 534     }
 535
 536     /* Is this a macro that needs to be passed through?
 537      * Macros start with $( and an alpha character, followed
 538      * by a string of alpha numeric characters ending with a )
 539      * If this does not match, then encode it as ODS-5.
 540      */
 541     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 542     int tcnt;
 543
 544         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 545             tcnt = 3;
 546             outspec[0] = inspec[0];
 547             outspec[1] = inspec[1];
 548             outspec[2] = inspec[2];
 549
 550             while(isalnum(inspec[tcnt]) ||
 551                   (inspec[2] == '.') || (inspec[2] == '_')) {
 552                 outspec[tcnt] = inspec[tcnt];
 553                 tcnt++;
 554             }
 555             if (inspec[tcnt] == ')') {
 556                 outspec[tcnt] = inspec[tcnt];
 557                 tcnt++;
 558                 *output_cnt = tcnt;
 559                 return tcnt;
 560             }
 561         }
 562     }
 563
 564     switch (*inspec) {
 565     case 0x7f:
 566         outspec[0] = '^';
 567         outspec[1] = '7';
 568         outspec[2] = 'F';
 569         *output_cnt = 3;
 570         return 1;
 571         break;
 572     case '?':
 573         if (decc_efs_charset == 0)
 574           outspec[0] = '%';
 575         else
 576           outspec[0] = '?';
 577         *output_cnt = 1;
 578         return 1;
 579         break;
 580     case '.':
 581     case '~':
 582     case '!':
 583     case '#':
 584     case '&':
 585     case '\'':
 586     case '`':
 587     case '(':
 588     case ')':
 589     case '+':
 590     case '@':
 591     case '{':
 592     case '}':
 593     case ',':
 594     case ';':
 595     case '[':
 596     case ']':
 597     case '%':
 598     case '^':
 599         /* Don't escape again if following character is
 600          * already something we escape.
 601          */
 602         if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
 603             *outspec = *inspec;
 604             *output_cnt = 1;
 605             return 1;
 606             break;
 607         }
 608         /* But otherwise fall through and escape it. */
 609     case '=':
 610         /* Assume that this is to be escaped */
 611         outspec[0] = '^';
 612         outspec[1] = *inspec;
 613         *output_cnt = 2;
 614         return 1;
 615         break;
 616     case ' ': /* space */
 617         /* Assume that this is to be escaped */
 618         outspec[0] = '^';
 619         outspec[1] = '_';
 620         *output_cnt = 2;
 621         return 1;
 622         break;
 623     default:
 624         *outspec = *inspec;
 625         *output_cnt = 1;
 626         return 1;
 627         break;
 628     }
 629 }
 630
 631
 632 /* This handles the expansion of a '^' prefix to the proper character
 633  * in a UNIX file specification.
 634  *
 635  * The output count variable contains the number of characters added
 636  * to the output string.
 637  *
 638  * The return value is the number of characters read from the input
 639  * string
 640  */
 641 static int copy_expand_vms_filename_escape
 642   (char *outspec, const char *inspec, int *output_cnt)
 643 {
 644 int count;
 645 int scnt;
 646
 647     count = 0;
 648     *output_cnt = 0;
 649     if (*inspec == '^') {
 650         inspec++;
 651         switch (*inspec) {
 652         /* Spaces and non-trailing dots should just be passed through,
 653          * but eat the escape character.
 654          */
 655         case '.':
 656             *outspec = *inspec;
 657             count += 2;
 658             (*output_cnt)++;
 659             break;
 660         case '_': /* space */
 661             *outspec = ' ';
 662             count += 2;
 663             (*output_cnt)++;
 664             break;
 665         case '^':
 666             /* Hmm.  Better leave the escape escaped. */
 667             outspec[0] = '^';
 668             outspec[1] = '^';
 669             count += 2;
 670             (*output_cnt) += 2;
 671             break;
 672         case 'U': /* Unicode - FIX-ME this is wrong. */
 673             inspec++;
 674             count++;
 675             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 676             if (scnt == 4) {
 677                 unsigned int c1, c2;
 678                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 679                 outspec[0] == c1 & 0xff;
 680                 outspec[1] == c2 & 0xff;
 681                 if (scnt > 1) {
 682                     (*output_cnt) += 2;
 683                     count += 4;
 684                 }
 685             }
 686             else {
 687                 /* Error - do best we can to continue */
 688                 *outspec = 'U';
 689                 outspec++;
 690                 (*output_cnt++);
 691                 *outspec = *inspec;
 692                 count++;
 693                 (*output_cnt++);
 694             }
 695             break;
 696         default:
 697             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 698             if (scnt == 2) {
 699                 /* Hex encoded */
 700                 unsigned int c1;
 701                 scnt = sscanf(inspec, "%2x", &c1);
 702                 outspec[0] = c1 & 0xff;
 703                 if (scnt > 0) {
 704                     (*output_cnt++);
 705                     count += 2;
 706                 }
 707             }
 708             else {
 709                 *outspec = *inspec;
 710                 count++;
 711                 (*output_cnt++);
 712             }
 713         }
 714     }
 715     else {
 716         *outspec = *inspec;
 717         count++;
 718         (*output_cnt)++;
 719     }
 720     return count;
 721 }
 722
 723 #ifdef sys$filescan
 724 #undef sys$filescan
 725 int sys$filescan
 726    (const struct dsc$descriptor_s * srcstr,
 727     struct filescan_itmlst_2 * valuelist,
 728     unsigned long * fldflags,
 729     struct dsc$descriptor_s *auxout,
 730     unsigned short * retlen);
 731 #endif
 732
 733 /* vms_split_path - Verify that the input file specification is a
 734  * VMS format file specification, and provide pointers to the components of
 735  * it.  With EFS format filenames, this is virtually the only way to
 736  * parse a VMS path specification into components.
 737  *
 738  * If the sum of the components do not add up to the length of the
 739  * string, then the passed file specification is probably a UNIX style
 740  * path.
 741  */
 742 static int vms_split_path
 743    (const char * path,
 744     char * * volume,
 745     int * vol_len,
 746     char * * root,
 747     int * root_len,
 748     char * * dir,
 749     int * dir_len,
 750     char * * name,
 751     int * name_len,
 752     char * * ext,
 753     int * ext_len,
 754     char * * version,
 755     int * ver_len)
 756 {
 757 struct dsc$descriptor path_desc;
 758 int status;
 759 unsigned long flags;
 760 int ret_stat;
 761 struct filescan_itmlst_2 item_list[9];
 762 const int filespec = 0;
 763 const int nodespec = 1;
 764 const int devspec = 2;
 765 const int rootspec = 3;
 766 const int dirspec = 4;
 767 const int namespec = 5;
 768 const int typespec = 6;
 769 const int verspec = 7;
 770
 771     /* Assume the worst for an easy exit */
 772     ret_stat = -1;
 773     *volume = NULL;
 774     *vol_len = 0;
 775     *root = NULL;
 776     *root_len = 0;
 777     *dir = NULL;
 778     *dir_len;
 779     *name = NULL;
 780     *name_len = 0;
 781     *ext = NULL;
 782     *ext_len = 0;
 783     *version = NULL;
 784     *ver_len = 0;
 785
 786     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 787     path_desc.dsc$w_length = strlen(path);
 788     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 789     path_desc.dsc$b_class = DSC$K_CLASS_S;
 790
 791     /* Get the total length, if it is shorter than the string passed
 792      * then this was probably not a VMS formatted file specification
 793      */
 794     item_list[filespec].itmcode = FSCN$_FILESPEC;
 795     item_list[filespec].length = 0;
 796     item_list[filespec].component = NULL;
 797
 798     /* If the node is present, then it gets considered as part of the
 799      * volume name to hopefully make things simple.
 800      */
 801     item_list[nodespec].itmcode = FSCN$_NODE;
 802     item_list[nodespec].length = 0;
 803     item_list[nodespec].component = NULL;
 804
 805     item_list[devspec].itmcode = FSCN$_DEVICE;
 806     item_list[devspec].length = 0;
 807     item_list[devspec].component = NULL;
 808
 809     /* root is a special case,  adding it to either the directory or
 810      * the device components will probalby complicate things for the
 811      * callers of this routine, so leave it separate.
 812      */
 813     item_list[rootspec].itmcode = FSCN$_ROOT;
 814     item_list[rootspec].length = 0;
 815     item_list[rootspec].component = NULL;
 816
 817     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 818     item_list[dirspec].length = 0;
 819     item_list[dirspec].component = NULL;
 820
 821     item_list[namespec].itmcode = FSCN$_NAME;
 822     item_list[namespec].length = 0;
 823     item_list[namespec].component = NULL;
 824
 825     item_list[typespec].itmcode = FSCN$_TYPE;
 826     item_list[typespec].length = 0;
 827     item_list[typespec].component = NULL;
 828
 829     item_list[verspec].itmcode = FSCN$_VERSION;
 830     item_list[verspec].length = 0;
 831     item_list[verspec].component = NULL;
 832
 833     item_list[8].itmcode = 0;
 834     item_list[8].length = 0;
 835     item_list[8].component = NULL;
 836
 837     status = sys$filescan
 838        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 839         &flags, NULL, NULL);
 840     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 841
 842     /* If we parsed it successfully these two lengths should be the same */
 843     if (path_desc.dsc$w_length != item_list[filespec].length)
 844         return ret_stat;
 845
 846     /* If we got here, then it is a VMS file specification */
 847     ret_stat = 0;
 848
 849     /* set the volume name */
 850     if (item_list[nodespec].length > 0) {
 851         *volume = item_list[nodespec].component;
 852         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 853     }
 854     else {
 855         *volume = item_list[devspec].component;
 856         *vol_len = item_list[devspec].length;
 857     }
 858
 859     *root = item_list[rootspec].component;
 860     *root_len = item_list[rootspec].length;
 861
 862     *dir = item_list[dirspec].component;
 863     *dir_len = item_list[dirspec].length;
 864
 865     /* Now fun with versions and EFS file specifications
 866      * The parser can not tell the difference when a "." is a version
 867      * delimiter or a part of the file specification.
 868      */
 869     if ((decc_efs_charset) &&
 870         (item_list[verspec].length > 0) &&
 871         (item_list[verspec].component[0] == '.')) {
 872         *name = item_list[namespec].component;
 873         *name_len = item_list[namespec].length + item_list[typespec].length;
 874         *ext = item_list[verspec].component;
 875         *ext_len = item_list[verspec].length;
 876         *version = NULL;
 877         *ver_len = 0;
 878     }
 879     else {
 880         *name = item_list[namespec].component;
 881         *name_len = item_list[namespec].length;
 882         *ext = item_list[typespec].component;
 883         *ext_len = item_list[typespec].length;
 884         *version = item_list[verspec].component;
 885         *ver_len = item_list[verspec].length;
 886     }
 887     return ret_stat;
 888 }
 889
 890
 891 /* my_maxidx
 892  * Routine to retrieve the maximum equivalence index for an input
 893  * logical name.  Some calls to this routine have no knowledge if
 894  * the variable is a logical or not.  So on error we return a max
 895  * index of zero.
 896  */
 897 /*{{{int my_maxidx(const char *lnm) */
 898 static int
 899 my_maxidx(const char *lnm)
 900 {
 901     int status;
 902     int midx;
 903     int attr = LNM$M_CASE_BLIND;
 904     struct dsc$descriptor lnmdsc;
 905     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 906                                 {0, 0, 0, 0}};
 907
 908     lnmdsc.dsc$w_length = strlen(lnm);
 909     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 910     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 911     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 912
 913     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 914     if ((status & 1) == 0)
 915        midx = 0;
 916
 917     return (midx);
 918 }
 919 /*}}}*/
 920
 921 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 922 int
 923 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 924   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 925 {
 926     const char *cp1;
 927     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 928     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 929     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 930     int midx;
 931     unsigned char acmode;
 932     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 933                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 934     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 935                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 936                                  {0, 0, 0, 0}};
 937     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 938 #if defined(PERL_IMPLICIT_CONTEXT)
 939     pTHX = NULL;
 940     if (PL_curinterp) {
 941       aTHX = PERL_GET_INTERP;
 942     } else {
 943       aTHX = NULL;
 944     }
 945 #endif
 946
 947     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 948       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 949     }
 950     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 951       *cp2 = _toupper(*cp1);
 952       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 953         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 954         return 0;
 955       }
 956     }
 957     lnmdsc.dsc$w_length = cp1 - lnm;
 958     lnmdsc.dsc$a_pointer = uplnm;
 959     uplnm[lnmdsc.dsc$w_length] = '\0';
 960     secure = flags & PERL__TRNENV_SECURE;
 961     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 962     if (!tabvec || !*tabvec) tabvec = env_tables;
 963
 964     for (curtab = 0; tabvec[curtab]; curtab++) {
 965       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 966         if (!ivenv && !secure) {
 967           char *eq, *end;
 968           int i;
 969           if (!environ) {
 970             ivenv = 1;
 971             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 972             continue;
 973           }
 974           retsts = SS$_NOLOGNAM;
 975           for (i = 0; environ[i]; i++) {
 976             if ((eq = strchr(environ[i],'=')) &&
 977                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 978                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 979               eq++;
 980               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 981               if (!eqvlen) continue;
 982               retsts = SS$_NORMAL;
 983               break;
 984             }
 985           }
 986           if (retsts != SS$_NOLOGNAM) break;
 987         }
 988       }
 989       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 990                !str$case_blind_compare(&tmpdsc,&clisym)) {
 991         if (!ivsym && !secure) {
 992           unsigned short int deflen = LNM$C_NAMLENGTH;
 993           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 994           /* dynamic dsc to accomodate possible long value */
 995           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 996           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 997           if (retsts & 1) {
 998             if (eqvlen > MAX_DCL_SYMBOL) {
 999               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
1000               eqvlen = MAX_DCL_SYMBOL;
1001               /* Special hack--we might be called before the interpreter's */
1002               /* fully initialized, in which case either thr or PL_curcop */
1003               /* might be bogus. We have to check, since ckWARN needs them */
1004               /* both to be valid if running threaded */
1005                 if (ckWARN(WARN_MISC)) {
1006                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1007                 }
1008             }
1009             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1010           }
1011           _ckvmssts(lib$sfree1_dd(&eqvdsc));
1012           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1013           if (retsts == LIB$_NOSUCHSYM) continue;
1014           break;
1015         }
1016       }
1017       else if (!ivlnm) {
1018         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1019           midx = my_maxidx(lnm);
1020           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1021             lnmlst[1].bufadr = cp2;
1022             eqvlen = 0;
1023             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1024             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1025             if (retsts == SS$_NOLOGNAM) break;
1026             /* PPFs have a prefix */
1027             if (
1028 #if INTSIZE == 4
1029                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1030 #endif
1031                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1032                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1033                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1034                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1035                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1036               memmove(eqv,eqv+4,eqvlen-4);
1037               eqvlen -= 4;
1038             }
1039             cp2 += eqvlen;
1040             *cp2 = '\0';
1041           }
1042           if ((retsts == SS$_IVLOGNAM) ||
1043               (retsts == SS$_NOLOGNAM)) { continue; }
1044         }
1045         else {
1046           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1047           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1048           if (retsts == SS$_NOLOGNAM) continue;
1049           eqv[eqvlen] = '\0';
1050         }
1051         eqvlen = strlen(eqv);
1052         break;
1053       }
1054     }
1055     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1056     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1057              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1058              retsts == SS$_NOLOGNAM) {
1059       set_errno(EINVAL);  set_vaxc_errno(retsts);
1060     }
1061     else _ckvmssts(retsts);
1062     return 0;
1063 }  /* end of vmstrnenv */
1064 /*}}}*/
1065
1066 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1067 /* Define as a function so we can access statics. */
1068 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1069 {
1070   return vmstrnenv(lnm,eqv,idx,fildev,
1071 #ifdef SECURE_INTERNAL_GETENV
1072                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
1073 #else
1074                    0
1075 #endif
1076                                                                               );
1077 }
1078 /*}}}*/
1079
1080 /* my_getenv
1081  * Note: Uses Perl temp to store result so char * can be returned to
1082  * caller; this pointer will be invalidated at next Perl statement
1083  * transition.
1084  * We define this as a function rather than a macro in terms of my_getenv_len()
1085  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1086  * allocate SVs).
1087  */
1088 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1089 char *
1090 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1091 {
1092     const char *cp1;
1093     static char *__my_getenv_eqv = NULL;
1094     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1095     unsigned long int idx = 0;
1096     int trnsuccess, success, secure, saverr, savvmserr;
1097     int midx, flags;
1098     SV *tmpsv;
1099
1100     midx = my_maxidx(lnm) + 1;
1101
1102     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1103       /* Set up a temporary buffer for the return value; Perl will
1104        * clean it up at the next statement transition */
1105       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1106       if (!tmpsv) return NULL;
1107       eqv = SvPVX(tmpsv);
1108     }
1109     else {
1110       /* Assume no interpreter ==> single thread */
1111       if (__my_getenv_eqv != NULL) {
1112         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1113       }
1114       else {
1115         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1116       }
1117       eqv = __my_getenv_eqv;
1118     }
1119
1120     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1121     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1122       int len;
1123       getcwd(eqv,LNM$C_NAMLENGTH);
1124
1125       len = strlen(eqv);
1126
1127       /* Get rid of "000000/ in rooted filespecs */
1128       if (len > 7) {
1129         char * zeros;
1130         zeros = strstr(eqv, "/000000/");
1131         if (zeros != NULL) {
1132           int mlen;
1133           mlen = len - (zeros - eqv) - 7;
1134           memmove(zeros, &zeros[7], mlen);
1135           len = len - 7;
1136           eqv[len] = '\0';
1137         }
1138       }
1139       return eqv;
1140     }
1141     else {
1142       /* Impose security constraints only if tainting */
1143       if (sys) {
1144         /* Impose security constraints only if tainting */
1145         secure = PL_curinterp ? PL_tainting : will_taint;
1146         saverr = errno;  savvmserr = vaxc$errno;
1147       }
1148       else {
1149         secure = 0;
1150       }
1151
1152       flags =
1153 #ifdef SECURE_INTERNAL_GETENV
1154               secure ? PERL__TRNENV_SECURE : 0
1155 #else
1156               0
1157 #endif
1158       ;
1159
1160       /* For the getenv interface we combine all the equivalence names
1161        * of a search list logical into one value to acquire a maximum
1162        * value length of 255*128 (assuming %ENV is using logicals).
1163        */
1164       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1165
1166       /* If the name contains a semicolon-delimited index, parse it
1167        * off and make sure we only retrieve the equivalence name for
1168        * that index.  */
1169       if ((cp2 = strchr(lnm,';')) != NULL) {
1170         strcpy(uplnm,lnm);
1171         uplnm[cp2-lnm] = '\0';
1172         idx = strtoul(cp2+1,NULL,0);
1173         lnm = uplnm;
1174         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1175       }
1176
1177       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1178
1179       /* Discard NOLOGNAM on internal calls since we're often looking
1180        * for an optional name, and this "error" often shows up as the
1181        * (bogus) exit status for a die() call later on.  */
1182       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1183       return success ? eqv : NULL;
1184     }
1185
1186 }  /* end of my_getenv() */
1187 /*}}}*/
1188
1189
1190 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1191 char *
1192 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1193 {
1194     const char *cp1;
1195     char *buf, *cp2;
1196     unsigned long idx = 0;
1197     int midx, flags;
1198     static char *__my_getenv_len_eqv = NULL;
1199     int secure, saverr, savvmserr;
1200     SV *tmpsv;
1201
1202     midx = my_maxidx(lnm) + 1;
1203
1204     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1205       /* Set up a temporary buffer for the return value; Perl will
1206        * clean it up at the next statement transition */
1207       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1208       if (!tmpsv) return NULL;
1209       buf = SvPVX(tmpsv);
1210     }
1211     else {
1212       /* Assume no interpreter ==> single thread */
1213       if (__my_getenv_len_eqv != NULL) {
1214         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1215       }
1216       else {
1217         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1218       }
1219       buf = __my_getenv_len_eqv;
1220     }
1221
1222     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1223     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1224     char * zeros;
1225
1226       getcwd(buf,LNM$C_NAMLENGTH);
1227       *len = strlen(buf);
1228
1229       /* Get rid of "000000/ in rooted filespecs */
1230       if (*len > 7) {
1231       zeros = strstr(buf, "/000000/");
1232       if (zeros != NULL) {
1233         int mlen;
1234         mlen = *len - (zeros - buf) - 7;
1235         memmove(zeros, &zeros[7], mlen);
1236         *len = *len - 7;
1237         buf[*len] = '\0';
1238         }
1239       }
1240       return buf;
1241     }
1242     else {
1243       if (sys) {
1244         /* Impose security constraints only if tainting */
1245         secure = PL_curinterp ? PL_tainting : will_taint;
1246         saverr = errno;  savvmserr = vaxc$errno;
1247       }
1248       else {
1249         secure = 0;
1250       }
1251
1252       flags =
1253 #ifdef SECURE_INTERNAL_GETENV
1254               secure ? PERL__TRNENV_SECURE : 0
1255 #else
1256               0
1257 #endif
1258       ;
1259
1260       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1261
1262       if ((cp2 = strchr(lnm,';')) != NULL) {
1263         strcpy(buf,lnm);
1264         buf[cp2-lnm] = '\0';
1265         idx = strtoul(cp2+1,NULL,0);
1266         lnm = buf;
1267         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1268       }
1269
1270       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1271
1272       /* Get rid of "000000/ in rooted filespecs */
1273       if (*len > 7) {
1274       char * zeros;
1275         zeros = strstr(buf, "/000000/");
1276         if (zeros != NULL) {
1277           int mlen;
1278           mlen = *len - (zeros - buf) - 7;
1279           memmove(zeros, &zeros[7], mlen);
1280           *len = *len - 7;
1281           buf[*len] = '\0';
1282         }
1283       }
1284
1285       /* Discard NOLOGNAM on internal calls since we're often looking
1286        * for an optional name, and this "error" often shows up as the
1287        * (bogus) exit status for a die() call later on.  */
1288       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1289       return *len ? buf : NULL;
1290     }
1291
1292 }  /* end of my_getenv_len() */
1293 /*}}}*/
1294
1295 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1296
1297 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1298
1299 /*{{{ void prime_env_iter() */
1300 void
1301 prime_env_iter(void)
1302 /* Fill the %ENV associative array with all logical names we can
1303  * find, in preparation for iterating over it.
1304  */
1305 {
1306   static int primed = 0;
1307   HV *seenhv = NULL, *envhv;
1308   SV *sv = NULL;
1309   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1310   unsigned short int chan;
1311 #ifndef CLI$M_TRUSTED
1312 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1313 #endif
1314   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1315   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1316   long int i;
1317   bool have_sym = FALSE, have_lnm = FALSE;
1318   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1319   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1320   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1321   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1322   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1323 #if defined(PERL_IMPLICIT_CONTEXT)
1324   pTHX;
1325 #endif
1326 #if defined(USE_ITHREADS)
1327   static perl_mutex primenv_mutex;
1328   MUTEX_INIT(&primenv_mutex);
1329 #endif
1330
1331 #if defined(PERL_IMPLICIT_CONTEXT)
1332     /* We jump through these hoops because we can be called at */
1333     /* platform-specific initialization time, which is before anything is */
1334     /* set up--we can't even do a plain dTHX since that relies on the */
1335     /* interpreter structure to be initialized */
1336     if (PL_curinterp) {
1337       aTHX = PERL_GET_INTERP;
1338     } else {
1339       aTHX = NULL;
1340     }
1341 #endif
1342
1343   if (primed || !PL_envgv) return;
1344   MUTEX_LOCK(&primenv_mutex);
1345   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1346   envhv = GvHVn(PL_envgv);
1347   /* Perform a dummy fetch as an lval to insure that the hash table is
1348    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1349   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1350
1351   for (i = 0; env_tables[i]; i++) {
1352      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1353          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1354      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1355   }
1356   if (have_sym || have_lnm) {
1357     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1358     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1359     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1360     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1361   }
1362
1363   for (i--; i >= 0; i--) {
1364     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1365       char *start;
1366       int j;
1367       for (j = 0; environ[j]; j++) {
1368         if (!(start = strchr(environ[j],'='))) {
1369           if (ckWARN(WARN_INTERNAL))
1370             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1371         }
1372         else {
1373           start++;
1374           sv = newSVpv(start,0);
1375           SvTAINTED_on(sv);
1376           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1377         }
1378       }
1379       continue;
1380     }
1381     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1382              !str$case_blind_compare(&tmpdsc,&clisym)) {
1383       strcpy(cmd,"Show Symbol/Global *");
1384       cmddsc.dsc$w_length = 20;
1385       if (env_tables[i]->dsc$w_length == 12 &&
1386           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1387           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1388       flags = defflags | CLI$M_NOLOGNAM;
1389     }
1390     else {
1391       strcpy(cmd,"Show Logical *");
1392       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1393         strcat(cmd," /Table=");
1394         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1395         cmddsc.dsc$w_length = strlen(cmd);
1396       }
1397       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1398       flags = defflags | CLI$M_NOCLISYM;
1399     }
1400
1401     /* Create a new subprocess to execute each command, to exclude the
1402      * remote possibility that someone could subvert a mbx or file used
1403      * to write multiple commands to a single subprocess.
1404      */
1405     do {
1406       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1407                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1408       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1409       defflags &= ~CLI$M_TRUSTED;
1410     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1411     _ckvmssts(retsts);
1412     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1413     if (seenhv) SvREFCNT_dec(seenhv);
1414     seenhv = newHV();
1415     while (1) {
1416       char *cp1, *cp2, *key;
1417       unsigned long int sts, iosb[2], retlen, keylen;
1418       register U32 hash;
1419
1420       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1421       if (sts & 1) sts = iosb[0] & 0xffff;
1422       if (sts == SS$_ENDOFFILE) {
1423         int wakect = 0;
1424         while (substs == 0) { sys$hiber(); wakect++;}
1425         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1426         _ckvmssts(substs);
1427         break;
1428       }
1429       _ckvmssts(sts);
1430       retlen = iosb[0] >> 16;
1431       if (!retlen) continue;  /* blank line */
1432       buf[retlen] = '\0';
1433       if (iosb[1] != subpid) {
1434         if (iosb[1]) {
1435           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1436         }
1437         continue;
1438       }
1439       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1440         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1441
1442       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1443       if (*cp1 == '(' || /* Logical name table name */
1444           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1445       if (*cp1 == '"') cp1++;
1446       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1447       key = cp1;  keylen = cp2 - cp1;
1448       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1449       while (*cp2 && *cp2 != '=') cp2++;
1450       while (*cp2 && *cp2 == '=') cp2++;
1451       while (*cp2 && *cp2 == ' ') cp2++;
1452       if (*cp2 == '"') {  /* String translation; may embed "" */
1453         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1454         cp2++;  cp1--; /* Skip "" surrounding translation */
1455       }
1456       else {  /* Numeric translation */
1457         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1458         cp1--;  /* stop on last non-space char */
1459       }
1460       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1461         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1462         continue;
1463       }
1464       PERL_HASH(hash,key,keylen);
1465
1466       if (cp1 == cp2 && *cp2 == '.') {
1467         /* A single dot usually means an unprintable character, such as a null
1468          * to indicate a zero-length value.  Get the actual value to make sure.
1469          */
1470         char lnm[LNM$C_NAMLENGTH+1];
1471         char eqv[MAX_DCL_SYMBOL+1];
1472         int trnlen;
1473         strncpy(lnm, key, keylen);
1474         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1475         sv = newSVpvn(eqv, strlen(eqv));
1476       }
1477       else {
1478         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1479       }
1480
1481       SvTAINTED_on(sv);
1482       hv_store(envhv,key,keylen,sv,hash);
1483       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1484     }
1485     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1486       /* get the PPFs for this process, not the subprocess */
1487       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1488       char eqv[LNM$C_NAMLENGTH+1];
1489       int trnlen, i;
1490       for (i = 0; ppfs[i]; i++) {
1491         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1492         sv = newSVpv(eqv,trnlen);
1493         SvTAINTED_on(sv);
1494         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1495       }
1496     }
1497   }
1498   primed = 1;
1499   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1500   if (buf) Safefree(buf);
1501   if (seenhv) SvREFCNT_dec(seenhv);
1502   MUTEX_UNLOCK(&primenv_mutex);
1503   return;
1504
1505 }  /* end of prime_env_iter */
1506 /*}}}*/
1507
1508
1509 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1510 /* Define or delete an element in the same "environment" as
1511  * vmstrnenv().  If an element is to be deleted, it's removed from
1512  * the first place it's found.  If it's to be set, it's set in the
1513  * place designated by the first element of the table vector.
1514  * Like setenv() returns 0 for success, non-zero on error.
1515  */
1516 int
1517 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1518 {
1519     const char *cp1;
1520     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1521     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1522     int nseg = 0, j;
1523     unsigned long int retsts, usermode = PSL$C_USER;
1524     struct itmlst_3 *ile, *ilist;
1525     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1526                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1527                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1528     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1529     $DESCRIPTOR(local,"_LOCAL");
1530
1531     if (!lnm) {
1532         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1533         return SS$_IVLOGNAM;
1534     }
1535
1536     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1537       *cp2 = _toupper(*cp1);
1538       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1539         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1540         return SS$_IVLOGNAM;
1541       }
1542     }
1543     lnmdsc.dsc$w_length = cp1 - lnm;
1544     if (!tabvec || !*tabvec) tabvec = env_tables;
1545
1546     if (!eqv) {  /* we're deleting n element */
1547       for (curtab = 0; tabvec[curtab]; curtab++) {
1548         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1549         int i;
1550           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1551             if ((cp1 = strchr(environ[i],'=')) &&
1552                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1553                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1554 #ifdef HAS_SETENV
1555               return setenv(lnm,"",1) ? vaxc$errno : 0;
1556             }
1557           }
1558           ivenv = 1; retsts = SS$_NOLOGNAM;
1559 #else
1560               if (ckWARN(WARN_INTERNAL))
1561                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1562               ivenv = 1; retsts = SS$_NOSUCHPGM;
1563               break;
1564             }
1565           }
1566 #endif
1567         }
1568         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1569                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1570           unsigned int symtype;
1571           if (tabvec[curtab]->dsc$w_length == 12 &&
1572               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1573               !str$case_blind_compare(&tmpdsc,&local))
1574             symtype = LIB$K_CLI_LOCAL_SYM;
1575           else symtype = LIB$K_CLI_GLOBAL_SYM;
1576           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1577           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1578           if (retsts == LIB$_NOSUCHSYM) continue;
1579           break;
1580         }
1581         else if (!ivlnm) {
1582           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1583           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1584           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1585           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1586           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1587         }
1588       }
1589     }
1590     else {  /* we're defining a value */
1591       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1592 #ifdef HAS_SETENV
1593         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1594 #else
1595         if (ckWARN(WARN_INTERNAL))
1596           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1597         retsts = SS$_NOSUCHPGM;
1598 #endif
1599       }
1600       else {
1601         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1602         eqvdsc.dsc$w_length  = strlen(eqv);
1603         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1604             !str$case_blind_compare(&tmpdsc,&clisym)) {
1605           unsigned int symtype;
1606           if (tabvec[0]->dsc$w_length == 12 &&
1607               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1608                !str$case_blind_compare(&tmpdsc,&local))
1609             symtype = LIB$K_CLI_LOCAL_SYM;
1610           else symtype = LIB$K_CLI_GLOBAL_SYM;
1611           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1612         }
1613         else {
1614           if (!*eqv) eqvdsc.dsc$w_length = 1;
1615           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1616
1617             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1618             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1619               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1620                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1621               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1622               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1623             }
1624
1625             Newx(ilist,nseg+1,struct itmlst_3);
1626             ile = ilist;
1627             if (!ile) {
1628               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1629               return SS$_INSFMEM;
1630             }
1631             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1632
1633             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1634               ile->itmcode = LNM$_STRING;
1635               ile->bufadr = c;
1636               if ((j+1) == nseg) {
1637                 ile->buflen = strlen(c);
1638                 /* in case we are truncating one that's too long */
1639                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1640               }
1641               else {
1642                 ile->buflen = LNM$C_NAMLENGTH;
1643               }
1644             }
1645
1646             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1647             Safefree (ilist);
1648           }
1649           else {
1650             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1651           }
1652         }
1653       }
1654     }
1655     if (!(retsts & 1)) {
1656       switch (retsts) {
1657         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1658         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1659           set_errno(EVMSERR); break;
1660         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1661         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1662           set_errno(EINVAL); break;
1663         case SS$_NOPRIV:
1664           set_errno(EACCES); break;
1665         default:
1666           _ckvmssts(retsts);
1667           set_errno(EVMSERR);
1668        }
1669        set_vaxc_errno(retsts);
1670        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1671     }
1672     else {
1673       /* We reset error values on success because Perl does an hv_fetch()
1674        * before each hv_store(), and if the thing we're setting didn't
1675        * previously exist, we've got a leftover error message.  (Of course,
1676        * this fails in the face of
1677        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1678        * in that the error reported in $! isn't spurious,
1679        * but it's right more often than not.)
1680        */
1681       set_errno(0); set_vaxc_errno(retsts);
1682       return 0;
1683     }
1684
1685 }  /* end of vmssetenv() */
1686 /*}}}*/
1687
1688 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1689 /* This has to be a function since there's a prototype for it in proto.h */
1690 void
1691 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1692 {
1693     if (lnm && *lnm) {
1694       int len = strlen(lnm);
1695       if  (len == 7) {
1696         char uplnm[8];
1697         int i;
1698         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1699         if (!strcmp(uplnm,"DEFAULT")) {
1700           if (eqv && *eqv) my_chdir(eqv);
1701           return;
1702         }
1703     }
1704 #ifndef RTL_USES_UTC
1705     if (len == 6 || len == 2) {
1706       char uplnm[7];
1707       int i;
1708       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1709       uplnm[len] = '\0';
1710       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1711       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1712     }
1713 #endif
1714   }
1715   (void) vmssetenv(lnm,eqv,NULL);
1716 }
1717 /*}}}*/
1718
1719 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1720 /*  vmssetuserlnm
1721  *  sets a user-mode logical in the process logical name table
1722  *  used for redirection of sys$error
1723  */
1724 void
1725 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1726 {
1727     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1728     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1729     unsigned long int iss, attr = LNM$M_CONFINE;
1730     unsigned char acmode = PSL$C_USER;
1731     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1732                                  {0, 0, 0, 0}};
1733     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1734     d_name.dsc$w_length = strlen(name);
1735
1736     lnmlst[0].buflen = strlen(eqv);
1737     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1738
1739     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1740     if (!(iss&1)) lib$signal(iss);
1741 }
1742 /*}}}*/
1743
1744
1745 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1746 /* my_crypt - VMS password hashing
1747  * my_crypt() provides an interface compatible with the Unix crypt()
1748  * C library function, and uses sys$hash_password() to perform VMS
1749  * password hashing.  The quadword hashed password value is returned
1750  * as a NUL-terminated 8 character string.  my_crypt() does not change
1751  * the case of its string arguments; in order to match the behavior
1752  * of LOGINOUT et al., alphabetic characters in both arguments must
1753  *  be upcased by the caller.
1754  *
1755  * - fix me to call ACM services when available
1756  */
1757 char *
1758 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1759 {
1760 #   ifndef UAI$C_PREFERRED_ALGORITHM
1761 #     define UAI$C_PREFERRED_ALGORITHM 127
1762 #   endif
1763     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1764     unsigned short int salt = 0;
1765     unsigned long int sts;
1766     struct const_dsc {
1767         unsigned short int dsc$w_length;
1768         unsigned char      dsc$b_type;
1769         unsigned char      dsc$b_class;
1770         const char *       dsc$a_pointer;
1771     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1772        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1773     struct itmlst_3 uailst[3] = {
1774         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1775         { sizeof salt, UAI$_SALT,    &salt, 0},
1776         { 0,           0,            NULL,  NULL}};
1777     static char hash[9];
1778
1779     usrdsc.dsc$w_length = strlen(usrname);
1780     usrdsc.dsc$a_pointer = usrname;
1781     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1782       switch (sts) {
1783         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1784           set_errno(EACCES);
1785           break;
1786         case RMS$_RNF:
1787           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1788           break;
1789         default:
1790           set_errno(EVMSERR);
1791       }
1792       set_vaxc_errno(sts);
1793       if (sts != RMS$_RNF) return NULL;
1794     }
1795
1796     txtdsc.dsc$w_length = strlen(textpasswd);
1797     txtdsc.dsc$a_pointer = textpasswd;
1798     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1799       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1800     }
1801
1802     return (char *) hash;
1803
1804 }  /* end of my_crypt() */
1805 /*}}}*/
1806
1807
1808 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1809 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1810 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1811
1812 /* fixup barenames that are directories for internal use.
1813  * There have been problems with the consistent handling of UNIX
1814  * style directory names when routines are presented with a name that
1815  * has no directory delimitors at all.  So this routine will eventually
1816  * fix the issue.
1817  */
1818 static char * fixup_bare_dirnames(const char * name)
1819 {
1820   if (decc_disable_to_vms_logname_translation) {
1821 /* fix me */
1822   }
1823   return NULL;
1824 }
1825
1826 /* 8.3, remove() is now broken on symbolic links */
1827 static int rms_erase(const char * vmsname);
1828
1829
1830 /* mp_do_kill_file
1831  * A little hack to get around a bug in some implemenation of remove()
1832  * that do not know how to delete a directory
1833  *
1834  * Delete any file to which user has control access, regardless of whether
1835  * delete access is explicitly allowed.
1836  * Limitations: User must have write access to parent directory.
1837  *              Does not block signals or ASTs; if interrupted in midstream
1838  *              may leave file with an altered ACL.
1839  * HANDLE WITH CARE!
1840  */
1841 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1842 static int
1843 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1844 {
1845     char *vmsname;
1846     char *rslt;
1847     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1848     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1849     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1850     struct myacedef {
1851       unsigned char myace$b_length;
1852       unsigned char myace$b_type;
1853       unsigned short int myace$w_flags;
1854       unsigned long int myace$l_access;
1855       unsigned long int myace$l_ident;
1856     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1857                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1858       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1859      struct itmlst_3
1860        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1861                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1862        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1863        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1864        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1865        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1866
1867     /* Expand the input spec using RMS, since the CRTL remove() and
1868      * system services won't do this by themselves, so we may miss
1869      * a file "hiding" behind a logical name or search list. */
1870     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1871     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1872
1873     rslt = do_rmsexpand(name,
1874                         vmsname,
1875                         0,
1876                         NULL,
1877                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
1878                         NULL,
1879                         NULL);
1880     if (rslt == NULL) {
1881         PerlMem_free(vmsname);
1882         return -1;
1883       }
1884
1885     /* Erase the file */
1886     rmsts = rms_erase(vmsname);
1887
1888     /* Did it succeed */
1889     if ($VMS_STATUS_SUCCESS(rmsts)) {
1890         PerlMem_free(vmsname);
1891         return 0;
1892       }
1893
1894     /* If not, can changing protections help? */
1895     if (rmsts != RMS$_PRV) {
1896       set_vaxc_errno(rmsts);
1897       PerlMem_free(vmsname);
1898       return -1;
1899     }
1900
1901     /* No, so we get our own UIC to use as a rights identifier,
1902      * and the insert an ACE at the head of the ACL which allows us
1903      * to delete the file.
1904      */
1905     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1906     fildsc.dsc$w_length = strlen(vmsname);
1907     fildsc.dsc$a_pointer = vmsname;
1908     cxt = 0;
1909     newace.myace$l_ident = oldace.myace$l_ident;
1910     rmsts = -1;
1911     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1912       switch (aclsts) {
1913         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1914           set_errno(ENOENT); break;
1915         case RMS$_DIR:
1916           set_errno(ENOTDIR); break;
1917         case RMS$_DEV:
1918           set_errno(ENODEV); break;
1919         case RMS$_SYN: case SS$_INVFILFOROP:
1920           set_errno(EINVAL); break;
1921         case RMS$_PRV:
1922           set_errno(EACCES); break;
1923         default:
1924           _ckvmssts(aclsts);
1925       }
1926       set_vaxc_errno(aclsts);
1927       PerlMem_free(vmsname);
1928       return -1;
1929     }
1930     /* Grab any existing ACEs with this identifier in case we fail */
1931     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1932     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1933                     || fndsts == SS$_NOMOREACE ) {
1934       /* Add the new ACE . . . */
1935       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1936         goto yourroom;
1937
1938       rmsts = rms_erase(vmsname);
1939       if ($VMS_STATUS_SUCCESS(rmsts)) {
1940         rmsts = 0;
1941         }
1942         else {
1943         rmsts = -1;
1944         /* We blew it - dir with files in it, no write priv for
1945          * parent directory, etc.  Put things back the way they were. */
1946         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1947           goto yourroom;
1948         if (fndsts & 1) {
1949           addlst[0].bufadr = &oldace;
1950           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1951             goto yourroom;
1952         }
1953       }
1954     }
1955
1956     yourroom:
1957     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1958     /* We just deleted it, so of course it's not there.  Some versions of
1959      * VMS seem to return success on the unlock operation anyhow (after all
1960      * the unlock is successful), but others don't.
1961      */
1962     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1963     if (aclsts & 1) aclsts = fndsts;
1964     if (!(aclsts & 1)) {
1965       set_errno(EVMSERR);
1966       set_vaxc_errno(aclsts);
1967     }
1968
1969     PerlMem_free(vmsname);
1970     return rmsts;
1971
1972 }  /* end of kill_file() */
1973 /*}}}*/
1974
1975
1976 /*{{{int do_rmdir(char *name)*/
1977 int
1978 Perl_do_rmdir(pTHX_ const char *name)
1979 {
1980     char * dirfile;
1981     int retval;
1982     Stat_t st;
1983
1984     dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
1985     if (dirfile == NULL)
1986         _ckvmssts(SS$_INSFMEM);
1987
1988     /* Force to a directory specification */
1989     if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
1990         PerlMem_free(dirfile);
1991         return -1;
1992     }
1993     if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
1994         errno = ENOTDIR;
1995         retval = -1;
1996     }
1997     else
1998         retval = mp_do_kill_file(aTHX_ dirfile, 1);
1999
2000     PerlMem_free(dirfile);
2001     return retval;
2002
2003 }  /* end of do_rmdir */
2004 /*}}}*/
2005
2006 /* kill_file
2007  * Delete any file to which user has control access, regardless of whether
2008  * delete access is explicitly allowed.
2009  * Limitations: User must have write access to parent directory.
2010  *              Does not block signals or ASTs; if interrupted in midstream
2011  *              may leave file with an altered ACL.
2012  * HANDLE WITH CARE!
2013  */
2014 /*{{{int kill_file(char *name)*/
2015 int
2016 Perl_kill_file(pTHX_ const char *name)
2017 {
2018     char rspec[NAM$C_MAXRSS+1];
2019     char *tspec;
2020     Stat_t st;
2021     int rmsts;
2022
2023    /* Remove() is allowed to delete directories, according to the X/Open
2024     * specifications.
2025     * This may need special handling to work with the ACL hacks.
2026      */
2027    if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
2028         rmsts = Perl_do_rmdir(aTHX_ name);
2029         return rmsts;
2030     }
2031
2032    rmsts = mp_do_kill_file(aTHX_ name, 0);
2033
2034     return rmsts;
2035
2036 }  /* end of kill_file() */
2037 /*}}}*/
2038
2039
2040 /*{{{int my_mkdir(char *,Mode_t)*/
2041 int
2042 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2043 {
2044   STRLEN dirlen = strlen(dir);
2045
2046   /* zero length string sometimes gives ACCVIO */
2047   if (dirlen == 0) return -1;
2048
2049   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2050    * null file name/type.  However, it's commonplace under Unix,
2051    * so we'll allow it for a gain in portability.
2052    */
2053   if (dir[dirlen-1] == '/') {
2054     char *newdir = savepvn(dir,dirlen-1);
2055     int ret = mkdir(newdir,mode);
2056     Safefree(newdir);
2057     return ret;
2058   }
2059   else return mkdir(dir,mode);
2060 }  /* end of my_mkdir */
2061 /*}}}*/
2062
2063 /*{{{int my_chdir(char *)*/
2064 int
2065 Perl_my_chdir(pTHX_ const char *dir)
2066 {
2067   STRLEN dirlen = strlen(dir);
2068
2069   /* zero length string sometimes gives ACCVIO */
2070   if (dirlen == 0) return -1;
2071   const char *dir1;
2072
2073   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2074    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2075    * so that existing scripts do not need to be changed.
2076    */
2077   dir1 = dir;
2078   while ((dirlen > 0) && (*dir1 == ' ')) {
2079     dir1++;
2080     dirlen--;
2081   }
2082
2083   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2084    * that implies
2085    * null file name/type.  However, it's commonplace under Unix,
2086    * so we'll allow it for a gain in portability.
2087    *
2088    * - Preview- '/' will be valid soon on VMS
2089    */
2090   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2091     char *newdir = savepvn(dir1,dirlen-1);
2092     int ret = chdir(newdir);
2093     Safefree(newdir);
2094     return ret;
2095   }
2096   else return chdir(dir1);
2097 }  /* end of my_chdir */
2098 /*}}}*/
2099
2100
2101 /*{{{int my_chmod(char *, mode_t)*/
2102 int
2103 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2104 {
2105   STRLEN speclen = strlen(file_spec);
2106
2107   /* zero length string sometimes gives ACCVIO */
2108   if (speclen == 0) return -1;
2109
2110   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2111    * that implies null file name/type.  However, it's commonplace under Unix,
2112    * so we'll allow it for a gain in portability.
2113    *
2114    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2115    * in VMS file.dir notation.
2116    */
2117   if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2118     char *vms_src, *vms_dir, *rslt;
2119     int ret = -1;
2120     errno = EIO;
2121
2122     /* First convert this to a VMS format specification */
2123     vms_src = PerlMem_malloc(VMS_MAXRSS);
2124     if (vms_src == NULL)
2125         _ckvmssts(SS$_INSFMEM);
2126
2127     rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2128     if (rslt == NULL) {
2129         /* If we fail, then not a file specification */
2130         PerlMem_free(vms_src);
2131         errno = EIO;
2132         return -1;
2133     }
2134
2135     /* Now make it a directory spec so chmod is happy */
2136     vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2137     if (vms_dir == NULL)
2138         _ckvmssts(SS$_INSFMEM);
2139     rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2140     PerlMem_free(vms_src);
2141
2142     /* Now do it */
2143     if (rslt != NULL) {
2144         ret = chmod(vms_dir, mode);
2145     } else {
2146         errno = EIO;
2147     }
2148     PerlMem_free(vms_dir);
2149     return ret;
2150   }
2151   else return chmod(file_spec, mode);
2152 }  /* end of my_chmod */
2153 /*}}}*/
2154
2155
2156 /*{{{FILE *my_tmpfile()*/
2157 FILE *
2158 my_tmpfile(void)
2159 {
2160   FILE *fp;
2161   char *cp;
2162
2163   if ((fp = tmpfile())) return fp;
2164
2165   cp = PerlMem_malloc(L_tmpnam+24);
2166   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2167
2168   if (decc_filename_unix_only == 0)
2169     strcpy(cp,"Sys$Scratch:");
2170   else
2171     strcpy(cp,"/tmp/");
2172   tmpnam(cp+strlen(cp));
2173   strcat(cp,".Perltmp");
2174   fp = fopen(cp,"w+","fop=dlt");
2175   PerlMem_free(cp);
2176   return fp;
2177 }
2178 /*}}}*/
2179
2180
2181 #ifndef HOMEGROWN_POSIX_SIGNALS
2182 /*
2183  * The C RTL's sigaction fails to check for invalid signal numbers so we
2184  * help it out a bit.  The docs are correct, but the actual routine doesn't
2185  * do what the docs say it will.
2186  */
2187 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2188 int
2189 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2190                    struct sigaction* oact)
2191 {
2192   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2193         SETERRNO(EINVAL, SS$_INVARG);
2194         return -1;
2195   }
2196   return sigaction(sig, act, oact);
2197 }
2198 /*}}}*/
2199 #endif
2200
2201 #ifdef KILL_BY_SIGPRC
2202 #include <errnodef.h>
2203
2204 /* We implement our own kill() using the undocumented system service
2205    sys$sigprc for one of two reasons:
2206
2207    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2208    target process to do a sys$exit, which usually can't be handled
2209    gracefully...certainly not by Perl and the %SIG{} mechanism.
2210
2211    2.) If the kill() in the CRTL can't be called from a signal
2212    handler without disappearing into the ether, i.e., the signal
2213    it purportedly sends is never trapped. Still true as of VMS 7.3.
2214
2215    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2216    in the target process rather than calling sys$exit.
2217
2218    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2219    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2220    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2221    with condition codes C$_SIG0+nsig*8, catching the exception on the
2222    target process and resignaling with appropriate arguments.
2223
2224    But we don't have that VMS 7.0+ exception handler, so if you
2225    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2226
2227    Also note that SIGTERM is listed in the docs as being "unimplemented",
2228    yet always seems to be signaled with a VMS condition code of 4 (and
2229    correctly handled for that code).  So we hardwire it in.
2230
2231    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2232    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2233    than signalling with an unrecognized (and unhandled by CRTL) code.
2234 */
2235
2236 #define _MY_SIG_MAX 28
2237
2238 static unsigned int
2239 Perl_sig_to_vmscondition_int(int sig)
2240 {
2241     static unsigned int sig_code[_MY_SIG_MAX+1] =
2242     {
2243         0,                  /*  0 ZERO     */
2244         SS$_HANGUP,         /*  1 SIGHUP   */
2245         SS$_CONTROLC,       /*  2 SIGINT   */
2246         SS$_CONTROLY,       /*  3 SIGQUIT  */
2247         SS$_RADRMOD,        /*  4 SIGILL   */
2248         SS$_BREAK,          /*  5 SIGTRAP  */
2249         SS$_OPCCUS,         /*  6 SIGABRT  */
2250         SS$_COMPAT,         /*  7 SIGEMT   */
2251 #ifdef __VAX
2252         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2253 #else
2254         SS$_HPARITH,        /*  8 SIGFPE AXP */
2255 #endif
2256         SS$_ABORT,          /*  9 SIGKILL  */
2257         SS$_ACCVIO,         /* 10 SIGBUS   */
2258         SS$_ACCVIO,         /* 11 SIGSEGV  */
2259         SS$_BADPARAM,       /* 12 SIGSYS   */
2260         SS$_NOMBX,          /* 13 SIGPIPE  */
2261         SS$_ASTFLT,         /* 14 SIGALRM  */
2262         4,                  /* 15 SIGTERM  */
2263         0,                  /* 16 SIGUSR1  */
2264         0,                  /* 17 SIGUSR2  */
2265         0,                  /* 18 */
2266         0,                  /* 19 */
2267         0,                  /* 20 SIGCHLD  */
2268         0,                  /* 21 SIGCONT  */
2269         0,                  /* 22 SIGSTOP  */
2270         0,                  /* 23 SIGTSTP  */
2271         0,                  /* 24 SIGTTIN  */
2272         0,                  /* 25 SIGTTOU  */
2273         0,                  /* 26 */
2274         0,                  /* 27 */
2275         0                   /* 28 SIGWINCH  */
2276     };
2277
2278 #if __VMS_VER >= 60200000
2279     static int initted = 0;
2280     if (!initted) {
2281         initted = 1;
2282         sig_code[16] = C$_SIGUSR1;
2283         sig_code[17] = C$_SIGUSR2;
2284 #if __CRTL_VER >= 70000000
2285         sig_code[20] = C$_SIGCHLD;
2286 #endif
2287 #if __CRTL_VER >= 70300000
2288         sig_code[28] = C$_SIGWINCH;
2289 #endif
2290     }
2291 #endif
2292
2293     if (sig < _SIG_MIN) return 0;
2294     if (sig > _MY_SIG_MAX) return 0;
2295     return sig_code[sig];
2296 }
2297
2298 unsigned int
2299 Perl_sig_to_vmscondition(int sig)
2300 {
2301 #ifdef SS$_DEBUG
2302     if (vms_debug_on_exception != 0)
2303         lib$signal(SS$_DEBUG);
2304 #endif
2305     return Perl_sig_to_vmscondition_int(sig);
2306 }
2307
2308
2309 int
2310 Perl_my_kill(int pid, int sig)
2311 {
2312     dTHX;
2313     int iss;
2314     unsigned int code;
2315     int sys$sigprc(unsigned int *pidadr,
2316                      struct dsc$descriptor_s *prcname,
2317                      unsigned int code);
2318
2319      /* sig 0 means validate the PID */
2320     /*------------------------------*/
2321     if (sig == 0) {
2322         const unsigned long int jpicode = JPI$_PID;
2323         pid_t ret_pid;
2324         int status;
2325         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2326         if ($VMS_STATUS_SUCCESS(status))
2327            return 0;
2328         switch (status) {
2329         case SS$_NOSUCHNODE:
2330         case SS$_UNREACHABLE:
2331         case SS$_NONEXPR:
2332            errno = ESRCH;
2333            break;
2334         case SS$_NOPRIV:
2335            errno = EPERM;
2336            break;
2337         default:
2338            errno = EVMSERR;
2339         }
2340         vaxc$errno=status;
2341         return -1;
2342     }
2343
2344     code = Perl_sig_to_vmscondition_int(sig);
2345
2346     if (!code) {
2347         SETERRNO(EINVAL, SS$_BADPARAM);
2348         return -1;
2349     }
2350
2351     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2352      * signals are to be sent to multiple processes.
2353      *  pid = 0 - all processes in group except ones that the system exempts
2354      *  pid = -1 - all processes except ones that the system exempts
2355      *  pid = -n - all processes in group (abs(n)) except ...
2356      * For now, just report as not supported.
2357      */
2358
2359     if (pid <= 0) {
2360         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2361         return -1;
2362     }
2363
2364     iss = sys$sigprc((unsigned int *)&pid,0,code);
2365     if (iss&1) return 0;
2366
2367     switch (iss) {
2368       case SS$_NOPRIV:
2369         set_errno(EPERM);  break;
2370       case SS$_NONEXPR:
2371       case SS$_NOSUCHNODE:
2372       case SS$_UNREACHABLE:
2373         set_errno(ESRCH);  break;
2374       case SS$_INSFMEM:
2375         set_errno(ENOMEM); break;
2376       default:
2377         _ckvmssts(iss);
2378         set_errno(EVMSERR);
2379     }
2380     set_vaxc_errno(iss);
2381
2382     return -1;
2383 }
2384 #endif
2385
2386 /* Routine to convert a VMS status code to a UNIX status code.
2387 ** More tricky than it appears because of conflicting conventions with
2388 ** existing code.
2389 **
2390 ** VMS status codes are a bit mask, with the least significant bit set for
2391 ** success.
2392 **
2393 ** Special UNIX status of EVMSERR indicates that no translation is currently
2394 ** available, and programs should check the VMS status code.
2395 **
2396 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2397 ** decoding.
2398 */
2399
2400 #ifndef C_FACILITY_NO
2401 #define C_FACILITY_NO 0x350000
2402 #endif
2403 #ifndef DCL_IVVERB
2404 #define DCL_IVVERB 0x38090
2405 #endif
2406
2407 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2408 {
2409 int facility;
2410 int fac_sp;
2411 int msg_no;
2412 int msg_status;
2413 int unix_status;
2414
2415   /* Assume the best or the worst */
2416   if (vms_status & STS$M_SUCCESS)
2417     unix_status = 0;
2418   else
2419     unix_status = EVMSERR;
2420
2421   msg_status = vms_status & ~STS$M_CONTROL;
2422
2423   facility = vms_status & STS$M_FAC_NO;
2424   fac_sp = vms_status & STS$M_FAC_SP;
2425   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2426
2427   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2428     switch(msg_no) {
2429     case SS$_NORMAL:
2430         unix_status = 0;
2431         break;
2432     case SS$_ACCVIO:
2433         unix_status = EFAULT;
2434         break;
2435     case SS$_DEVOFFLINE:
2436         unix_status = EBUSY;
2437         break;
2438     case SS$_CLEARED:
2439         unix_status = ENOTCONN;
2440         break;
2441     case SS$_IVCHAN:
2442     case SS$_IVLOGNAM:
2443     case SS$_BADPARAM:
2444     case SS$_IVLOGTAB:
2445     case SS$_NOLOGNAM:
2446     case SS$_NOLOGTAB:
2447     case SS$_INVFILFOROP:
2448     case SS$_INVARG:
2449     case SS$_NOSUCHID:
2450     case SS$_IVIDENT:
2451         unix_status = EINVAL;
2452         break;
2453     case SS$_UNSUPPORTED:
2454         unix_status = ENOTSUP;
2455         break;
2456     case SS$_FILACCERR:
2457     case SS$_NOGRPPRV:
2458     case SS$_NOSYSPRV:
2459         unix_status = EACCES;
2460         break;
2461     case SS$_DEVICEFULL:
2462         unix_status = ENOSPC;
2463         break;
2464     case SS$_NOSUCHDEV:
2465         unix_status = ENODEV;
2466         break;
2467     case SS$_NOSUCHFILE:
2468     case SS$_NOSUCHOBJECT:
2469         unix_status = ENOENT;
2470         break;
2471     case SS$_ABORT:                                 /* Fatal case */
2472     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2473     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2474         unix_status = EINTR;
2475         break;
2476     case SS$_BUFFEROVF:
2477         unix_status = E2BIG;
2478         break;
2479     case SS$_INSFMEM:
2480         unix_status = ENOMEM;
2481         break;
2482     case SS$_NOPRIV:
2483         unix_status = EPERM;
2484         break;
2485     case SS$_NOSUCHNODE:
2486     case SS$_UNREACHABLE:
2487         unix_status = ESRCH;
2488         break;
2489     case SS$_NONEXPR:
2490         unix_status = ECHILD;
2491         break;
2492     default:
2493         if ((facility == 0) && (msg_no < 8)) {
2494           /* These are not real VMS status codes so assume that they are
2495           ** already UNIX status codes
2496           */
2497           unix_status = msg_no;
2498           break;
2499         }
2500     }
2501   }
2502   else {
2503     /* Translate a POSIX exit code to a UNIX exit code */
2504     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2505         unix_status = (msg_no & 0x07F8) >> 3;
2506     }
2507     else {
2508
2509          /* Documented traditional behavior for handling VMS child exits */
2510         /*--------------------------------------------------------------*/
2511         if (child_flag != 0) {
2512
2513              /* Success / Informational return 0 */
2514             /*----------------------------------*/
2515             if (msg_no & STS$K_SUCCESS)
2516                 return 0;
2517
2518              /* Warning returns 1 */
2519             /*-------------------*/
2520             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2521                 return 1;
2522
2523              /* Everything else pass through the severity bits */
2524             /*------------------------------------------------*/
2525             return (msg_no & STS$M_SEVERITY);
2526         }
2527
2528          /* Normal VMS status to ERRNO mapping attempt */
2529         /*--------------------------------------------*/
2530         switch(msg_status) {
2531         /* case RMS$_EOF: */ /* End of File */
2532         case RMS$_FNF:  /* File Not Found */
2533         case RMS$_DNF:  /* Dir Not Found */
2534                 unix_status = ENOENT;
2535                 break;
2536         case RMS$_RNF:  /* Record Not Found */
2537                 unix_status = ESRCH;
2538                 break;
2539         case RMS$_DIR:
2540                 unix_status = ENOTDIR;
2541                 break;
2542         case RMS$_DEV:
2543                 unix_status = ENODEV;
2544                 break;
2545         case RMS$_IFI:
2546         case RMS$_FAC:
2547         case RMS$_ISI:
2548                 unix_status = EBADF;
2549                 break;
2550         case RMS$_FEX:
2551                 unix_status = EEXIST;
2552                 break;
2553         case RMS$_SYN:
2554         case RMS$_FNM:
2555         case LIB$_INVSTRDES:
2556         case LIB$_INVARG:
2557         case LIB$_NOSUCHSYM:
2558         case LIB$_INVSYMNAM:
2559         case DCL_IVVERB:
2560                 unix_status = EINVAL;
2561                 break;
2562         case CLI$_BUFOVF:
2563         case RMS$_RTB:
2564         case CLI$_TKNOVF:
2565         case CLI$_RSLOVF:
2566                 unix_status = E2BIG;
2567                 break;
2568         case RMS$_PRV:  /* No privilege */
2569         case RMS$_ACC:  /* ACP file access failed */
2570         case RMS$_WLK:  /* Device write locked */
2571                 unix_status = EACCES;
2572                 break;
2573         case RMS$_MKD:  /* Failed to mark for delete */
2574                 unix_status = EPERM;
2575                 break;
2576         /* case RMS$_NMF: */  /* No more files */
2577         }
2578     }
2579   }
2580
2581   return unix_status;
2582 }
2583
2584 /* Try to guess at what VMS error status should go with a UNIX errno
2585  * value.  This is hard to do as there could be many possible VMS
2586  * error statuses that caused the errno value to be set.
2587  */
2588
2589 int Perl_unix_status_to_vms(int unix_status)
2590 {
2591 int test_unix_status;
2592
2593      /* Trivial cases first */
2594     /*---------------------*/
2595     if (unix_status == EVMSERR)
2596         return vaxc$errno;
2597
2598      /* Is vaxc$errno sane? */
2599     /*---------------------*/
2600     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2601     if (test_unix_status == unix_status)
2602         return vaxc$errno;
2603
2604      /* If way out of range, must be VMS code already */
2605     /*-----------------------------------------------*/
2606     if (unix_status > EVMSERR)
2607         return unix_status;
2608
2609      /* If out of range, punt */
2610     /*-----------------------*/
2611     if (unix_status > __ERRNO_MAX)
2612         return SS$_ABORT;
2613
2614
2615      /* Ok, now we have to do it the hard way. */
2616     /*----------------------------------------*/
2617     switch(unix_status) {
2618     case 0:     return SS$_NORMAL;
2619     case EPERM: return SS$_NOPRIV;
2620     case ENOENT: return SS$_NOSUCHOBJECT;
2621     case ESRCH: return SS$_UNREACHABLE;
2622     case EINTR: return SS$_ABORT;
2623     /* case EIO: */
2624     /* case ENXIO:  */
2625     case E2BIG: return SS$_BUFFEROVF;
2626     /* case ENOEXEC */
2627     case EBADF: return RMS$_IFI;
2628     case ECHILD: return SS$_NONEXPR;
2629     /* case EAGAIN */
2630     case ENOMEM: return SS$_INSFMEM;
2631     case EACCES: return SS$_FILACCERR;
2632     case EFAULT: return SS$_ACCVIO;
2633     /* case ENOTBLK */
2634     case EBUSY: return SS$_DEVOFFLINE;
2635     case EEXIST: return RMS$_FEX;
2636     /* case EXDEV */
2637     case ENODEV: return SS$_NOSUCHDEV;
2638     case ENOTDIR: return RMS$_DIR;
2639     /* case EISDIR */
2640     case EINVAL: return SS$_INVARG;
2641     /* case ENFILE */
2642     /* case EMFILE */
2643     /* case ENOTTY */
2644     /* case ETXTBSY */
2645     /* case EFBIG */
2646     case ENOSPC: return SS$_DEVICEFULL;
2647     case ESPIPE: return LIB$_INVARG;
2648     /* case EROFS: */
2649     /* case EMLINK: */
2650     /* case EPIPE: */
2651     /* case EDOM */
2652     case ERANGE: return LIB$_INVARG;
2653     /* case EWOULDBLOCK */
2654     /* case EINPROGRESS */
2655     /* case EALREADY */
2656     /* case ENOTSOCK */
2657     /* case EDESTADDRREQ */
2658     /* case EMSGSIZE */
2659     /* case EPROTOTYPE */
2660     /* case ENOPROTOOPT */
2661     /* case EPROTONOSUPPORT */
2662     /* case ESOCKTNOSUPPORT */
2663     /* case EOPNOTSUPP */
2664     /* case EPFNOSUPPORT */
2665     /* case EAFNOSUPPORT */
2666     /* case EADDRINUSE */
2667     /* case EADDRNOTAVAIL */
2668     /* case ENETDOWN */
2669     /* case ENETUNREACH */
2670     /* case ENETRESET */
2671     /* case ECONNABORTED */
2672     /* case ECONNRESET */
2673     /* case ENOBUFS */
2674     /* case EISCONN */
2675     case ENOTCONN: return SS$_CLEARED;
2676     /* case ESHUTDOWN */
2677     /* case ETOOMANYREFS */
2678     /* case ETIMEDOUT */
2679     /* case ECONNREFUSED */
2680     /* case ELOOP */
2681     /* case ENAMETOOLONG */
2682     /* case EHOSTDOWN */
2683     /* case EHOSTUNREACH */
2684     /* case ENOTEMPTY */
2685     /* case EPROCLIM */
2686     /* case EUSERS  */
2687     /* case EDQUOT  */
2688     /* case ENOMSG  */
2689     /* case EIDRM */
2690     /* case EALIGN */
2691     /* case ESTALE */
2692     /* case EREMOTE */
2693     /* case ENOLCK */
2694     /* case ENOSYS */
2695     /* case EFTYPE */
2696     /* case ECANCELED */
2697     /* case EFAIL */
2698     /* case EINPROG */
2699     case ENOTSUP:
2700         return SS$_UNSUPPORTED;
2701     /* case EDEADLK */
2702     /* case ENWAIT */
2703     /* case EILSEQ */
2704     /* case EBADCAT */
2705     /* case EBADMSG */
2706     /* case EABANDONED */
2707     default:
2708         return SS$_ABORT; /* punt */
2709     }
2710
2711   return SS$_ABORT; /* Should not get here */
2712 }
2713
2714
2715 /* default piping mailbox size */
2716 #define PERL_BUFSIZ        512
2717
2718
2719 static void
2720 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2721 {
2722   unsigned long int mbxbufsiz;
2723   static unsigned long int syssize = 0;
2724   unsigned long int dviitm = DVI$_DEVNAM;
2725   char csize[LNM$C_NAMLENGTH+1];
2726   int sts;
2727
2728   if (!syssize) {
2729     unsigned long syiitm = SYI$_MAXBUF;
2730     /*
2731      * Get the SYSGEN parameter MAXBUF
2732      *
2733      * If the logical 'PERL_MBX_SIZE' is defined
2734      * use the value of the logical instead of PERL_BUFSIZ, but
2735      * keep the size between 128 and MAXBUF.
2736      *
2737      */
2738     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2739   }
2740
2741   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2742       mbxbufsiz = atoi(csize);
2743   } else {
2744       mbxbufsiz = PERL_BUFSIZ;
2745   }
2746   if (mbxbufsiz < 128) mbxbufsiz = 128;
2747   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2748
2749   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2750
2751   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2752   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2753
2754 }  /* end of create_mbx() */
2755
2756
2757 /*{{{  my_popen and my_pclose*/
2758
2759 typedef struct _iosb           IOSB;
2760 typedef struct _iosb*         pIOSB;
2761 typedef struct _pipe           Pipe;
2762 typedef struct _pipe*         pPipe;
2763 typedef struct pipe_details    Info;
2764 typedef struct pipe_details*  pInfo;
2765 typedef struct _srqp            RQE;
2766 typedef struct _srqp*          pRQE;
2767 typedef struct _tochildbuf      CBuf;
2768 typedef struct _tochildbuf*    pCBuf;
2769
2770 struct _iosb {
2771     unsigned short status;
2772     unsigned short count;
2773     unsigned long  dvispec;
2774 };
2775
2776 #pragma member_alignment save
2777 #pragma nomember_alignment quadword
2778 struct _srqp {          /* VMS self-relative queue entry */
2779     unsigned long qptr[2];
2780 };
2781 #pragma member_alignment restore
2782 static RQE  RQE_ZERO = {0,0};
2783
2784 struct _tochildbuf {
2785     RQE             q;
2786     int             eof;
2787     unsigned short  size;
2788     char            *buf;
2789 };
2790
2791 struct _pipe {
2792     RQE            free;
2793     RQE            wait;
2794     int            fd_out;
2795     unsigned short chan_in;
2796     unsigned short chan_out;
2797     char          *buf;
2798     unsigned int   bufsize;
2799     IOSB           iosb;
2800     IOSB           iosb2;
2801     int           *pipe_done;
2802     int            retry;
2803     int            type;
2804     int            shut_on_empty;
2805     int            need_wake;
2806     pPipe         *home;
2807     pInfo          info;
2808     pCBuf          curr;
2809     pCBuf          curr2;
2810 #if defined(PERL_IMPLICIT_CONTEXT)
2811     void            *thx;           /* Either a thread or an interpreter */
2812                                     /* pointer, depending on how we're built */
2813 #endif
2814 };
2815
2816
2817 struct pipe_details
2818 {
2819     pInfo           next;
2820     PerlIO *fp;  /* file pointer to pipe mailbox */
2821     int useFILE; /* using stdio, not perlio */
2822     int pid;   /* PID of subprocess */
2823     int mode;  /* == 'r' if pipe open for reading */
2824     int done;  /* subprocess has completed */
2825     int waiting; /* waiting for completion/closure */
2826     int             closing;        /* my_pclose is closing this pipe */
2827     unsigned long   completion;     /* termination status of subprocess */
2828     pPipe           in;             /* pipe in to sub */
2829     pPipe           out;            /* pipe out of sub */
2830     pPipe           err;            /* pipe of sub's sys$error */
2831     int             in_done;        /* true when in pipe finished */
2832     int             out_done;
2833     int             err_done;
2834     unsigned short  xchan;          /* channel to debug xterm */
2835     unsigned short  xchan_valid;    /* channel is assigned */
2836 };
2837
2838 struct exit_control_block
2839 {
2840     struct exit_control_block *flink;
2841     unsigned long int   (*exit_routine)();
2842     unsigned long int arg_count;
2843     unsigned long int *status_address;
2844     unsigned long int exit_status;
2845 };
2846
2847 typedef struct _closed_pipes    Xpipe;
2848 typedef struct _closed_pipes*  pXpipe;
2849
2850 struct _closed_pipes {
2851     int             pid;            /* PID of subprocess */
2852     unsigned long   completion;     /* termination status of subprocess */
2853 };
2854 #define NKEEPCLOSED 50
2855 static Xpipe closed_list[NKEEPCLOSED];
2856 static int   closed_index = 0;
2857 static int   closed_num = 0;
2858
2859 #define RETRY_DELAY     "0 ::0.20"
2860 #define MAX_RETRY              50
2861
2862 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2863 static unsigned long mypid;
2864 static unsigned long delaytime[2];
2865
2866 static pInfo open_pipes = NULL;
2867 static $DESCRIPTOR(nl_desc, "NL:");
2868
2869 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2870
2871
2872
2873 static unsigned long int
2874 pipe_exit_routine(pTHX)
2875 {
2876     pInfo info;
2877     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2878     int sts, did_stuff, need_eof, j;
2879
2880    /*
2881     * Flush any pending i/o, but since we are in process run-down, be
2882     * careful about referencing PerlIO structures that may already have
2883     * been deallocated.  We may not even have an interpreter anymore.
2884     */
2885     info = open_pipes;
2886     while (info) {
2887         if (info->fp) {
2888            if (!info->useFILE
2889 #if defined(USE_ITHREADS)
2890              && my_perl
2891 #endif
2892              && PL_perlio_fd_refcnt)
2893                PerlIO_flush(info->fp);
2894            else
2895                fflush((FILE *)info->fp);
2896         }
2897         info = info->next;
2898     }
2899
2900     /*
2901      next we try sending an EOF...ignore if doesn't work, make sure we
2902      don't hang
2903     */
2904     did_stuff = 0;
2905     info = open_pipes;
2906
2907     while (info) {
2908       int need_eof;
2909       _ckvmssts_noperl(sys$setast(0));
2910       if (info->in && !info->in->shut_on_empty) {
2911         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2912                           0, 0, 0, 0, 0, 0));
2913         info->waiting = 1;
2914         did_stuff = 1;
2915       }
2916       _ckvmssts_noperl(sys$setast(1));
2917       info = info->next;
2918     }
2919
2920     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2921
2922     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2923         int nwait = 0;
2924
2925         info = open_pipes;
2926         while (info) {
2927           _ckvmssts_noperl(sys$setast(0));
2928           if (info->waiting && info->done)
2929                 info->waiting = 0;
2930           nwait += info->waiting;
2931           _ckvmssts_noperl(sys$setast(1));
2932           info = info->next;
2933         }
2934         if (!nwait) break;
2935         sleep(1);
2936     }
2937
2938     did_stuff = 0;
2939     info = open_pipes;
2940     while (info) {
2941       _ckvmssts_noperl(sys$setast(0));
2942       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2943         sts = sys$forcex(&info->pid,0,&abort);
2944         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2945         did_stuff = 1;
2946       }
2947       _ckvmssts_noperl(sys$setast(1));
2948       info = info->next;
2949     }
2950
2951     /* again, wait for effect */
2952
2953     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2954         int nwait = 0;
2955
2956         info = open_pipes;
2957         while (info) {
2958           _ckvmssts_noperl(sys$setast(0));
2959           if (info->waiting && info->done)
2960                 info->waiting = 0;
2961           nwait += info->waiting;
2962           _ckvmssts_noperl(sys$setast(1));
2963           info = info->next;
2964         }
2965         if (!nwait) break;
2966         sleep(1);
2967     }
2968
2969     info = open_pipes;
2970     while (info) {
2971       _ckvmssts_noperl(sys$setast(0));
2972       if (!info->done) {  /* We tried to be nice . . . */
2973         sts = sys$delprc(&info->pid,0);
2974         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2975         info->done = 1;  /* sys$delprc is as done as we're going to get. */
2976       }
2977       _ckvmssts_noperl(sys$setast(1));
2978       info = info->next;
2979     }
2980
2981     while(open_pipes) {
2982       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2983       else if (!(sts & 1)) retsts = sts;
2984     }
2985     return retsts;
2986 }
2987
2988 static struct exit_control_block pipe_exitblock =
2989        {(struct exit_control_block *) 0,
2990         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2991
2992 static void pipe_mbxtofd_ast(pPipe p);
2993 static void pipe_tochild1_ast(pPipe p);
2994 static void pipe_tochild2_ast(pPipe p);
2995
2996 static void
2997 popen_completion_ast(pInfo info)
2998 {
2999   pInfo i = open_pipes;
3000   int iss;
3001   int sts;
3002   pXpipe x;
3003
3004   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3005   closed_list[closed_index].pid = info->pid;
3006   closed_list[closed_index].completion = info->completion;
3007   closed_index++;
3008   if (closed_index == NKEEPCLOSED)
3009     closed_index = 0;
3010   closed_num++;
3011
3012   while (i) {
3013     if (i == info) break;
3014     i = i->next;
3015   }
3016   if (!i) return;       /* unlinked, probably freed too */
3017
3018   info->done = TRUE;
3019
3020 /*
3021     Writing to subprocess ...
3022             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3023
3024             chan_out may be waiting for "done" flag, or hung waiting
3025             for i/o completion to child...cancel the i/o.  This will
3026             put it into "snarf mode" (done but no EOF yet) that discards
3027             input.
3028
3029     Output from subprocess (stdout, stderr) needs to be flushed and
3030     shut down.   We try sending an EOF, but if the mbx is full the pipe
3031     routine should still catch the "shut_on_empty" flag, telling it to
3032     use immediate-style reads so that "mbx empty" -> EOF.
3033
3034
3035 */
3036   if (info->in && !info->in_done) {               /* only for mode=w */
3037         if (info->in->shut_on_empty && info->in->need_wake) {
3038             info->in->need_wake = FALSE;
3039             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3040         } else {
3041             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3042         }
3043   }
3044
3045   if (info->out && !info->out_done) {             /* were we also piping output? */
3046       info->out->shut_on_empty = TRUE;
3047       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3048       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3049       _ckvmssts_noperl(iss);
3050   }
3051
3052   if (info->err && !info->err_done) {        /* we were piping stderr */
3053         info->err->shut_on_empty = TRUE;
3054         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3055         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3056         _ckvmssts_noperl(iss);
3057   }
3058   _ckvmssts_noperl(sys$setef(pipe_ef));
3059
3060 }
3061
3062 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3063 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3064
3065 /*
3066     we actually differ from vmstrnenv since we use this to
3067     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3068     are pointing to the same thing
3069 */
3070
3071 static unsigned short
3072 popen_translate(pTHX_ char *logical, char *result)
3073 {
3074     int iss;
3075     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3076     $DESCRIPTOR(d_log,"");
3077     struct _il3 {
3078         unsigned short length;
3079         unsigned short code;
3080         char *         buffer_addr;
3081         unsigned short *retlenaddr;
3082     } itmlst[2];
3083     unsigned short l, ifi;
3084
3085     d_log.dsc$a_pointer = logical;
3086     d_log.dsc$w_length  = strlen(logical);
3087
3088     itmlst[0].code = LNM$_STRING;
3089     itmlst[0].length = 255;
3090     itmlst[0].buffer_addr = result;
3091     itmlst[0].retlenaddr = &l;
3092
3093     itmlst[1].code = 0;
3094     itmlst[1].length = 0;
3095     itmlst[1].buffer_addr = 0;
3096     itmlst[1].retlenaddr = 0;
3097
3098     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3099     if (iss == SS$_NOLOGNAM) {
3100         iss = SS$_NORMAL;
3101         l = 0;
3102     }
3103     if (!(iss&1)) lib$signal(iss);
3104     result[l] = '\0';
3105 /*
3106     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3107     strip it off and return the ifi, if any
3108 */
3109     ifi  = 0;
3110     if (result[0] == 0x1b && result[1] == 0x00) {
3111         memmove(&ifi,result+2,2);
3112         strcpy(result,result+4);
3113     }
3114     return ifi;     /* this is the RMS internal file id */
3115 }
3116
3117 static void pipe_infromchild_ast(pPipe p);
3118
3119 /*
3120     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3121     inside an AST routine without worrying about reentrancy and which Perl
3122     memory allocator is being used.
3123
3124     We read data and queue up the buffers, then spit them out one at a
3125     time to the output mailbox when the output mailbox is ready for one.
3126
3127 */
3128 #define INITIAL_TOCHILDQUEUE  2
3129
3130 static pPipe
3131 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3132 {
3133     pPipe p;
3134     pCBuf b;
3135     char mbx1[64], mbx2[64];
3136     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3137                                       DSC$K_CLASS_S, mbx1},
3138                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3139                                       DSC$K_CLASS_S, mbx2};
3140     unsigned int dviitm = DVI$_DEVBUFSIZ;
3141     int j, n;
3142
3143     n = sizeof(Pipe);
3144     _ckvmssts(lib$get_vm(&n, &p));
3145
3146     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3147     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3148     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3149
3150     p->buf           = 0;
3151     p->shut_on_empty = FALSE;
3152     p->need_wake     = FALSE;
3153     p->type          = 0;
3154     p->retry         = 0;
3155     p->iosb.status   = SS$_NORMAL;
3156     p->iosb2.status  = SS$_NORMAL;
3157     p->free          = RQE_ZERO;
3158     p->wait          = RQE_ZERO;
3159     p->curr          = 0;
3160     p->curr2         = 0;
3161     p->info          = 0;
3162 #ifdef PERL_IMPLICIT_CONTEXT
3163     p->thx           = aTHX;
3164 #endif
3165
3166     n = sizeof(CBuf) + p->bufsize;
3167
3168     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3169         _ckvmssts(lib$get_vm(&n, &b));
3170         b->buf = (char *) b + sizeof(CBuf);
3171         _ckvmssts(lib$insqhi(b, &p->free));
3172     }
3173
3174     pipe_tochild2_ast(p);
3175     pipe_tochild1_ast(p);
3176     strcpy(wmbx, mbx1);
3177     strcpy(rmbx, mbx2);
3178     return p;
3179 }
3180
3181 /*  reads the MBX Perl is writing, and queues */
3182
3183 static void
3184 pipe_tochild1_ast(pPipe p)
3185 {
3186     pCBuf b = p->curr;
3187     int iss = p->iosb.status;
3188     int eof = (iss == SS$_ENDOFFILE);
3189     int sts;
3190 #ifdef PERL_IMPLICIT_CONTEXT
3191     pTHX = p->thx;
3192 #endif
3193
3194     if (p->retry) {
3195         if (eof) {
3196             p->shut_on_empty = TRUE;
3197             b->eof     = TRUE;
3198             _ckvmssts(sys$dassgn(p->chan_in));
3199         } else  {
3200             _ckvmssts(iss);
3201         }
3202
3203         b->eof  = eof;
3204         b->size = p->iosb.count;
3205         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3206         if (p->need_wake) {
3207             p->need_wake = FALSE;
3208             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3209         }
3210     } else {
3211         p->retry = 1;   /* initial call */
3212     }
3213
3214     if (eof) {                  /* flush the free queue, return when done */
3215         int n = sizeof(CBuf) + p->bufsize;
3216         while (1) {
3217             iss = lib$remqti(&p->free, &b);
3218             if (iss == LIB$_QUEWASEMP) return;
3219             _ckvmssts(iss);
3220             _ckvmssts(lib$free_vm(&n, &b));
3221         }
3222     }
3223
3224     iss = lib$remqti(&p->free, &b);
3225     if (iss == LIB$_QUEWASEMP) {
3226         int n = sizeof(CBuf) + p->bufsize;
3227         _ckvmssts(lib$get_vm(&n, &b));
3228         b->buf = (char *) b + sizeof(CBuf);
3229     } else {
3230        _ckvmssts(iss);
3231     }
3232
3233     p->curr = b;
3234     iss = sys$qio(0,p->chan_in,
3235              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3236              &p->iosb,
3237              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3238     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3239     _ckvmssts(iss);
3240 }
3241
3242
3243 /* writes queued buffers to output, waits for each to complete before
3244    doing the next */
3245
3246 static void
3247 pipe_tochild2_ast(pPipe p)
3248 {
3249     pCBuf b = p->curr2;
3250     int iss = p->iosb2.status;
3251     int n = sizeof(CBuf) + p->bufsize;
3252     int done = (p->info && p->info->done) ||
3253               iss == SS$_CANCEL || iss == SS$_ABORT;
3254 #if defined(PERL_IMPLICIT_CONTEXT)
3255     pTHX = p->thx;
3256 #endif
3257
3258     do {
3259         if (p->type) {         /* type=1 has old buffer, dispose */
3260             if (p->shut_on_empty) {
3261                 _ckvmssts(lib$free_vm(&n, &b));
3262             } else {
3263                 _ckvmssts(lib$insqhi(b, &p->free));
3264             }
3265             p->type = 0;
3266         }
3267
3268         iss = lib$remqti(&p->wait, &b);
3269         if (iss == LIB$_QUEWASEMP) {
3270             if (p->shut_on_empty) {
3271                 if (done) {
3272                     _ckvmssts(sys$dassgn(p->chan_out));
3273                     *p->pipe_done = TRUE;
3274                     _ckvmssts(sys$setef(pipe_ef));
3275                 } else {
3276                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3277                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3278                 }
3279                 return;
3280             }
3281             p->need_wake = TRUE;
3282             return;
3283         }
3284         _ckvmssts(iss);
3285         p->type = 1;
3286     } while (done);
3287
3288
3289     p->curr2 = b;
3290     if (b->eof) {
3291         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3292             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3293     } else {
3294         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3295             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3296     }
3297
3298     return;
3299
3300 }
3301
3302
3303 static pPipe
3304 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3305 {
3306     pPipe p;
3307     char mbx1[64], mbx2[64];
3308     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3309                                       DSC$K_CLASS_S, mbx1},
3310                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3311                                       DSC$K_CLASS_S, mbx2};
3312     unsigned int dviitm = DVI$_DEVBUFSIZ;
3313
3314     int n = sizeof(Pipe);
3315     _ckvmssts(lib$get_vm(&n, &p));
3316     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3317     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3318
3319     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3320     n = p->bufsize * sizeof(char);
3321     _ckvmssts(lib$get_vm(&n, &p->buf));
3322     p->shut_on_empty = FALSE;
3323     p->info   = 0;
3324     p->type   = 0;
3325     p->iosb.status = SS$_NORMAL;
3326 #if defined(PERL_IMPLICIT_CONTEXT)
3327     p->thx = aTHX;
3328 #endif
3329     pipe_infromchild_ast(p);
3330
3331     strcpy(wmbx, mbx1);
3332     strcpy(rmbx, mbx2);
3333     return p;
3334 }
3335
3336 static void
3337 pipe_infromchild_ast(pPipe p)
3338 {
3339     int iss = p->iosb.status;
3340     int eof = (iss == SS$_ENDOFFILE);
3341     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3342     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3343 #if defined(PERL_IMPLICIT_CONTEXT)
3344     pTHX = p->thx;
3345 #endif
3346
3347     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3348         _ckvmssts(sys$dassgn(p->chan_out));
3349         p->chan_out = 0;
3350     }
3351
3352     /* read completed:
3353             input shutdown if EOF from self (done or shut_on_empty)
3354             output shutdown if closing flag set (my_pclose)
3355             send data/eof from child or eof from self
3356             otherwise, re-read (snarf of data from child)
3357     */
3358
3359     if (p->type == 1) {
3360         p->type = 0;
3361         if (myeof && p->chan_in) {                  /* input shutdown */
3362             _ckvmssts(sys$dassgn(p->chan_in));
3363             p->chan_in = 0;
3364         }
3365
3366         if (p->chan_out) {
3367             if (myeof || kideof) {      /* pass EOF to parent */
3368                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3369                               pipe_infromchild_ast, p,
3370                               0, 0, 0, 0, 0, 0));
3371                 return;
3372             } else if (eof) {       /* eat EOF --- fall through to read*/
3373
3374             } else {                /* transmit data */
3375                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3376                               pipe_infromchild_ast,p,
3377                               p->buf, p->iosb.count, 0, 0, 0, 0));
3378                 return;
3379             }
3380         }
3381     }
3382
3383     /*  everything shut? flag as done */
3384
3385     if (!p->chan_in && !p->chan_out) {
3386         *p->pipe_done = TRUE;
3387         _ckvmssts(sys$setef(pipe_ef));
3388         return;
3389     }
3390
3391     /* write completed (or read, if snarfing from child)
3392             if still have input active,
3393                queue read...immediate mode if shut_on_empty so we get EOF if empty
3394             otherwise,
3395                check if Perl reading, generate EOFs as needed
3396     */
3397
3398     if (p->type == 0) {
3399         p->type = 1;
3400         if (p->chan_in) {
3401             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3402                           pipe_infromchild_ast,p,
3403                           p->buf, p->bufsize, 0, 0, 0, 0);
3404             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3405             _ckvmssts(iss);
3406         } else {           /* send EOFs for extra reads */
3407             p->iosb.status = SS$_ENDOFFILE;
3408             p->iosb.dvispec = 0;
3409             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3410                       0, 0, 0,
3411                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3412         }
3413     }
3414 }
3415
3416 static pPipe
3417 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3418 {
3419     pPipe p;
3420     char mbx[64];
3421     unsigned long dviitm = DVI$_DEVBUFSIZ;
3422     struct stat s;
3423     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3424                                       DSC$K_CLASS_S, mbx};
3425     int n = sizeof(Pipe);
3426
3427     /* things like terminals and mbx's don't need this filter */
3428     if (fd && fstat(fd,&s) == 0) {
3429         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3430         char device[65];
3431         unsigned short dev_len;
3432         struct dsc$descriptor_s d_dev;
3433         char * cptr;
3434         struct item_list_3 items[3];
3435         int status;
3436         unsigned short dvi_iosb[4];
3437
3438         cptr = getname(fd, out, 1);
3439         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3440         d_dev.dsc$a_pointer = out;
3441         d_dev.dsc$w_length = strlen(out);
3442         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3443         d_dev.dsc$b_class = DSC$K_CLASS_S;
3444
3445         items[0].len = 4;
3446         items[0].code = DVI$_DEVCHAR;
3447         items[0].bufadr = &devchar;
3448         items[0].retadr = NULL;
3449         items[1].len = 64;
3450         items[1].code = DVI$_FULLDEVNAM;
3451         items[1].bufadr = device;
3452         items[1].retadr = &dev_len;
3453         items[2].len = 0;
3454         items[2].code = 0;
3455
3456         status = sys$getdviw
3457                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3458         _ckvmssts(status);
3459         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3460             device[dev_len] = 0;
3461
3462             if (!(devchar & DEV$M_DIR)) {
3463                 strcpy(out, device);
3464                 return 0;
3465             }
3466         }
3467     }
3468
3469     _ckvmssts(lib$get_vm(&n, &p));
3470     p->fd_out = dup(fd);
3471     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3472     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3473     n = (p->bufsize+1) * sizeof(char);
3474     _ckvmssts(lib$get_vm(&n, &p->buf));
3475     p->shut_on_empty = FALSE;
3476     p->retry = 0;
3477     p->info  = 0;
3478     strcpy(out, mbx);
3479
3480     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3481                   pipe_mbxtofd_ast, p,
3482                   p->buf, p->bufsize, 0, 0, 0, 0));
3483
3484     return p;
3485 }
3486
3487 static void
3488 pipe_mbxtofd_ast(pPipe p)
3489 {
3490     int iss = p->iosb.status;
3491     int done = p->info->done;
3492     int iss2;
3493     int eof = (iss == SS$_ENDOFFILE);
3494     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3495     int err = !(iss&1) && !eof;
3496 #if defined(PERL_IMPLICIT_CONTEXT)
3497     pTHX = p->thx;
3498 #endif
3499
3500     if (done && myeof) {               /* end piping */
3501         close(p->fd_out);
3502         sys$dassgn(p->chan_in);
3503         *p->pipe_done = TRUE;
3504         _ckvmssts(sys$setef(pipe_ef));
3505         return;
3506     }
3507
3508     if (!err && !eof) {             /* good data to send to file */
3509         p->buf[p->iosb.count] = '\n';
3510         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3511         if (iss2 < 0) {
3512             p->retry++;
3513             if (p->retry < MAX_RETRY) {
3514                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3515                 return;
3516             }
3517         }
3518         p->retry = 0;
3519     } else if (err) {
3520         _ckvmssts(iss);
3521     }
3522
3523
3524     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3525           pipe_mbxtofd_ast, p,
3526           p->buf, p->bufsize, 0, 0, 0, 0);
3527     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3528     _ckvmssts(iss);
3529 }
3530
3531
3532 typedef struct _pipeloc     PLOC;
3533 typedef struct _pipeloc*   pPLOC;
3534
3535 struct _pipeloc {
3536     pPLOC   next;
3537     char    dir[NAM$C_MAXRSS+1];
3538 };
3539 static pPLOC  head_PLOC = 0;
3540
3541 void
3542 free_pipelocs(pTHX_ void *head)
3543 {
3544     pPLOC p, pnext;
3545     pPLOC *pHead = (pPLOC *)head;
3546
3547     p = *pHead;
3548     while (p) {
3549         pnext = p->next;
3550         PerlMem_free(p);
3551         p = pnext;
3552     }
3553     *pHead = 0;
3554 }
3555
3556 static void
3557 store_pipelocs(pTHX)
3558 {
3559     int    i;
3560     pPLOC  p;
3561     AV    *av = 0;
3562     SV    *dirsv;
3563     GV    *gv;
3564     char  *dir, *x;
3565     char  *unixdir;
3566     char  temp[NAM$C_MAXRSS+1];
3567     STRLEN n_a;
3568
3569     if (head_PLOC)
3570         free_pipelocs(aTHX_ &head_PLOC);
3571
3572 /*  the . directory from @INC comes last */
3573
3574     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3575     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3576     p->next = head_PLOC;
3577     head_PLOC = p;
3578     strcpy(p->dir,"./");
3579
3580 /*  get the directory from $^X */
3581
3582     unixdir = PerlMem_malloc(VMS_MAXRSS);
3583     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3584
3585 #ifdef PERL_IMPLICIT_CONTEXT
3586     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3587 #else
3588     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3589 #endif
3590         strcpy(temp, PL_origargv[0]);
3591         x = strrchr(temp,']');
3592         if (x == NULL) {
3593         x = strrchr(temp,'>');
3594           if (x == NULL) {
3595             /* It could be a UNIX path */
3596             x = strrchr(temp,'/');
3597           }
3598         }
3599         if (x)
3600           x[1] = '\0';
3601         else {
3602           /* Got a bare name, so use default directory */
3603           temp[0] = '.';
3604           temp[1] = '\0';
3605         }
3606
3607         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3608             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3609             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3610             p->next = head_PLOC;
3611             head_PLOC = p;
3612             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3613             p->dir[NAM$C_MAXRSS] = '\0';
3614         }
3615     }
3616
3617 /*  reverse order of @INC entries, skip "." since entered above */
3618
3619 #ifdef PERL_IMPLICIT_CONTEXT
3620     if (aTHX)
3621 #endif
3622     if (PL_incgv) av = GvAVn(PL_incgv);
3623
3624     for (i = 0; av && i <= AvFILL(av); i++) {
3625         dirsv = *av_fetch(av,i,TRUE);
3626
3627         if (SvROK(dirsv)) continue;
3628         dir = SvPVx(dirsv,n_a);
3629         if (strcmp(dir,".") == 0) continue;
3630         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3631             continue;
3632
3633         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3634         p->next = head_PLOC;
3635         head_PLOC = p;
3636         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3637         p->dir[NAM$C_MAXRSS] = '\0';
3638     }
3639
3640 /* most likely spot (ARCHLIB) put first in the list */
3641
3642 #ifdef ARCHLIB_EXP
3643     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3644         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3645         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3646         p->next = head_PLOC;
3647         head_PLOC = p;
3648         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3649         p->dir[NAM$C_MAXRSS] = '\0';
3650     }
3651 #endif
3652     PerlMem_free(unixdir);
3653 }
3654
3655 static I32
3656 Perl_cando_by_name_int
3657    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3658 #if !defined(PERL_IMPLICIT_CONTEXT)
3659 #define cando_by_name_int               Perl_cando_by_name_int
3660 #else
3661 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3662 #endif
3663
3664 static char *
3665 find_vmspipe(pTHX)
3666 {
3667     static int   vmspipe_file_status = 0;
3668     static char  vmspipe_file[NAM$C_MAXRSS+1];
3669
3670     /* already found? Check and use ... need read+execute permission */
3671
3672     if (vmspipe_file_status == 1) {
3673         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3674          && cando_by_name_int
3675            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3676             return vmspipe_file;
3677         }
3678         vmspipe_file_status = 0;
3679     }
3680
3681     /* scan through stored @INC, $^X */
3682
3683     if (vmspipe_file_status == 0) {
3684         char file[NAM$C_MAXRSS+1];
3685         pPLOC  p = head_PLOC;
3686
3687         while (p) {
3688             char * exp_res;
3689             int dirlen;
3690             strcpy(file, p->dir);
3691             dirlen = strlen(file);
3692             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3693             file[NAM$C_MAXRSS] = '\0';
3694             p = p->next;
3695
3696             exp_res = do_rmsexpand
3697                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3698             if (!exp_res) continue;
3699
3700             if (cando_by_name_int
3701                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3702              && cando_by_name_int
3703                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3704                 vmspipe_file_status = 1;
3705                 return vmspipe_file;
3706             }
3707         }
3708         vmspipe_file_status = -1;   /* failed, use tempfiles */
3709     }
3710
3711     return 0;
3712 }
3713
3714 static FILE *
3715 vmspipe_tempfile(pTHX)
3716 {
3717     char file[NAM$C_MAXRSS+1];
3718     FILE *fp;
3719     static int index = 0;
3720     Stat_t s0, s1;
3721     int cmp_result;
3722
3723     /* create a tempfile */
3724
3725     /* we can't go from   W, shr=get to  R, shr=get without
3726        an intermediate vulnerable state, so don't bother trying...
3727
3728        and lib$spawn doesn't shr=put, so have to close the write
3729
3730        So... match up the creation date/time and the FID to
3731        make sure we're dealing with the same file
3732
3733     */
3734
3735     index++;
3736     if (!decc_filename_unix_only) {
3737       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3738       fp = fopen(file,"w");
3739       if (!fp) {
3740         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3741         fp = fopen(file,"w");
3742         if (!fp) {
3743             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3744             fp = fopen(file,"w");
3745         }
3746       }
3747      }
3748      else {
3749       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3750       fp = fopen(file,"w");
3751       if (!fp) {
3752         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3753         fp = fopen(file,"w");
3754         if (!fp) {
3755           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3756           fp = fopen(file,"w");
3757         }
3758       }
3759     }
3760     if (!fp) return 0;  /* we're hosed */
3761
3762     fprintf(fp,"$! 'f$verify(0)'\n");
3763     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3764     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3765     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3766     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3767     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3768     fprintf(fp,"$ perl_del    = \"delete\"\n");
3769     fprintf(fp,"$ pif         = \"if\"\n");
3770     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3771     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3772     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3773     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3774     fprintf(fp,"$!  --- build command line to get max possible length\n");
3775     fprintf(fp,"$c=perl_popen_cmd0\n");
3776     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3777     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3778     fprintf(fp,"$x=perl_popen_cmd3\n");
3779     fprintf(fp,"$c=c+x\n");
3780     fprintf(fp,"$ perl_on\n");
3781     fprintf(fp,"$ 'c'\n");
3782     fprintf(fp,"$ perl_status = $STATUS\n");
3783     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3784     fprintf(fp,"$ perl_exit 'perl_status'\n");
3785     fsync(fileno(fp));
3786
3787     fgetname(fp, file, 1);
3788     fstat(fileno(fp), (struct stat *)&s0);
3789     fclose(fp);
3790
3791     if (decc_filename_unix_only)
3792         do_tounixspec(file, file, 0, NULL);
3793     fp = fopen(file,"r","shr=get");
3794     if (!fp) return 0;
3795     fstat(fileno(fp), (struct stat *)&s1);
3796
3797     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3798     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3799         fclose(fp);
3800         return 0;
3801     }
3802
3803     return fp;
3804 }
3805
3806
3807 static int vms_is_syscommand_xterm(void)
3808 {
3809     const static struct dsc$descriptor_s syscommand_dsc =
3810       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3811
3812     const static struct dsc$descriptor_s decwdisplay_dsc =
3813       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3814
3815     struct item_list_3 items[2];
3816     unsigned short dvi_iosb[4];
3817     unsigned long devchar;
3818     unsigned long devclass;
3819     int status;
3820
3821     /* Very simple check to guess if sys$command is a decterm? */
3822     /* First see if the DECW$DISPLAY: device exists */
3823     items[0].len = 4;
3824     items[0].code = DVI$_DEVCHAR;
3825     items[0].bufadr = &devchar;
3826     items[0].retadr = NULL;
3827     items[1].len = 0;
3828     items[1].code = 0;
3829
3830     status = sys$getdviw
3831         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3832
3833     if ($VMS_STATUS_SUCCESS(status)) {
3834         status = dvi_iosb[0];
3835     }
3836
3837     if (!$VMS_STATUS_SUCCESS(status)) {
3838         SETERRNO(EVMSERR, status);
3839         return -1;
3840     }
3841
3842     /* If it does, then for now assume that we are on a workstation */
3843     /* Now verify that SYS$COMMAND is a terminal */
3844     /* for creating the debugger DECTerm */
3845
3846     items[0].len = 4;
3847     items[0].code = DVI$_DEVCLASS;
3848     items[0].bufadr = &devclass;
3849     items[0].retadr = NULL;
3850     items[1].len = 0;
3851     items[1].code = 0;
3852
3853     status = sys$getdviw
3854         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3855
3856     if ($VMS_STATUS_SUCCESS(status)) {
3857         status = dvi_iosb[0];
3858     }
3859
3860     if (!$VMS_STATUS_SUCCESS(status)) {
3861         SETERRNO(EVMSERR, status);
3862         return -1;
3863     }
3864     else {
3865         if (devclass == DC$_TERM) {
3866             return 0;
3867         }
3868     }
3869     return -1;
3870 }
3871
3872 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3873 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3874 {
3875     int status;
3876     int ret_stat;
3877     char * ret_char;
3878     char device_name[65];
3879     unsigned short device_name_len;
3880     struct dsc$descriptor_s customization_dsc;
3881     struct dsc$descriptor_s device_name_dsc;
3882     const char * cptr;
3883     char * tptr;
3884     char customization[200];
3885     char title[40];
3886     pInfo info = NULL;
3887     char mbx1[64];
3888     unsigned short p_chan;
3889     int n;
3890     unsigned short iosb[4];
3891     struct item_list_3 items[2];
3892     const char * cust_str =
3893         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3894     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3895                                           DSC$K_CLASS_S, mbx1};
3896
3897      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3898     /*---------------------------------------*/
3899     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3900
3901
3902     /* Make sure that this is from the Perl debugger */
3903     ret_char = strstr(cmd," xterm ");
3904     if (ret_char == NULL)
3905         return NULL;
3906     cptr = ret_char + 7;
3907     ret_char = strstr(cmd,"tty");
3908     if (ret_char == NULL)
3909         return NULL;
3910     ret_char = strstr(cmd,"sleep");
3911     if (ret_char == NULL)
3912         return NULL;
3913
3914     if (decw_term_port == 0) {
3915         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3916         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3917         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3918
3919        status = lib$find_image_symbol
3920                                (&filename1_dsc,
3921                                 &decw_term_port_dsc,
3922                                 (void *)&decw_term_port,
3923                                 NULL,
3924                                 0);
3925
3926         /* Try again with the other image name */
3927         if (!$VMS_STATUS_SUCCESS(status)) {
3928
3929            status = lib$find_image_symbol
3930                                (&filename2_dsc,
3931                                 &decw_term_port_dsc,
3932                                 (void *)&decw_term_port,
3933                                 NULL,
3934                                 0);
3935
3936         }
3937
3938     }
3939
3940
3941     /* No decw$term_port, give it up */
3942     if (!$VMS_STATUS_SUCCESS(status))
3943         return NULL;
3944
3945     /* Are we on a workstation? */
3946     /* to do: capture the rows / columns and pass their properties */
3947     ret_stat = vms_is_syscommand_xterm();
3948     if (ret_stat < 0)
3949         return NULL;
3950
3951     /* Make the title: */
3952     ret_char = strstr(cptr,"-title");
3953     if (ret_char != NULL) {
3954         while ((*cptr != 0) && (*cptr != '\"')) {
3955             cptr++;
3956         }
3957         if (*cptr == '\"')
3958             cptr++;
3959         n = 0;
3960         while ((*cptr != 0) && (*cptr != '\"')) {
3961             title[n] = *cptr;
3962             n++;
3963             if (n == 39) {
3964                 title[39] == 0;
3965                 break;
3966             }
3967             cptr++;
3968         }
3969         title[n] = 0;
3970     }
3971     else {
3972             /* Default title */
3973             strcpy(title,"Perl Debug DECTerm");
3974     }
3975     sprintf(customization, cust_str, title);
3976
3977     customization_dsc.dsc$a_pointer = customization;
3978     customization_dsc.dsc$w_length = strlen(customization);
3979     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3980     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3981
3982     device_name_dsc.dsc$a_pointer = device_name;
3983     device_name_dsc.dsc$w_length = sizeof device_name -1;
3984     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3985     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3986
3987     device_name_len = 0;
3988
3989     /* Try to create the window */
3990      status = (*decw_term_port)
3991        (NULL,
3992         NULL,
3993         &customization_dsc,
3994         &device_name_dsc,
3995         &device_name_len,
3996         NULL,
3997         NULL,
3998         NULL);
3999     if (!$VMS_STATUS_SUCCESS(status)) {
4000         SETERRNO(EVMSERR, status);
4001         return NULL;
4002     }
4003
4004     device_name[device_name_len] = '\0';
4005
4006     /* Need to set this up to look like a pipe for cleanup */
4007     n = sizeof(Info);
4008     status = lib$get_vm(&n, &info);
4009     if (!$VMS_STATUS_SUCCESS(status)) {
4010         SETERRNO(ENOMEM, status);
4011         return NULL;
4012     }
4013
4014     info->mode = *mode;
4015     info->done = FALSE;
4016     info->completion = 0;
4017     info->closing    = FALSE;
4018     info->in         = 0;
4019     info->out        = 0;
4020     info->err        = 0;
4021     info->fp         = NULL;
4022     info->useFILE    = 0;
4023     info->waiting    = 0;
4024     info->in_done    = TRUE;
4025     info->out_done   = TRUE;
4026     info->err_done   = TRUE;
4027
4028     /* Assign a channel on this so that it will persist, and not login */
4029     /* We stash this channel in the info structure for reference. */
4030     /* The created xterm self destructs when the last channel is removed */
4031     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4032     /* So leave this assigned. */
4033     device_name_dsc.dsc$w_length = device_name_len;
4034     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4035     if (!$VMS_STATUS_SUCCESS(status)) {
4036         SETERRNO(EVMSERR, status);
4037         return NULL;
4038     }
4039     info->xchan_valid = 1;
4040
4041     /* Now create a mailbox to be read by the application */
4042
4043     create_mbx(aTHX_ &p_chan, &d_mbx1);
4044
4045     /* write the name of the created terminal to the mailbox */
4046     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4047             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4048
4049     if (!$VMS_STATUS_SUCCESS(status)) {
4050         SETERRNO(EVMSERR, status);
4051         return NULL;
4052     }
4053
4054     info->fp  = PerlIO_open(mbx1, mode);
4055
4056     /* Done with this channel */
4057     sys$dassgn(p_chan);
4058
4059     /* If any errors, then clean up */
4060     if (!info->fp) {
4061         n = sizeof(Info);
4062         _ckvmssts(lib$free_vm(&n, &info));
4063         return NULL;
4064         }
4065
4066     /* All done */
4067     return info->fp;
4068 }
4069
4070 static PerlIO *
4071 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4072 {
4073     static int handler_set_up = FALSE;
4074     unsigned long int sts, flags = CLI$M_NOWAIT;
4075     /* The use of a GLOBAL table (as was done previously) rendered
4076      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4077      * environment.  Hence we've switched to LOCAL symbol table.
4078      */
4079     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4080     int j, wait = 0, n;
4081     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4082     char *in, *out, *err, mbx[512];
4083     FILE *tpipe = 0;
4084     char tfilebuf[NAM$C_MAXRSS+1];
4085     pInfo info = NULL;
4086     char cmd_sym_name[20];
4087     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4088                                       DSC$K_CLASS_S, symbol};
4089     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4090                                       DSC$K_CLASS_S, 0};
4091     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4092                                       DSC$K_CLASS_S, cmd_sym_name};
4093     struct dsc$descriptor_s *vmscmd;
4094     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4095     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4096     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4097
4098     /* Check here for Xterm create request.  This means looking for
4099      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4100      *  is possible to create an xterm.
4101      */
4102     if (*in_mode == 'r') {
4103         PerlIO * xterm_fd;
4104
4105         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4106         if (xterm_fd != NULL)
4107             return xterm_fd;
4108     }
4109
4110     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4111
4112     /* once-per-program initialization...
4113        note that the SETAST calls and the dual test of pipe_ef
4114        makes sure that only the FIRST thread through here does
4115        the initialization...all other threads wait until it's
4116        done.
4117
4118        Yeah, uglier than a pthread call, it's got all the stuff inline
4119        rather than in a separate routine.
4120     */
4121
4122     if (!pipe_ef) {
4123         _ckvmssts(sys$setast(0));
4124         if (!pipe_ef) {
4125             unsigned long int pidcode = JPI$_PID;
4126             $DESCRIPTOR(d_delay, RETRY_DELAY);
4127             _ckvmssts(lib$get_ef(&pipe_ef));
4128             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4129             _ckvmssts(sys$bintim(&d_delay, delaytime));
4130         }
4131         if (!handler_set_up) {
4132           _ckvmssts(sys$dclexh(&pipe_exitblock));
4133           handler_set_up = TRUE;
4134         }
4135         _ckvmssts(sys$setast(1));
4136     }
4137
4138     /* see if we can find a VMSPIPE.COM */
4139
4140     tfilebuf[0] = '@';
4141     vmspipe = find_vmspipe(aTHX);
4142     if (vmspipe) {
4143         strcpy(tfilebuf+1,vmspipe);
4144     } else {        /* uh, oh...we're in tempfile hell */
4145         tpipe = vmspipe_tempfile(aTHX);
4146         if (!tpipe) {       /* a fish popular in Boston */
4147             if (ckWARN(WARN_PIPE)) {
4148                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4149             }
4150         return NULL;
4151         }
4152         fgetname(tpipe,tfilebuf+1,1);
4153     }
4154     vmspipedsc.dsc$a_pointer = tfilebuf;
4155     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4156
4157     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4158     if (!(sts & 1)) {
4159       switch (sts) {
4160         case RMS$_FNF:  case RMS$_DNF:
4161           set_errno(ENOENT); break;
4162         case RMS$_DIR:
4163           set_errno(ENOTDIR); break;
4164         case RMS$_DEV:
4165           set_errno(ENODEV); break;
4166         case RMS$_PRV:
4167           set_errno(EACCES); break;
4168         case RMS$_SYN:
4169           set_errno(EINVAL); break;
4170         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4171           set_errno(E2BIG); break;
4172         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4173           _ckvmssts(sts); /* fall through */
4174         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4175           set_errno(EVMSERR);
4176       }
4177       set_vaxc_errno(sts);
4178       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4179         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4180       }
4181       *psts = sts;
4182       return NULL;
4183     }
4184     n = sizeof(Info);
4185     _ckvmssts(lib$get_vm(&n, &info));
4186
4187     strcpy(mode,in_mode);
4188     info->mode = *mode;
4189     info->done = FALSE;
4190     info->completion = 0;
4191     info->closing    = FALSE;
4192     info->in         = 0;
4193     info->out        = 0;
4194     info->err        = 0;
4195     info->fp         = NULL;
4196     info->useFILE    = 0;
4197     info->waiting    = 0;
4198     info->in_done    = TRUE;
4199     info->out_done   = TRUE;
4200     info->err_done   = TRUE;
4201     info->xchan      = 0;
4202     info->xchan_valid = 0;
4203
4204     in = PerlMem_malloc(VMS_MAXRSS);
4205     if (in == NULL) _ckvmssts(SS$_INSFMEM);
4206     out = PerlMem_malloc(VMS_MAXRSS);
4207     if (out == NULL) _ckvmssts(SS$_INSFMEM);
4208     err = PerlMem_malloc(VMS_MAXRSS);
4209     if (err == NULL) _ckvmssts(SS$_INSFMEM);
4210
4211     in[0] = out[0] = err[0] = '\0';
4212
4213     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4214         info->useFILE = 1;
4215         strcpy(p,p+1);
4216     }
4217     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4218         wait = 1;
4219         strcpy(p,p+1);
4220     }
4221
4222     if (*mode == 'r') {             /* piping from subroutine */
4223
4224         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4225         if (info->out) {
4226             info->out->pipe_done = &info->out_done;
4227             info->out_done = FALSE;
4228             info->out->info = info;
4229         }
4230         if (!info->useFILE) {
4231             info->fp  = PerlIO_open(mbx, mode);
4232         } else {
4233             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4234             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4235         }
4236
4237         if (!info->fp && info->out) {
4238             sys$cancel(info->out->chan_out);
4239
4240             while (!info->out_done) {
4241                 int done;
4242                 _ckvmssts(sys$setast(0));
4243                 done = info->out_done;
4244                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4245                 _ckvmssts(sys$setast(1));
4246                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4247             }
4248
4249             if (info->out->buf) {
4250                 n = info->out->bufsize * sizeof(char);
4251                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4252             }
4253             n = sizeof(Pipe);
4254             _ckvmssts(lib$free_vm(&n, &info->out));
4255             n = sizeof(Info);
4256             _ckvmssts(lib$free_vm(&n, &info));
4257             *psts = RMS$_FNF;
4258             return NULL;
4259         }
4260
4261         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4262         if (info->err) {
4263             info->err->pipe_done = &info->err_done;
4264             info->err_done = FALSE;
4265             info->err->info = info;
4266         }
4267
4268     } else if (*mode == 'w') {      /* piping to subroutine */
4269
4270         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4271         if (info->out) {
4272             info->out->pipe_done = &info->out_done;
4273             info->out_done = FALSE;
4274             info->out->info = info;
4275         }
4276
4277         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4278         if (info->err) {
4279             info->err->pipe_done = &info->err_done;
4280             info->err_done = FALSE;
4281             info->err->info = info;
4282         }
4283
4284         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4285         if (!info->useFILE) {
4286             info->fp  = PerlIO_open(mbx, mode);
4287         } else {
4288             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4289             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4290         }
4291
4292         if (info->in) {
4293             info->in->pipe_done = &info->in_done;
4294             info->in_done = FALSE;
4295             info->in->info = info;
4296         }
4297
4298         /* error cleanup */
4299         if (!info->fp && info->in) {
4300             info->done = TRUE;
4301             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4302                               0, 0, 0, 0, 0, 0, 0, 0));
4303
4304             while (!info->in_done) {
4305                 int done;
4306                 _ckvmssts(sys$setast(0));
4307                 done = info->in_done;
4308                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4309                 _ckvmssts(sys$setast(1));
4310                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4311             }
4312
4313             if (info->in->buf) {
4314                 n = info->in->bufsize * sizeof(char);
4315                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4316             }
4317             n = sizeof(Pipe);
4318             _ckvmssts(lib$free_vm(&n, &info->in));
4319             n = sizeof(Info);
4320             _ckvmssts(lib$free_vm(&n, &info));
4321             *psts = RMS$_FNF;
4322             return NULL;
4323         }
4324
4325
4326     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4327         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4328         if (info->out) {
4329             info->out->pipe_done = &info->out_done;
4330             info->out_done = FALSE;
4331             info->out->info = info;
4332         }
4333
4334         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4335         if (info->err) {
4336             info->err->pipe_done = &info->err_done;
4337             info->err_done = FALSE;
4338             info->err->info = info;
4339         }
4340     }
4341
4342     symbol[MAX_DCL_SYMBOL] = '\0';
4343
4344     strncpy(symbol, in, MAX_DCL_SYMBOL);
4345     d_symbol.dsc$w_length = strlen(symbol);
4346     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4347
4348     strncpy(symbol, err, MAX_DCL_SYMBOL);
4349     d_symbol.dsc$w_length = strlen(symbol);
4350     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4351
4352     strncpy(symbol, out, MAX_DCL_SYMBOL);
4353     d_symbol.dsc$w_length = strlen(symbol);
4354     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4355
4356     /* Done with the names for the pipes */
4357     PerlMem_free(err);
4358     PerlMem_free(out);
4359     PerlMem_free(in);
4360
4361     p = vmscmd->dsc$a_pointer;
4362     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4363     if (*p == '$') p++;                         /* remove leading $ */
4364     while (*p == ' ' || *p == '\t') p++;
4365
4366     for (j = 0; j < 4; j++) {
4367         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4368         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4369
4370     strncpy(symbol, p, MAX_DCL_SYMBOL);
4371     d_symbol.dsc$w_length = strlen(symbol);
4372     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4373
4374         if (strlen(p) > MAX_DCL_SYMBOL) {
4375             p += MAX_DCL_SYMBOL;
4376         } else {
4377             p += strlen(p);
4378         }
4379     }
4380     _ckvmssts(sys$setast(0));
4381     info->next=open_pipes;  /* prepend to list */
4382     open_pipes=info;
4383     _ckvmssts(sys$setast(1));
4384     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4385      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4386      * have SYS$COMMAND if we need it.
4387      */
4388     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4389                       0, &info->pid, &info->completion,
4390                       0, popen_completion_ast,info,0,0,0));
4391
4392     /* if we were using a tempfile, close it now */
4393
4394     if (tpipe) fclose(tpipe);
4395
4396     /* once the subprocess is spawned, it has copied the symbols and
4397        we can get rid of ours */
4398
4399     for (j = 0; j < 4; j++) {
4400         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4401         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4402     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4403     }
4404     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4405     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4406     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4407     vms_execfree(vmscmd);
4408
4409 #ifdef PERL_IMPLICIT_CONTEXT
4410     if (aTHX)
4411 #endif
4412     PL_forkprocess = info->pid;
4413
4414     if (wait) {
4415          int done = 0;
4416          while (!done) {
4417              _ckvmssts(sys$setast(0));
4418              done = info->done;
4419              if (!done) _ckvmssts(sys$clref(pipe_ef));
4420              _ckvmssts(sys$setast(1));
4421              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4422          }
4423         *psts = info->completion;
4424 /* Caller thinks it is open and tries to close it. */
4425 /* This causes some problems, as it changes the error status */
4426 /*        my_pclose(info->fp); */
4427     } else {
4428         *psts = info->pid;
4429     }
4430     return info->fp;
4431 }  /* end of safe_popen */
4432
4433
4434 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4435 PerlIO *
4436 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4437 {
4438     int sts;
4439     TAINT_ENV();
4440     TAINT_PROPER("popen");
4441     PERL_FLUSHALL_FOR_CHILD;
4442     return safe_popen(aTHX_ cmd,mode,&sts);
4443 }
4444
4445 /*}}}*/
4446
4447 /*{{{  I32 my_pclose(PerlIO *fp)*/
4448 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4449 {
4450     pInfo info, last = NULL;
4451     unsigned long int retsts;
4452     int done, iss, n;
4453     int status;
4454
4455     for (info = open_pipes; info != NULL; last = info, info = info->next)
4456         if (info->fp == fp) break;
4457
4458     if (info == NULL) {  /* no such pipe open */
4459       set_errno(ECHILD); /* quoth POSIX */
4460       set_vaxc_errno(SS$_NONEXPR);
4461       return -1;
4462     }
4463
4464     /* If we were writing to a subprocess, insure that someone reading from
4465      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4466      * produce an EOF record in the mailbox.
4467      *
4468      *  well, at least sometimes it *does*, so we have to watch out for
4469      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4470      */
4471      if (info->fp) {
4472         if (!info->useFILE
4473 #if defined(USE_ITHREADS)
4474           && my_perl
4475 #endif
4476           && PL_perlio_fd_refcnt)
4477             PerlIO_flush(info->fp);
4478         else
4479             fflush((FILE *)info->fp);
4480     }
4481
4482     _ckvmssts(sys$setast(0));
4483      info->closing = TRUE;
4484      done = info->done && info->in_done && info->out_done && info->err_done;
4485      /* hanging on write to Perl's input? cancel it */
4486      if (info->mode == 'r' && info->out && !info->out_done) {
4487         if (info->out->chan_out) {
4488             _ckvmssts(sys$cancel(info->out->chan_out));
4489             if (!info->out->chan_in) {   /* EOF generation, need AST */
4490                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4491             }
4492         }
4493      }
4494      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4495          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4496                            0, 0, 0, 0, 0, 0));
4497     _ckvmssts(sys$setast(1));
4498     if (info->fp) {
4499      if (!info->useFILE
4500 #if defined(USE_ITHREADS)
4501          && my_perl
4502 #endif
4503          && PL_perlio_fd_refcnt)
4504         PerlIO_close(info->fp);
4505      else
4506         fclose((FILE *)info->fp);
4507     }
4508      /*
4509         we have to wait until subprocess completes, but ALSO wait until all
4510         the i/o completes...otherwise we'll be freeing the "info" structure
4511         that the i/o ASTs could still be using...
4512      */
4513
4514      while (!done) {
4515          _ckvmssts(sys$setast(0));
4516          done = info->done && info->in_done && info->out_done && info->err_done;
4517          if (!done) _ckvmssts(sys$clref(pipe_ef));
4518          _ckvmssts(sys$setast(1));
4519          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4520      }
4521      retsts = info->completion;
4522
4523     /* remove from list of open pipes */
4524     _ckvmssts(sys$setast(0));
4525     if (last) last->next = info->next;
4526     else open_pipes = info->next;
4527     _ckvmssts(sys$setast(1));
4528
4529     /* free buffers and structures */
4530
4531     if (info->in) {
4532         if (info->in->buf) {
4533             n = info->in->bufsize * sizeof(char);
4534             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4535         }
4536         n = sizeof(Pipe);
4537         _ckvmssts(lib$free_vm(&n, &info->in));
4538     }
4539     if (info->out) {
4540         if (info->out->buf) {
4541             n = info->out->bufsize * sizeof(char);
4542             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4543         }
4544         n = sizeof(Pipe);
4545         _ckvmssts(lib$free_vm(&n, &info->out));
4546     }
4547     if (info->err) {
4548         if (info->err->buf) {
4549             n = info->err->bufsize * sizeof(char);
4550             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4551         }
4552         n = sizeof(Pipe);
4553         _ckvmssts(lib$free_vm(&n, &info->err));
4554     }
4555     n = sizeof(Info);
4556     _ckvmssts(lib$free_vm(&n, &info));
4557
4558     return retsts;
4559
4560 }  /* end of my_pclose() */
4561
4562 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4563   /* Roll our own prototype because we want this regardless of whether
4564    * _VMS_WAIT is defined.
4565    */
4566   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4567 #endif
4568 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4569    created with popen(); otherwise partially emulate waitpid() unless
4570    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4571    Also check processes not considered by the CRTL waitpid().
4572  */
4573 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4574 Pid_t
4575 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4576 {
4577     pInfo info;
4578     int done;
4579     int sts;
4580     int j;
4581
4582     if (statusp) *statusp = 0;
4583
4584     for (info = open_pipes; info != NULL; info = info->next)
4585         if (info->pid == pid) break;
4586
4587     if (info != NULL) {  /* we know about this child */
4588       while (!info->done) {
4589           _ckvmssts(sys$setast(0));
4590           done = info->done;
4591           if (!done) _ckvmssts(sys$clref(pipe_ef));
4592           _ckvmssts(sys$setast(1));
4593           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4594       }
4595
4596       if (statusp) *statusp = info->completion;
4597       return pid;
4598     }
4599
4600     /* child that already terminated? */
4601
4602     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4603         if (closed_list[j].pid == pid) {
4604             if (statusp) *statusp = closed_list[j].completion;
4605             return pid;
4606         }
4607     }
4608
4609     /* fall through if this child is not one of our own pipe children */
4610
4611 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4612
4613       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4614        * in 7.2 did we get a version that fills in the VMS completion
4615        * status as Perl has always tried to do.
4616        */
4617
4618       sts = __vms_waitpid( pid, statusp, flags );
4619
4620       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4621          return sts;
4622
4623       /* If the real waitpid tells us the child does not exist, we
4624        * fall through here to implement waiting for a child that
4625        * was created by some means other than exec() (say, spawned
4626        * from DCL) or to wait for a process that is not a subprocess
4627        * of the current process.
4628        */
4629
4630 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4631
4632     {
4633       $DESCRIPTOR(intdsc,"0 00:00:01");
4634       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4635       unsigned long int pidcode = JPI$_PID, mypid;
4636       unsigned long int interval[2];
4637       unsigned int jpi_iosb[2];
4638       struct itmlst_3 jpilist[2] = {
4639           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4640           {                      0,         0,                 0, 0}
4641       };
4642
4643       if (pid <= 0) {
4644         /* Sorry folks, we don't presently implement rooting around for
4645            the first child we can find, and we definitely don't want to
4646            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4647          */
4648         set_errno(ENOTSUP);
4649         return -1;
4650       }
4651
4652       /* Get the owner of the child so I can warn if it's not mine. If the
4653        * process doesn't exist or I don't have the privs to look at it,
4654        * I can go home early.
4655        */
4656       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4657       if (sts & 1) sts = jpi_iosb[0];
4658       if (!(sts & 1)) {
4659         switch (sts) {
4660             case SS$_NONEXPR:
4661                 set_errno(ECHILD);
4662                 break;
4663             case SS$_NOPRIV:
4664                 set_errno(EACCES);
4665                 break;
4666             default:
4667                 _ckvmssts(sts);
4668         }
4669         set_vaxc_errno(sts);
4670         return -1;
4671       }
4672
4673       if (ckWARN(WARN_EXEC)) {
4674         /* remind folks they are asking for non-standard waitpid behavior */
4675         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4676         if (ownerpid != mypid)
4677           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4678                       "waitpid: process %x is not a child of process %x",
4679                       pid,mypid);
4680       }
4681
4682       /* simply check on it once a second until it's not there anymore. */
4683
4684       _ckvmssts(sys$bintim(&intdsc,interval));
4685       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4686             _ckvmssts(sys$schdwk(0,0,interval,0));
4687             _ckvmssts(sys$hiber());
4688       }
4689       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4690
4691       _ckvmssts(sts);
4692       return pid;
4693     }
4694 }  /* end of waitpid() */
4695 /*}}}*/
4696 /*}}}*/
4697 /*}}}*/
4698
4699 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4700 char *
4701 my_gconvert(double val, int ndig, int trail, char *buf)
4702 {
4703   static char __gcvtbuf[DBL_DIG+1];
4704   char *loc;
4705
4706   loc = buf ? buf : __gcvtbuf;
4707
4708 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4709   if (val < 1) {
4710     sprintf(loc,"%.*g",ndig,val);
4711     return loc;
4712   }
4713 #endif
4714
4715   if (val) {
4716     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4717     return gcvt(val,ndig,loc);
4718   }
4719   else {
4720     loc[0] = '0'; loc[1] = '\0';
4721     return loc;
4722   }
4723
4724 }
4725 /*}}}*/
4726
4727 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4728 static int rms_free_search_context(struct FAB * fab)
4729 {
4730 struct NAM * nam;
4731
4732     nam = fab->fab$l_nam;
4733     nam->nam$b_nop |= NAM$M_SYNCHK;
4734     nam->nam$l_rlf = NULL;
4735     fab->fab$b_dns = 0;
4736     return sys$parse(fab, NULL, NULL);
4737 }
4738
4739 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4740 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4741 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4742 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4743 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4744 #define rms_nam_esll(nam) nam.nam$b_esl
4745 #define rms_nam_esl(nam) nam.nam$b_esl
4746 #define rms_nam_name(nam) nam.nam$l_name
4747 #define rms_nam_namel(nam) nam.nam$l_name
4748 #define rms_nam_type(nam) nam.nam$l_type
4749 #define rms_nam_typel(nam) nam.nam$l_type
4750 #define rms_nam_ver(nam) nam.nam$l_ver
4751 #define rms_nam_verl(nam) nam.nam$l_ver
4752 #define rms_nam_rsll(nam) nam.nam$b_rsl
4753 #define rms_nam_rsl(nam) nam.nam$b_rsl
4754 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4755 #define rms_set_fna(fab, nam, name, size) \
4756         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4757 #define rms_get_fna(fab, nam) fab.fab$l_fna
4758 #define rms_set_dna(fab, nam, name, size) \
4759         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4760 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4761 #define rms_set_esa(nam, name, size) \
4762         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4763 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4764         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4765 #define rms_set_rsa(nam, name, size) \
4766         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4767 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4768         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4769 #define rms_nam_name_type_l_size(nam) \
4770         (nam.nam$b_name + nam.nam$b_type)
4771 #else
4772 static int rms_free_search_context(struct FAB * fab)
4773 {
4774 struct NAML * nam;
4775
4776     nam = fab->fab$l_naml;
4777     nam->naml$b_nop |= NAM$M_SYNCHK;
4778     nam->naml$l_rlf = NULL;
4779     nam->naml$l_long_defname_size = 0;
4780
4781     fab->fab$b_dns = 0;
4782     return sys$parse(fab, NULL, NULL);
4783 }
4784
4785 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4786 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4787 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4788 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4789 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4790 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4791 #define rms_nam_esl(nam) nam.naml$b_esl
4792 #define rms_nam_name(nam) nam.naml$l_name
4793 #define rms_nam_namel(nam) nam.naml$l_long_name
4794 #define rms_nam_type(nam) nam.naml$l_type
4795 #define rms_nam_typel(nam) nam.naml$l_long_type
4796 #define rms_nam_ver(nam) nam.naml$l_ver
4797 #define rms_nam_verl(nam) nam.naml$l_long_ver
4798 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4799 #define rms_nam_rsl(nam) nam.naml$b_rsl
4800 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4801 #define rms_set_fna(fab, nam, name, size) \
4802         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4803         nam.naml$l_long_filename_size = size; \
4804         nam.naml$l_long_filename = name;}
4805 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4806 #define rms_set_dna(fab, nam, name, size) \
4807         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4808         nam.naml$l_long_defname_size = size; \
4809         nam.naml$l_long_defname = name; }
4810 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4811 #define rms_set_esa(nam, name, size) \
4812         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4813         nam.naml$l_long_expand_alloc = size; \
4814         nam.naml$l_long_expand = name; }
4815 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4816         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4817         nam.naml$l_long_expand = l_name; \
4818         nam.naml$l_long_expand_alloc = l_size; }
4819 #define rms_set_rsa(nam, name, size) \
4820         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4821         nam.naml$l_long_result = name; \
4822         nam.naml$l_long_result_alloc = size; }
4823 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4824         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4825         nam.naml$l_long_result = l_name; \
4826         nam.naml$l_long_result_alloc = l_size; }
4827 #define rms_nam_name_type_l_size(nam) \
4828         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4829 #endif
4830
4831
4832 /* rms_erase
4833  * The CRTL for 8.3 and later can create symbolic links in any mode,
4834  * however in 8.3 the unlink/remove/delete routines will only properly handle
4835  * them if one of the PCP modes is active.
4836  */
4837 static int rms_erase(const char * vmsname)
4838 {
4839   int status;
4840   struct FAB myfab = cc$rms_fab;
4841   rms_setup_nam(mynam);
4842
4843   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4844   rms_bind_fab_nam(myfab, mynam);
4845
4846   /* Are we removing all versions? */
4847   if (vms_unlink_all_versions == 1) {
4848     const char * defspec = ";*";
4849     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4850   }
4851
4852 #ifdef NAML$M_OPEN_SPECIAL
4853   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4854 #endif
4855
4856   status = sys$erase(&myfab, 0, 0);
4857
4858   return status;
4859 }
4860
4861
4862 static int
4863 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4864                     const struct dsc$descriptor_s * vms_dst_dsc,
4865                     unsigned long flags)
4866 {
4867     /*  VMS and UNIX handle file permissions differently and the
4868      * the same ACL trick may be needed for renaming files,
4869      * especially if they are directories.
4870      */
4871
4872    /* todo: get kill_file and rename to share common code */
4873    /* I can not find online documentation for $change_acl
4874     * it appears to be replaced by $set_security some time ago */
4875
4876 const unsigned int access_mode = 0;
4877 $DESCRIPTOR(obj_file_dsc,"FILE");
4878 char *vmsname;
4879 char *rslt;
4880 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
4881 int aclsts, fndsts, rnsts = -1;
4882 unsigned int ctx = 0;
4883 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4884 struct dsc$descriptor_s * clean_dsc;
4885
4886 struct myacedef {
4887     unsigned char myace$b_length;
4888     unsigned char myace$b_type;
4889     unsigned short int myace$w_flags;
4890     unsigned long int myace$l_access;
4891     unsigned long int myace$l_ident;
4892 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4893              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4894              0},
4895              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4896
4897 struct item_list_3
4898         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4899                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4900                       {0,0,0,0}},
4901         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4902         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4903                      {0,0,0,0}};
4904
4905
4906     /* Expand the input spec using RMS, since we do not want to put
4907      * ACLs on the target of a symbolic link */
4908     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
4909     if (vmsname == NULL)
4910         return SS$_INSFMEM;
4911
4912     rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer,
4913                         vmsname,
4914                         0,
4915                         NULL,
4916                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
4917                         NULL,
4918                         NULL);
4919     if (rslt == NULL) {
4920         PerlMem_free(vmsname);
4921         return SS$_INSFMEM;
4922     }
4923
4924     /* So we get our own UIC to use as a rights identifier,
4925      * and the insert an ACE at the head of the ACL which allows us
4926      * to delete the file.
4927      */
4928     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4929
4930     fildsc.dsc$w_length = strlen(vmsname);
4931     fildsc.dsc$a_pointer = vmsname;
4932     ctx = 0;
4933     newace.myace$l_ident = oldace.myace$l_ident;
4934     rnsts = SS$_ABORT;
4935
4936     /* Grab any existing ACEs with this identifier in case we fail */
4937     clean_dsc = &fildsc;
4938     aclsts = fndsts = sys$get_security(&obj_file_dsc,
4939                                &fildsc,
4940                                NULL,
4941                                OSS$M_WLOCK,
4942                                findlst,
4943                                &ctx,
4944                                &access_mode);
4945
4946     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
4947         /* Add the new ACE . . . */
4948
4949         /* if the sys$get_security succeeded, then ctx is valid, and the
4950          * object/file descriptors will be ignored.  But otherwise they
4951          * are needed
4952          */
4953         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4954                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
4955         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4956             set_errno(EVMSERR);
4957             set_vaxc_errno(aclsts);
4958             PerlMem_free(vmsname);
4959             return aclsts;
4960         }
4961
4962         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4963                                 NULL, NULL,
4964                                 &flags,
4965                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4966
4967         if ($VMS_STATUS_SUCCESS(rnsts)) {
4968             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4969         }
4970
4971         /* Put things back the way they were. */
4972         ctx = 0;
4973         aclsts = sys$get_security(&obj_file_dsc,
4974                                   clean_dsc,
4975                                   NULL,
4976                                   OSS$M_WLOCK,
4977                                   findlst,
4978                                   &ctx,
4979                                   &access_mode);
4980
4981         if ($VMS_STATUS_SUCCESS(aclsts)) {
4982         int sec_flags;
4983
4984             sec_flags = 0;
4985             if (!$VMS_STATUS_SUCCESS(fndsts))
4986                 sec_flags = OSS$M_RELCTX;
4987
4988             /* Get rid of the new ACE */
4989             aclsts = sys$set_security(NULL, NULL, NULL,
4990                                   sec_flags, dellst, &ctx, &access_mode);
4991
4992             /* If there was an old ACE, put it back */
4993             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
4994                 addlst[0].bufadr = &oldace;
4995                 aclsts = sys$set_security(NULL, NULL, NULL,
4996                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
4997                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4998                     set_errno(EVMSERR);
4999                     set_vaxc_errno(aclsts);
5000                     rnsts = aclsts;
5001                 }
5002             } else {
5003             int aclsts2;
5004
5005                 /* Try to clear the lock on the ACL list */
5006                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5007                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5008
5009                 /* Rename errors are most important */
5010                 if (!$VMS_STATUS_SUCCESS(rnsts))
5011                     aclsts = rnsts;
5012                 set_errno(EVMSERR);
5013                 set_vaxc_errno(aclsts);
5014                 rnsts = aclsts;
5015             }
5016         }
5017         else {
5018             if (aclsts != SS$_ACLEMPTY)
5019                 rnsts = aclsts;
5020         }
5021     }
5022     else
5023         rnsts = fndsts;
5024
5025     PerlMem_free(vmsname);
5026     return rnsts;
5027 }
5028
5029
5030 /*{{{int rename(const char *, const char * */
5031 /* Not exactly what X/Open says to do, but doing it absolutely right
5032  * and efficiently would require a lot more work.  This should be close
5033  * enough to pass all but the most strict X/Open compliance test.
5034  */
5035 int
5036 Perl_rename(pTHX_ const char *src, const char * dst)
5037 {
5038 int retval;
5039 int pre_delete = 0;
5040 int src_sts;
5041 int dst_sts;
5042 Stat_t src_st;
5043 Stat_t dst_st;
5044
5045     /* Validate the source file */
5046     src_sts = flex_lstat(src, &src_st);
5047     if (src_sts != 0) {
5048
5049         /* No source file or other problem */
5050         return src_sts;
5051     }
5052
5053     dst_sts = flex_lstat(dst, &dst_st);
5054     if (dst_sts == 0) {
5055
5056         if (dst_st.st_dev != src_st.st_dev) {
5057             /* Must be on the same device */
5058             errno = EXDEV;
5059             return -1;
5060         }
5061
5062         /* VMS_INO_T_COMPARE is true if the inodes are different
5063          * to match the output of memcmp
5064          */
5065
5066         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5067             /* That was easy, the files are the same! */
5068             return 0;
5069         }
5070
5071         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5072             /* If source is a directory, so must be dest */
5073                 errno = EISDIR;
5074                 return -1;
5075         }
5076
5077     }
5078
5079
5080     if ((dst_sts == 0) &&
5081         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5082
5083         /* We have issues here if vms_unlink_all_versions is set
5084          * If the destination exists, and is not a directory, then
5085          * we must delete in advance.
5086          *
5087          * If the src is a directory, then we must always pre-delete
5088          * the destination.
5089          *
5090          * If we successfully delete the dst in advance, and the rename fails
5091          * X/Open requires that errno be EIO.
5092          *
5093          */
5094
5095         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5096             int d_sts;
5097             d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5098             if (d_sts != 0)
5099                 return d_sts;
5100
5101             /* We killed the destination, so only errno now is EIO */
5102             pre_delete = 1;
5103         }
5104     }
5105
5106     /* Originally the idea was to call the CRTL rename() and only
5107      * try the lib$rename_file if it failed.
5108      * It turns out that there are too many variants in what the
5109      * the CRTL rename might do, so only use lib$rename_file
5110      */
5111     retval = -1;
5112
5113     {
5114         /* Is the source and dest both in VMS format */
5115         /* if the source is a directory, then need to fileify */
5116         /*  and dest must be a directory or non-existant. */
5117
5118         char * vms_src;
5119         char * vms_dst;
5120         int sts;
5121         char * ret_str;
5122         unsigned long flags;
5123         struct dsc$descriptor_s old_file_dsc;
5124         struct dsc$descriptor_s new_file_dsc;
5125
5126         /* We need to modify the src and dst depending
5127          * on if one or more of them are directories.
5128          */
5129
5130         vms_src = PerlMem_malloc(VMS_MAXRSS);
5131         if (vms_src == NULL)
5132             _ckvmssts(SS$_INSFMEM);
5133
5134         /* Source is always a VMS format file */
5135         ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5136         if (ret_str == NULL) {
5137             PerlMem_free(vms_src);
5138             errno = EIO;
5139             return -1;
5140         }
5141
5142         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5143         if (vms_dst == NULL)
5144             _ckvmssts(SS$_INSFMEM);
5145
5146         if (S_ISDIR(src_st.st_mode)) {
5147         char * ret_str;
5148         char * vms_dir_file;
5149
5150             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5151             if (vms_dir_file == NULL)
5152                 _ckvmssts(SS$_INSFMEM);
5153
5154             /* The source must be a file specification */
5155             ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
5156             if (ret_str == NULL) {
5157                 PerlMem_free(vms_src);
5158                 PerlMem_free(vms_dst);
5159                 PerlMem_free(vms_dir_file);
5160                 errno = EIO;
5161                 return -1;
5162             }
5163             PerlMem_free(vms_src);
5164             vms_src = vms_dir_file;
5165
5166             /* If the dest is a directory, we must remove it
5167             if (dst_sts == 0) {
5168                 int d_sts;
5169                 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5170                 if (d_sts != 0) {
5171                     PerlMem_free(vms_src);
5172                     PerlMem_free(vms_dst);
5173                     errno = EIO;
5174                     return sts;
5175                 }
5176
5177                 pre_delete = 1;
5178             }
5179
5180            /* The dest must be a VMS file specification */
5181            ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5182            if (ret_str == NULL) {
5183                 PerlMem_free(vms_src);
5184                 PerlMem_free(vms_dst);
5185                 errno = EIO;
5186                 return -1;
5187            }
5188
5189             /* The source must be a file specification */
5190             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5191             if (vms_dir_file == NULL)
5192                 _ckvmssts(SS$_INSFMEM);
5193
5194             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5195             if (ret_str == NULL) {
5196                 PerlMem_free(vms_src);
5197                 PerlMem_free(vms_dst);
5198                 PerlMem_free(vms_dir_file);
5199                 errno = EIO;
5200                 return -1;
5201             }
5202             PerlMem_free(vms_dst);
5203             vms_dst = vms_dir_file;
5204
5205         } else {
5206             /* File to file or file to new dir */
5207
5208             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5209                 /* VMS pathify a dir target */
5210                 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5211                 if (ret_str == NULL) {
5212                     PerlMem_free(vms_src);
5213                     PerlMem_free(vms_dst);
5214                     errno = EIO;
5215                     return -1;
5216                 }
5217             } else {
5218
5219                 /* fileify a target VMS file specification */
5220                 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5221                 if (ret_str == NULL) {
5222                     PerlMem_free(vms_src);
5223                     PerlMem_free(vms_dst);
5224                     errno = EIO;
5225                     return -1;
5226                 }
5227             }
5228         }
5229
5230         old_file_dsc.dsc$a_pointer = vms_src;
5231         old_file_dsc.dsc$w_length = strlen(vms_src);
5232         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5233         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5234
5235         new_file_dsc.dsc$a_pointer = vms_dst;
5236         new_file_dsc.dsc$w_length = strlen(vms_dst);
5237         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5238         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5239
5240         flags = 0;
5241 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5242         flags |= 2; /* LIB$M_FIL_LONG_NAMES */
5243 #endif
5244
5245         sts = lib$rename_file(&old_file_dsc,
5246                               &new_file_dsc,
5247                               NULL, NULL,
5248                               &flags,
5249                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5250         if (!$VMS_STATUS_SUCCESS(sts)) {
5251
5252            /* We could have failed because VMS style permissions do not
5253             * permit renames that UNIX will allow.  Just like the hack
5254             * in for kill_file.
5255             */
5256            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5257         }
5258
5259         PerlMem_free(vms_src);
5260         PerlMem_free(vms_dst);
5261         if (!$VMS_STATUS_SUCCESS(sts)) {
5262             errno = EIO;
5263             return -1;
5264         }
5265         retval = 0;
5266     }
5267
5268     if (vms_unlink_all_versions) {
5269         /* Now get rid of any previous versions of the source file that
5270          * might still exist
5271          */
5272         int save_errno;
5273         save_errno = errno;
5274         src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5275         errno = save_errno;
5276     }
5277
5278     /* We deleted the destination, so must force the error to be EIO */
5279     if ((retval != 0) && (pre_delete != 0))
5280         errno = EIO;
5281
5282     return retval;
5283 }
5284 /*}}}*/
5285
5286
5287 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5288 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5289  * to expand file specification.  Allows for a single default file
5290  * specification and a simple mask of options.  If outbuf is non-NULL,
5291  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5292  * the resultant file specification is placed.  If outbuf is NULL, the
5293  * resultant file specification is placed into a static buffer.
5294  * The third argument, if non-NULL, is taken to be a default file
5295  * specification string.  The fourth argument is unused at present.
5296  * rmesexpand() returns the address of the resultant string if
5297  * successful, and NULL on error.
5298  *
5299  * New functionality for previously unused opts value:
5300  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5301  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5302  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5303  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5304  */
5305 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5306
5307 static char *
5308 mp_do_rmsexpand
5309    (pTHX_ const char *filespec,
5310     char *outbuf,
5311     int ts,
5312     const char *defspec,
5313     unsigned opts,
5314     int * fs_utf8,
5315     int * dfs_utf8)
5316 {
5317   static char __rmsexpand_retbuf[VMS_MAXRSS];
5318   char * vmsfspec, *tmpfspec;
5319   char * esa, *cp, *out = NULL;
5320   char * tbuf;
5321   char * esal = NULL;
5322   char * outbufl;
5323   struct FAB myfab = cc$rms_fab;
5324   rms_setup_nam(mynam);
5325   STRLEN speclen;
5326   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5327   int sts;
5328
5329   /* temp hack until UTF8 is actually implemented */
5330   if (fs_utf8 != NULL)
5331     *fs_utf8 = 0;
5332
5333   if (!filespec || !*filespec) {
5334     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5335     return NULL;
5336   }
5337   if (!outbuf) {
5338     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
5339     else    outbuf = __rmsexpand_retbuf;
5340   }
5341
5342   vmsfspec = NULL;
5343   tmpfspec = NULL;
5344   outbufl = NULL;
5345
5346   isunix = 0;
5347   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5348     isunix = is_unix_filespec(filespec);
5349     if (isunix) {
5350       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5351       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
5352       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
5353         PerlMem_free(vmsfspec);
5354         if (out)
5355            Safefree(out);
5356         return NULL;
5357       }
5358       filespec = vmsfspec;
5359
5360       /* Unless we are forcing to VMS format, a UNIX input means
5361        * UNIX output, and that requires long names to be used
5362        */
5363 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5364       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5365         opts |= PERL_RMSEXPAND_M_LONG;
5366       else
5367 #endif
5368         isunix = 0;
5369       }
5370     }
5371
5372   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
5373   rms_bind_fab_nam(myfab, mynam);
5374
5375   if (defspec && *defspec) {
5376     int t_isunix;
5377     t_isunix = is_unix_filespec(defspec);
5378     if (t_isunix) {
5379       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5380       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5381       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
5382         PerlMem_free(tmpfspec);
5383         if (vmsfspec != NULL)
5384             PerlMem_free(vmsfspec);
5385         if (out)
5386            Safefree(out);
5387         return NULL;
5388       }
5389       defspec = tmpfspec;
5390     }
5391     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5392   }
5393
5394   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5395   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5396 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5397   esal = PerlMem_malloc(VMS_MAXRSS);
5398   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5399 #endif
5400   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5401
5402   /* If a NAML block is used RMS always writes to the long and short
5403    * addresses unless you suppress the short name.
5404    */
5405 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5406   outbufl = PerlMem_malloc(VMS_MAXRSS);
5407   if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
5408 #endif
5409    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5410
5411 #ifdef NAM$M_NO_SHORT_UPCASE
5412   if (decc_efs_case_preserve)
5413     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5414 #endif
5415
5416    /* We may not want to follow symbolic links */
5417 #ifdef NAML$M_OPEN_SPECIAL
5418   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5419     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5420 #endif
5421
5422   /* First attempt to parse as an existing file */
5423   retsts = sys$parse(&myfab,0,0);
5424   if (!(retsts & STS$K_SUCCESS)) {
5425
5426     /* Could not find the file, try as syntax only if error is not fatal */
5427     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5428     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
5429       retsts = sys$parse(&myfab,0,0);
5430       if (retsts & STS$K_SUCCESS) goto expanded;
5431     }
5432
5433      /* Still could not parse the file specification */
5434     /*----------------------------------------------*/
5435     sts = rms_free_search_context(&myfab); /* Free search context */
5436     if (out) Safefree(out);
5437     if (tmpfspec != NULL)
5438         PerlMem_free(tmpfspec);
5439     if (vmsfspec != NULL)
5440         PerlMem_free(vmsfspec);
5441     if (outbufl != NULL)
5442         PerlMem_free(outbufl);
5443     PerlMem_free(esa);
5444     if (esal != NULL)
5445         PerlMem_free(esal);
5446     set_vaxc_errno(retsts);
5447     if      (retsts == RMS$_PRV) set_errno(EACCES);
5448     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5449     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5450     else                         set_errno(EVMSERR);
5451     return NULL;
5452   }
5453   retsts = sys$search(&myfab,0,0);
5454   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5455     sts = rms_free_search_context(&myfab); /* Free search context */
5456     if (out) Safefree(out);
5457     if (tmpfspec != NULL)
5458         PerlMem_free(tmpfspec);
5459     if (vmsfspec != NULL)
5460         PerlMem_free(vmsfspec);
5461     if (outbufl != NULL)
5462         PerlMem_free(outbufl);
5463     PerlMem_free(esa);
5464     if (esal != NULL)
5465         PerlMem_free(esal);
5466     set_vaxc_errno(retsts);
5467     if      (retsts == RMS$_PRV) set_errno(EACCES);
5468     else                         set_errno(EVMSERR);
5469     return NULL;
5470   }
5471
5472   /* If the input filespec contained any lowercase characters,
5473    * downcase the result for compatibility with Unix-minded code. */
5474   expanded:
5475   if (!decc_efs_case_preserve) {
5476     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5477       if (islower(*tbuf)) { haslower = 1; break; }
5478   }
5479
5480    /* Is a long or a short name expected */
5481   /*------------------------------------*/
5482   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5483     if (rms_nam_rsll(mynam)) {
5484         tbuf = outbufl;
5485         speclen = rms_nam_rsll(mynam);
5486     }
5487     else {
5488         tbuf = esal; /* Not esa */
5489         speclen = rms_nam_esll(mynam);
5490     }
5491   }
5492   else {
5493     if (rms_nam_rsl(mynam)) {
5494         tbuf = outbuf;
5495         speclen = rms_nam_rsl(mynam);
5496     }
5497     else {
5498         tbuf = esa; /* Not esal */
5499         speclen = rms_nam_esl(mynam);
5500     }
5501   }
5502   tbuf[speclen] = '\0';
5503
5504   /* Trim off null fields added by $PARSE
5505    * If type > 1 char, must have been specified in original or default spec
5506    * (not true for version; $SEARCH may have added version of existing file).
5507    */
5508   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5509   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5510     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5511              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5512   }
5513   else {
5514     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5515              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5516   }
5517   if (trimver || trimtype) {
5518     if (defspec && *defspec) {
5519       char *defesal = NULL;
5520       char *defesa = NULL;
5521       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5522       if (defesa != NULL) {
5523 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5524         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5525         if (defesal == NULL) _ckvmssts(SS$_INSFMEM);
5526 #endif
5527         struct FAB deffab = cc$rms_fab;
5528         rms_setup_nam(defnam);
5529
5530         rms_bind_fab_nam(deffab, defnam);
5531
5532         /* Cast ok */
5533         rms_set_fna
5534             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5535
5536         /* RMS needs the esa/esal as a work area if wildcards are involved */
5537         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5538
5539         rms_clear_nam_nop(defnam);
5540         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5541 #ifdef NAM$M_NO_SHORT_UPCASE
5542         if (decc_efs_case_preserve)
5543           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5544 #endif
5545 #ifdef NAML$M_OPEN_SPECIAL
5546         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5547           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5548 #endif
5549         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5550           if (trimver) {
5551              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5552           }
5553           if (trimtype) {
5554             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5555           }
5556         }
5557         if (defesal != NULL)
5558             PerlMem_free(defesal);
5559         PerlMem_free(defesa);
5560       }
5561     }
5562     if (trimver) {
5563       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5564         if (*(rms_nam_verl(mynam)) != '\"')
5565           speclen = rms_nam_verl(mynam) - tbuf;
5566       }
5567       else {
5568         if (*(rms_nam_ver(mynam)) != '\"')
5569           speclen = rms_nam_ver(mynam) - tbuf;
5570       }
5571     }
5572     if (trimtype) {
5573       /* If we didn't already trim version, copy down */
5574       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5575         if (speclen > rms_nam_verl(mynam) - tbuf)
5576           memmove
5577            (rms_nam_typel(mynam),
5578             rms_nam_verl(mynam),
5579             speclen - (rms_nam_verl(mynam) - tbuf));
5580           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5581       }
5582       else {
5583         if (speclen > rms_nam_ver(mynam) - tbuf)
5584           memmove
5585            (rms_nam_type(mynam),
5586             rms_nam_ver(mynam),
5587             speclen - (rms_nam_ver(mynam) - tbuf));
5588           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5589       }
5590     }
5591   }
5592
5593    /* Done with these copies of the input files */
5594   /*-------------------------------------------*/
5595   if (vmsfspec != NULL)
5596         PerlMem_free(vmsfspec);
5597   if (tmpfspec != NULL)
5598         PerlMem_free(tmpfspec);
5599
5600   /* If we just had a directory spec on input, $PARSE "helpfully"
5601    * adds an empty name and type for us */
5602 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5603   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5604     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5605         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5606         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5607       speclen = rms_nam_namel(mynam) - tbuf;
5608   }
5609   else
5610 #endif
5611   {
5612     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5613         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5614         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5615       speclen = rms_nam_name(mynam) - tbuf;
5616   }
5617
5618   /* Posix format specifications must have matching quotes */
5619   if (speclen < (VMS_MAXRSS - 1)) {
5620     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5621       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5622         tbuf[speclen] = '\"';
5623         speclen++;
5624       }
5625     }
5626   }
5627   tbuf[speclen] = '\0';
5628   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5629
5630   /* Have we been working with an expanded, but not resultant, spec? */
5631   /* Also, convert back to Unix syntax if necessary. */
5632   {
5633   int rsl;
5634
5635 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5636     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5637       rsl = rms_nam_rsll(mynam);
5638     } else
5639 #endif
5640     {
5641       rsl = rms_nam_rsl(mynam);
5642     }
5643     if (!rsl) {
5644       if (isunix) {
5645         if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
5646           if (out) Safefree(out);
5647           if (esal != NULL)
5648             PerlMem_free(esal);
5649           PerlMem_free(esa);
5650           if (outbufl != NULL)
5651             PerlMem_free(outbufl);
5652           return NULL;
5653         }
5654       }
5655       else strcpy(outbuf, tbuf);
5656     }
5657     else if (isunix) {
5658       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5659       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5660       if (do_tounixspec(tbuf,tmpfspec,0,fs_utf8) == NULL) {
5661         if (out) Safefree(out);
5662         PerlMem_free(esa);
5663         if (esal != NULL)
5664             PerlMem_free(esal);
5665         PerlMem_free(tmpfspec);
5666         if (outbufl != NULL)
5667             PerlMem_free(outbufl);
5668         return NULL;
5669       }
5670       strcpy(outbuf,tmpfspec);
5671       PerlMem_free(tmpfspec);
5672     }
5673   }
5674   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5675   sts = rms_free_search_context(&myfab); /* Free search context */
5676   PerlMem_free(esa);
5677   if (esal != NULL)
5678      PerlMem_free(esal);
5679   if (outbufl != NULL)
5680      PerlMem_free(outbufl);
5681   return outbuf;
5682 }
5683 /*}}}*/
5684 /* External entry points */
5685 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5686 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5687 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5688 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5689 char *Perl_rmsexpand_utf8
5690   (pTHX_ const char *spec, char *buf, const char *def,
5691    unsigned opt, int * fs_utf8, int * dfs_utf8)
5692 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5693 char *Perl_rmsexpand_utf8_ts
5694   (pTHX_ const char *spec, char *buf, const char *def,
5695    unsigned opt, int * fs_utf8, int * dfs_utf8)
5696 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5697
5698
5699 /*
5700 ** The following routines are provided to make life easier when
5701 ** converting among VMS-style and Unix-style directory specifications.
5702 ** All will take input specifications in either VMS or Unix syntax. On
5703 ** failure, all return NULL.  If successful, the routines listed below
5704 ** return a pointer to a buffer containing the appropriately
5705 ** reformatted spec (and, therefore, subsequent calls to that routine
5706 ** will clobber the result), while the routines of the same names with
5707 ** a _ts suffix appended will return a pointer to a mallocd string
5708 ** containing the appropriately reformatted spec.
5709 ** In all cases, only explicit syntax is altered; no check is made that
5710 ** the resulting string is valid or that the directory in question
5711 ** actually exists.
5712 **
5713 **   fileify_dirspec() - convert a directory spec into the name of the
5714 **     directory file (i.e. what you can stat() to see if it's a dir).
5715 **     The style (VMS or Unix) of the result is the same as the style
5716 **     of the parameter passed in.
5717 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5718 **     what you prepend to a filename to indicate what directory it's in).
5719 **     The style (VMS or Unix) of the result is the same as the style
5720 **     of the parameter passed in.
5721 **   tounixpath() - convert a directory spec into a Unix-style path.
5722 **   tovmspath() - convert a directory spec into a VMS-style path.
5723 **   tounixspec() - convert any file spec into a Unix-style file spec.
5724 **   tovmsspec() - convert any file spec into a VMS-style spec.
5725 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5726 **
5727 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5728 ** Permission is given to distribute this code as part of the Perl
5729 ** standard distribution under the terms of the GNU General Public
5730 ** License or the Perl Artistic License.  Copies of each may be
5731 ** found in the Perl standard distribution.
5732  */
5733
5734 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5735 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5736 {
5737     static char __fileify_retbuf[VMS_MAXRSS];
5738     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5739     char *retspec, *cp1, *cp2, *lastdir;
5740     char *trndir, *vmsdir;
5741     unsigned short int trnlnm_iter_count;
5742     int sts;
5743     if (utf8_fl != NULL)
5744         *utf8_fl = 0;
5745
5746     if (!dir || !*dir) {
5747       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5748     }
5749     dirlen = strlen(dir);
5750     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5751     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5752       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5753         dir = "/sys$disk";
5754         dirlen = 9;
5755       }
5756       else
5757         dirlen = 1;
5758     }
5759     if (dirlen > (VMS_MAXRSS - 1)) {
5760       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5761       return NULL;
5762     }
5763     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5764     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5765     if (!strpbrk(dir+1,"/]>:")  &&
5766         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5767       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5768       trnlnm_iter_count = 0;
5769       while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5770         trnlnm_iter_count++;
5771         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5772       }
5773       dirlen = strlen(trndir);
5774     }
5775     else {
5776       strncpy(trndir,dir,dirlen);
5777       trndir[dirlen] = '\0';
5778     }
5779
5780     /* At this point we are done with *dir and use *trndir which is a
5781      * copy that can be modified.  *dir must not be modified.
5782      */
5783
5784     /* If we were handed a rooted logical name or spec, treat it like a
5785      * simple directory, so that
5786      *    $ Define myroot dev:[dir.]
5787      *    ... do_fileify_dirspec("myroot",buf,1) ...
5788      * does something useful.
5789      */
5790     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5791       trndir[--dirlen] = '\0';
5792       trndir[dirlen-1] = ']';
5793     }
5794     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5795       trndir[--dirlen] = '\0';
5796       trndir[dirlen-1] = '>';
5797     }
5798
5799     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5800       /* If we've got an explicit filename, we can just shuffle the string. */
5801       if (*(cp1+1)) hasfilename = 1;
5802       /* Similarly, we can just back up a level if we've got multiple levels
5803          of explicit directories in a VMS spec which ends with directories. */
5804       else {
5805         for (cp2 = cp1; cp2 > trndir; cp2--) {
5806           if (*cp2 == '.') {
5807             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5808 /* fix-me, can not scan EFS file specs backward like this */
5809               *cp2 = *cp1; *cp1 = '\0';
5810               hasfilename = 1;
5811               break;
5812             }
5813           }
5814           if (*cp2 == '[' || *cp2 == '<') break;
5815         }
5816       }
5817     }
5818
5819     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5820     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5821     cp1 = strpbrk(trndir,"]:>");
5822     if (hasfilename || !cp1) { /* Unix-style path or filename */
5823       if (trndir[0] == '.') {
5824         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5825           PerlMem_free(trndir);
5826           PerlMem_free(vmsdir);
5827           return do_fileify_dirspec("[]",buf,ts,NULL);
5828         }
5829         else if (trndir[1] == '.' &&
5830                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5831           PerlMem_free(trndir);
5832           PerlMem_free(vmsdir);
5833           return do_fileify_dirspec("[-]",buf,ts,NULL);
5834         }
5835       }
5836       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5837         dirlen -= 1;                 /* to last element */
5838         lastdir = strrchr(trndir,'/');
5839       }
5840       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5841         /* If we have "/." or "/..", VMSify it and let the VMS code
5842          * below expand it, rather than repeating the code to handle
5843          * relative components of a filespec here */
5844         do {
5845           if (*(cp1+2) == '.') cp1++;
5846           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5847             char * ret_chr;
5848             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5849                 PerlMem_free(trndir);
5850                 PerlMem_free(vmsdir);
5851                 return NULL;
5852             }
5853             if (strchr(vmsdir,'/') != NULL) {
5854               /* If do_tovmsspec() returned it, it must have VMS syntax
5855                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5856                * the time to check this here only so we avoid a recursion
5857                * loop; otherwise, gigo.
5858                */
5859               PerlMem_free(trndir);
5860               PerlMem_free(vmsdir);
5861               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5862               return NULL;
5863             }
5864             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5865                 PerlMem_free(trndir);
5866                 PerlMem_free(vmsdir);
5867                 return NULL;
5868             }
5869             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5870             PerlMem_free(trndir);
5871             PerlMem_free(vmsdir);
5872             return ret_chr;
5873           }
5874           cp1++;
5875         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5876         lastdir = strrchr(trndir,'/');
5877       }
5878       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5879         char * ret_chr;
5880         /* Ditto for specs that end in an MFD -- let the VMS code
5881          * figure out whether it's a real device or a rooted logical. */
5882
5883         /* This should not happen any more.  Allowing the fake /000000
5884          * in a UNIX pathname causes all sorts of problems when trying
5885          * to run in UNIX emulation.  So the VMS to UNIX conversions
5886          * now remove the fake /000000 directories.
5887          */
5888
5889         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5890         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5891             PerlMem_free(trndir);
5892             PerlMem_free(vmsdir);
5893             return NULL;
5894         }
5895         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5896             PerlMem_free(trndir);
5897             PerlMem_free(vmsdir);
5898             return NULL;
5899         }
5900         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5901         PerlMem_free(trndir);
5902         PerlMem_free(vmsdir);
5903         return ret_chr;
5904       }
5905       else {
5906
5907         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5908              !(lastdir = cp1 = strrchr(trndir,']')) &&
5909              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5910         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5911           int ver; char *cp3;
5912
5913           /* For EFS or ODS-5 look for the last dot */
5914           if (decc_efs_charset) {
5915               cp2 = strrchr(cp1,'.');
5916           }
5917           if (vms_process_case_tolerant) {
5918               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5919                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5920                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5921                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5922                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5923                             (ver || *cp3)))))) {
5924                   PerlMem_free(trndir);
5925                   PerlMem_free(vmsdir);
5926                   set_errno(ENOTDIR);
5927                   set_vaxc_errno(RMS$_DIR);
5928                   return NULL;
5929               }
5930           }
5931           else {
5932               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5933                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5934                   !*(cp2+3) || *(cp2+3) != 'R' ||
5935                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5936                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5937                             (ver || *cp3)))))) {
5938                  PerlMem_free(trndir);
5939                  PerlMem_free(vmsdir);
5940                  set_errno(ENOTDIR);
5941                  set_vaxc_errno(RMS$_DIR);
5942                  return NULL;
5943               }
5944           }
5945           dirlen = cp2 - trndir;
5946         }
5947       }
5948
5949       retlen = dirlen + 6;
5950       if (buf) retspec = buf;
5951       else if (ts) Newx(retspec,retlen+1,char);
5952       else retspec = __fileify_retbuf;
5953       memcpy(retspec,trndir,dirlen);
5954       retspec[dirlen] = '\0';
5955
5956       /* We've picked up everything up to the directory file name.
5957          Now just add the type and version, and we're set. */
5958       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5959         strcat(retspec,".dir;1");
5960       else
5961         strcat(retspec,".DIR;1");
5962       PerlMem_free(trndir);
5963       PerlMem_free(vmsdir);
5964       return retspec;
5965     }
5966     else {  /* VMS-style directory spec */
5967
5968       char *esa, *esal, term, *cp;
5969       char *my_esa;
5970       int my_esa_len;
5971       unsigned long int sts, cmplen, haslower = 0;
5972       unsigned int nam_fnb;
5973       char * nam_type;
5974       struct FAB dirfab = cc$rms_fab;
5975       rms_setup_nam(savnam);
5976       rms_setup_nam(dirnam);
5977
5978       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5979       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5980       esal = NULL;
5981 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5982       esal = PerlMem_malloc(VMS_MAXRSS);
5983       if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5984 #endif
5985       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5986       rms_bind_fab_nam(dirfab, dirnam);
5987       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5988       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
5989 #ifdef NAM$M_NO_SHORT_UPCASE
5990       if (decc_efs_case_preserve)
5991         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5992 #endif
5993
5994       for (cp = trndir; *cp; cp++)
5995         if (islower(*cp)) { haslower = 1; break; }
5996       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5997         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5998           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5999           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6000         }
6001         if (!sts) {
6002           PerlMem_free(esa);
6003           if (esal != NULL)
6004               PerlMem_free(esal);
6005           PerlMem_free(trndir);
6006           PerlMem_free(vmsdir);
6007           set_errno(EVMSERR);
6008           set_vaxc_errno(dirfab.fab$l_sts);
6009           return NULL;
6010         }
6011       }
6012       else {
6013         savnam = dirnam;
6014         /* Does the file really exist? */
6015         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6016           /* Yes; fake the fnb bits so we'll check type below */
6017         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6018         }
6019         else { /* No; just work with potential name */
6020           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6021           else {
6022             int fab_sts;
6023             fab_sts = dirfab.fab$l_sts;
6024             sts = rms_free_search_context(&dirfab);
6025             PerlMem_free(esa);
6026             if (esal != NULL)
6027                 PerlMem_free(esal);
6028             PerlMem_free(trndir);
6029             PerlMem_free(vmsdir);
6030             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6031             return NULL;
6032           }
6033         }
6034       }
6035
6036       /* Make sure we are using the right buffer */
6037       if (esal != NULL) {
6038         my_esa = esal;
6039         my_esa_len = rms_nam_esll(dirnam);
6040       } else {
6041         my_esa = esa;
6042         my_esa_len = rms_nam_esl(dirnam);
6043       }
6044       my_esa[my_esa_len] = '\0';
6045       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6046         cp1 = strchr(my_esa,']');
6047         if (!cp1) cp1 = strchr(my_esa,'>');
6048         if (cp1) {  /* Should always be true */
6049           my_esa_len -= cp1 - my_esa - 1;
6050           memmove(my_esa, cp1 + 1, my_esa_len);
6051         }
6052       }
6053       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6054         /* Yep; check version while we're at it, if it's there. */
6055         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6056         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6057           /* Something other than .DIR[;1].  Bzzt. */
6058           sts = rms_free_search_context(&dirfab);
6059           PerlMem_free(esa);
6060           if (esal != NULL)
6061              PerlMem_free(esal);
6062           PerlMem_free(trndir);
6063           PerlMem_free(vmsdir);
6064           set_errno(ENOTDIR);
6065           set_vaxc_errno(RMS$_DIR);
6066           return NULL;
6067         }
6068       }
6069
6070       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6071         /* They provided at least the name; we added the type, if necessary, */
6072         if (buf) retspec = buf;                            /* in sys$parse() */
6073         else if (ts) Newx(retspec, my_esa_len + 1, char);
6074         else retspec = __fileify_retbuf;
6075         strcpy(retspec,my_esa);
6076         sts = rms_free_search_context(&dirfab);
6077         PerlMem_free(trndir);
6078         PerlMem_free(esa);
6079         if (esal != NULL)
6080             PerlMem_free(esal);
6081         PerlMem_free(vmsdir);
6082         return retspec;
6083       }
6084       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6085         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6086         *cp1 = '\0';
6087         my_esa_len -= 9;
6088       }
6089       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6090       if (cp1 == NULL) { /* should never happen */
6091         sts = rms_free_search_context(&dirfab);
6092         PerlMem_free(trndir);
6093         PerlMem_free(esa);
6094         if (esal != NULL)
6095             PerlMem_free(esal);
6096         PerlMem_free(vmsdir);
6097         return NULL;
6098       }
6099       term = *cp1;
6100       *cp1 = '\0';
6101       retlen = strlen(my_esa);
6102       cp1 = strrchr(my_esa,'.');
6103       /* ODS-5 directory specifications can have extra "." in them. */
6104       /* Fix-me, can not scan EFS file specifications backwards */
6105       while (cp1 != NULL) {
6106         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6107           break;
6108         else {
6109            cp1--;
6110            while ((cp1 > my_esa) && (*cp1 != '.'))
6111              cp1--;
6112         }
6113         if (cp1 == my_esa)
6114           cp1 = NULL;
6115       }
6116
6117       if ((cp1) != NULL) {
6118         /* There's more than one directory in the path.  Just roll back. */
6119         *cp1 = term;
6120         if (buf) retspec = buf;
6121         else if (ts) Newx(retspec,retlen+7,char);
6122         else retspec = __fileify_retbuf;
6123         strcpy(retspec,my_esa);
6124       }
6125       else {
6126         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6127           /* Go back and expand rooted logical name */
6128           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6129 #ifdef NAM$M_NO_SHORT_UPCASE
6130           if (decc_efs_case_preserve)
6131             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6132 #endif
6133           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6134             sts = rms_free_search_context(&dirfab);
6135             PerlMem_free(esa);
6136             if (esal != NULL)
6137                 PerlMem_free(esal);
6138             PerlMem_free(trndir);
6139             PerlMem_free(vmsdir);
6140             set_errno(EVMSERR);
6141             set_vaxc_errno(dirfab.fab$l_sts);
6142             return NULL;
6143           }
6144
6145           /* This changes the length of the string of course */
6146           if (esal != NULL) {
6147               my_esa_len = rms_nam_esll(dirnam);
6148           } else {
6149               my_esa_len = rms_nam_esl(dirnam);
6150           }
6151
6152           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6153           if (buf) retspec = buf;
6154           else if (ts) Newx(retspec,retlen+16,char);
6155           else retspec = __fileify_retbuf;
6156           cp1 = strstr(my_esa,"][");
6157           if (!cp1) cp1 = strstr(my_esa,"]<");
6158           dirlen = cp1 - my_esa;
6159           memcpy(retspec,my_esa,dirlen);
6160           if (!strncmp(cp1+2,"000000]",7)) {
6161             retspec[dirlen-1] = '\0';
6162             /* fix-me Not full ODS-5, just extra dots in directories for now */
6163             cp1 = retspec + dirlen - 1;
6164             while (cp1 > retspec)
6165             {
6166               if (*cp1 == '[')
6167                 break;
6168               if (*cp1 == '.') {
6169                 if (*(cp1-1) != '^')
6170                   break;
6171               }
6172               cp1--;
6173             }
6174             if (*cp1 == '.') *cp1 = ']';
6175             else {
6176               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6177               memmove(cp1+1,"000000]",7);
6178             }
6179           }
6180           else {
6181             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
6182             retspec[retlen] = '\0';
6183             /* Convert last '.' to ']' */
6184             cp1 = retspec+retlen-1;
6185             while (*cp != '[') {
6186               cp1--;
6187               if (*cp1 == '.') {
6188                 /* Do not trip on extra dots in ODS-5 directories */
6189                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6190                 break;
6191               }
6192             }
6193             if (*cp1 == '.') *cp1 = ']';
6194             else {
6195               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6196               memmove(cp1+1,"000000]",7);
6197             }
6198           }
6199         }
6200         else {  /* This is a top-level dir.  Add the MFD to the path. */
6201           if (buf) retspec = buf;
6202           else if (ts) Newx(retspec,retlen+16,char);
6203           else retspec = __fileify_retbuf;
6204           cp1 = my_esa;
6205           cp2 = retspec;
6206           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6207           strcpy(cp2,":[000000]");
6208           cp1 += 2;
6209           strcpy(cp2+9,cp1);
6210         }
6211       }
6212       sts = rms_free_search_context(&dirfab);
6213       /* We've set up the string up through the filename.  Add the
6214          type and version, and we're done. */
6215       strcat(retspec,".DIR;1");
6216
6217       /* $PARSE may have upcased filespec, so convert output to lower
6218        * case if input contained any lowercase characters. */
6219       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
6220       PerlMem_free(trndir);
6221       PerlMem_free(esa);
6222       if (esal != NULL)
6223         PerlMem_free(esal);
6224       PerlMem_free(vmsdir);
6225       return retspec;
6226     }
6227 }  /* end of do_fileify_dirspec() */
6228 /*}}}*/
6229 /* External entry points */
6230 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6231 { return do_fileify_dirspec(dir,buf,0,NULL); }
6232 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6233 { return do_fileify_dirspec(dir,buf,1,NULL); }
6234 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6235 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6236 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6237 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6238
6239 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6240 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6241 {
6242     static char __pathify_retbuf[VMS_MAXRSS];
6243     unsigned long int retlen;
6244     char *retpath, *cp1, *cp2, *trndir;
6245     unsigned short int trnlnm_iter_count;
6246     STRLEN trnlen;
6247     int sts;
6248     if (utf8_fl != NULL)
6249         *utf8_fl = 0;
6250
6251     if (!dir || !*dir) {
6252       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6253     }
6254
6255     trndir = PerlMem_malloc(VMS_MAXRSS);
6256     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
6257     if (*dir) strcpy(trndir,dir);
6258     else getcwd(trndir,VMS_MAXRSS - 1);
6259
6260     trnlnm_iter_count = 0;
6261     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6262            && my_trnlnm(trndir,trndir,0)) {
6263       trnlnm_iter_count++;
6264       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6265       trnlen = strlen(trndir);
6266
6267       /* Trap simple rooted lnms, and return lnm:[000000] */
6268       if (!strcmp(trndir+trnlen-2,".]")) {
6269         if (buf) retpath = buf;
6270         else if (ts) Newx(retpath,strlen(dir)+10,char);
6271         else retpath = __pathify_retbuf;
6272         strcpy(retpath,dir);
6273         strcat(retpath,":[000000]");
6274         PerlMem_free(trndir);
6275         return retpath;
6276       }
6277     }
6278
6279     /* At this point we do not work with *dir, but the copy in
6280      * *trndir that is modifiable.
6281      */
6282
6283     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
6284       if (*trndir == '.' && (*(trndir+1) == '\0' ||
6285                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
6286         retlen = 2 + (*(trndir+1) != '\0');
6287       else {
6288         if ( !(cp1 = strrchr(trndir,'/')) &&
6289              !(cp1 = strrchr(trndir,']')) &&
6290              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
6291         if ((cp2 = strchr(cp1,'.')) != NULL &&
6292             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
6293              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
6294               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
6295               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
6296           int ver; char *cp3;
6297
6298           /* For EFS or ODS-5 look for the last dot */
6299           if (decc_efs_charset) {
6300             cp2 = strrchr(cp1,'.');
6301           }
6302           if (vms_process_case_tolerant) {
6303               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6304                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6305                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6306                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6307                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6308                             (ver || *cp3)))))) {
6309                 PerlMem_free(trndir);
6310                 set_errno(ENOTDIR);
6311                 set_vaxc_errno(RMS$_DIR);
6312                 return NULL;
6313               }
6314           }
6315           else {
6316               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6317                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6318                   !*(cp2+3) || *(cp2+3) != 'R' ||
6319                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6320                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6321                             (ver || *cp3)))))) {
6322                 PerlMem_free(trndir);
6323                 set_errno(ENOTDIR);
6324                 set_vaxc_errno(RMS$_DIR);
6325                 return NULL;
6326               }
6327           }
6328           retlen = cp2 - trndir + 1;
6329         }
6330         else {  /* No file type present.  Treat the filename as a directory. */
6331           retlen = strlen(trndir) + 1;
6332         }
6333       }
6334       if (buf) retpath = buf;
6335       else if (ts) Newx(retpath,retlen+1,char);
6336       else retpath = __pathify_retbuf;
6337       strncpy(retpath, trndir, retlen-1);
6338       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
6339         retpath[retlen-1] = '/';      /* with '/', add it. */
6340         retpath[retlen] = '\0';
6341       }
6342       else retpath[retlen-1] = '\0';
6343     }
6344     else {  /* VMS-style directory spec */
6345       char *esa, *esal, *cp;
6346       char *my_esa;
6347       int my_esa_len;
6348       unsigned long int sts, cmplen, haslower;
6349       struct FAB dirfab = cc$rms_fab;
6350       int dirlen;
6351       rms_setup_nam(savnam);
6352       rms_setup_nam(dirnam);
6353
6354       /* If we've got an explicit filename, we can just shuffle the string. */
6355       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
6356              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
6357         if ((cp2 = strchr(cp1,'.')) != NULL) {
6358           int ver; char *cp3;
6359           if (vms_process_case_tolerant) {
6360               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6361                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6362                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6363                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6364                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6365                             (ver || *cp3)))))) {
6366                PerlMem_free(trndir);
6367                set_errno(ENOTDIR);
6368                set_vaxc_errno(RMS$_DIR);
6369                return NULL;
6370              }
6371           }
6372           else {
6373               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6374                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6375                   !*(cp2+3) || *(cp2+3) != 'R' ||
6376                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6377                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6378                             (ver || *cp3)))))) {
6379                PerlMem_free(trndir);
6380                set_errno(ENOTDIR);
6381                set_vaxc_errno(RMS$_DIR);
6382                return NULL;
6383              }
6384           }
6385         }
6386         else {  /* No file type, so just draw name into directory part */
6387           for (cp2 = cp1; *cp2; cp2++) ;
6388         }
6389         *cp2 = *cp1;
6390         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
6391         *cp1 = '.';
6392         /* We've now got a VMS 'path'; fall through */
6393       }
6394
6395       dirlen = strlen(trndir);
6396       if (trndir[dirlen-1] == ']' ||
6397           trndir[dirlen-1] == '>' ||
6398           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
6399         if (buf) retpath = buf;
6400         else if (ts) Newx(retpath,strlen(trndir)+1,char);
6401         else retpath = __pathify_retbuf;
6402         strcpy(retpath,trndir);
6403         PerlMem_free(trndir);
6404         return retpath;
6405       }
6406       rms_set_fna(dirfab, dirnam, trndir, dirlen);
6407       esa = PerlMem_malloc(VMS_MAXRSS);
6408       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
6409       esal = NULL;
6410 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6411       esal = PerlMem_malloc(VMS_MAXRSS);
6412       if (esal == NULL) _ckvmssts(SS$_INSFMEM);
6413 #endif
6414       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6415       rms_bind_fab_nam(dirfab, dirnam);
6416       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
6417 #ifdef NAM$M_NO_SHORT_UPCASE
6418       if (decc_efs_case_preserve)
6419           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6420 #endif
6421
6422       for (cp = trndir; *cp; cp++)
6423         if (islower(*cp)) { haslower = 1; break; }
6424
6425       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
6426         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6427           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6428           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6429         }
6430         if (!sts) {
6431           PerlMem_free(trndir);
6432           PerlMem_free(esa);
6433           if (esal != NULL)
6434             PerlMem_free(esal);
6435           set_errno(EVMSERR);
6436           set_vaxc_errno(dirfab.fab$l_sts);
6437           return NULL;
6438         }
6439       }
6440       else {
6441         savnam = dirnam;
6442         /* Does the file really exist? */
6443         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
6444           if (dirfab.fab$l_sts != RMS$_FNF) {
6445             int sts1;
6446             sts1 = rms_free_search_context(&dirfab);
6447             PerlMem_free(trndir);
6448             PerlMem_free(esa);
6449             if (esal != NULL)
6450                 PerlMem_free(esal);
6451             set_errno(EVMSERR);
6452             set_vaxc_errno(dirfab.fab$l_sts);
6453             return NULL;
6454           }
6455           dirnam = savnam; /* No; just work with potential name */
6456         }
6457       }
6458       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6459         /* Yep; check version while we're at it, if it's there. */
6460         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6461         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
6462           int sts2;
6463           /* Something other than .DIR[;1].  Bzzt. */
6464           sts2 = rms_free_search_context(&dirfab);
6465           PerlMem_free(trndir);
6466           PerlMem_free(esa);
6467           if (esal != NULL)
6468              PerlMem_free(esal);
6469           set_errno(ENOTDIR);
6470           set_vaxc_errno(RMS$_DIR);
6471           return NULL;
6472         }
6473       }
6474       /* Make sure we are using the right buffer */
6475       if (esal != NULL) {
6476         /* We only need one, clean up the other */
6477         my_esa = esal;
6478         my_esa_len = rms_nam_esll(dirnam);
6479       } else {
6480         my_esa = esa;
6481         my_esa_len = rms_nam_esl(dirnam);
6482       }
6483
6484       /* Null terminate the buffer */
6485       my_esa[my_esa_len] = '\0';
6486
6487       /* OK, the type was fine.  Now pull any file name into the
6488          directory path. */
6489       if ((cp1 = strrchr(my_esa,']'))) *(rms_nam_typel(dirnam)) = ']';
6490       else {
6491         cp1 = strrchr(my_esa,'>');
6492         *(rms_nam_typel(dirnam)) = '>';
6493       }
6494       *cp1 = '.';
6495       *(rms_nam_typel(dirnam) + 1) = '\0';
6496       retlen = (rms_nam_typel(dirnam)) - my_esa + 2;
6497       if (buf) retpath = buf;
6498       else if (ts) Newx(retpath,retlen,char);
6499       else retpath = __pathify_retbuf;
6500       strcpy(retpath,my_esa);
6501       PerlMem_free(esa);
6502       if (esal != NULL)
6503           PerlMem_free(esal);
6504       sts = rms_free_search_context(&dirfab);
6505       /* $PARSE may have upcased filespec, so convert output to lower
6506        * case if input contained any lowercase characters. */
6507       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
6508     }
6509
6510     PerlMem_free(trndir);
6511     return retpath;
6512 }  /* end of do_pathify_dirspec() */
6513 /*}}}*/
6514 /* External entry points */
6515 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6516 { return do_pathify_dirspec(dir,buf,0,NULL); }
6517 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6518 { return do_pathify_dirspec(dir,buf,1,NULL); }
6519 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6520 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6521 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6522 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6523
6524 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
6525 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
6526 {
6527   static char __tounixspec_retbuf[VMS_MAXRSS];
6528   char *dirend, *rslt, *cp1, *cp3, *tmp;
6529   const char *cp2;
6530   int devlen, dirlen, retlen = VMS_MAXRSS;
6531   int expand = 1; /* guarantee room for leading and trailing slashes */
6532   unsigned short int trnlnm_iter_count;
6533   int cmp_rslt;
6534   if (utf8_fl != NULL)
6535     *utf8_fl = 0;
6536
6537   if (spec == NULL) return NULL;
6538   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
6539   if (buf) rslt = buf;
6540   else if (ts) {
6541     Newx(rslt, VMS_MAXRSS, char);
6542   }
6543   else rslt = __tounixspec_retbuf;
6544
6545   /* New VMS specific format needs translation
6546    * glob passes filenames with trailing '\n' and expects this preserved.
6547    */
6548   if (decc_posix_compliant_pathnames) {
6549     if (strncmp(spec, "\"^UP^", 5) == 0) {
6550       char * uspec;
6551       char *tunix;
6552       int tunix_len;
6553       int nl_flag;
6554
6555       tunix = PerlMem_malloc(VMS_MAXRSS);
6556       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
6557       strcpy(tunix, spec);
6558       tunix_len = strlen(tunix);
6559       nl_flag = 0;
6560       if (tunix[tunix_len - 1] == '\n') {
6561         tunix[tunix_len - 1] = '\"';
6562         tunix[tunix_len] = '\0';
6563         tunix_len--;
6564         nl_flag = 1;
6565       }
6566       uspec = decc$translate_vms(tunix);
6567       PerlMem_free(tunix);
6568       if ((int)uspec > 0) {
6569         strcpy(rslt,uspec);
6570         if (nl_flag) {
6571           strcat(rslt,"\n");
6572         }
6573         else {
6574           /* If we can not translate it, makemaker wants as-is */
6575           strcpy(rslt, spec);
6576         }
6577         return rslt;
6578       }
6579     }
6580   }
6581
6582   cmp_rslt = 0; /* Presume VMS */
6583   cp1 = strchr(spec, '/');
6584   if (cp1 == NULL)
6585     cmp_rslt = 0;
6586
6587     /* Look for EFS ^/ */
6588     if (decc_efs_charset) {
6589       while (cp1 != NULL) {
6590         cp2 = cp1 - 1;
6591         if (*cp2 != '^') {
6592           /* Found illegal VMS, assume UNIX */
6593           cmp_rslt = 1;
6594           break;
6595         }
6596       cp1++;
6597       cp1 = strchr(cp1, '/');
6598     }
6599   }
6600
6601   /* Look for "." and ".." */
6602   if (decc_filename_unix_report) {
6603     if (spec[0] == '.') {
6604       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6605         cmp_rslt = 1;
6606       }
6607       else {
6608         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6609           cmp_rslt = 1;
6610         }
6611       }
6612     }
6613   }
6614   /* This is already UNIX or at least nothing VMS understands */
6615   if (cmp_rslt) {
6616     strcpy(rslt,spec);
6617     return rslt;
6618   }
6619
6620   cp1 = rslt;
6621   cp2 = spec;
6622   dirend = strrchr(spec,']');
6623   if (dirend == NULL) dirend = strrchr(spec,'>');
6624   if (dirend == NULL) dirend = strchr(spec,':');
6625   if (dirend == NULL) {
6626     strcpy(rslt,spec);
6627     return rslt;
6628   }
6629
6630   /* Special case 1 - sys$posix_root = / */
6631 #if __CRTL_VER >= 70000000
6632   if (!decc_disable_posix_root) {
6633     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6634       *cp1 = '/';
6635       cp1++;
6636       cp2 = cp2 + 15;
6637       }
6638   }
6639 #endif
6640
6641   /* Special case 2 - Convert NLA0: to /dev/null */
6642 #if __CRTL_VER < 70000000
6643   cmp_rslt = strncmp(spec,"NLA0:", 5);
6644   if (cmp_rslt != 0)
6645      cmp_rslt = strncmp(spec,"nla0:", 5);
6646 #else
6647   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6648 #endif
6649   if (cmp_rslt == 0) {
6650     strcpy(rslt, "/dev/null");
6651     cp1 = cp1 + 9;
6652     cp2 = cp2 + 5;
6653     if (spec[6] != '\0') {
6654       cp1[9] == '/';
6655       cp1++;
6656       cp2++;
6657     }
6658   }
6659
6660    /* Also handle special case "SYS$SCRATCH:" */
6661 #if __CRTL_VER < 70000000
6662   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6663   if (cmp_rslt != 0)
6664      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6665 #else
6666   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6667 #endif
6668   tmp = PerlMem_malloc(VMS_MAXRSS);
6669   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6670   if (cmp_rslt == 0) {
6671   int islnm;
6672
6673     islnm = my_trnlnm(tmp, "TMP", 0);
6674     if (!islnm) {
6675       strcpy(rslt, "/tmp");
6676       cp1 = cp1 + 4;
6677       cp2 = cp2 + 12;
6678       if (spec[12] != '\0') {
6679         cp1[4] == '/';
6680         cp1++;
6681         cp2++;
6682       }
6683     }
6684   }
6685
6686   if (*cp2 != '[' && *cp2 != '<') {
6687     *(cp1++) = '/';
6688   }
6689   else {  /* the VMS spec begins with directories */
6690     cp2++;
6691     if (*cp2 == ']' || *cp2 == '>') {
6692       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6693       PerlMem_free(tmp);
6694       return rslt;
6695     }
6696     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6697       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6698         if (ts) Safefree(rslt);
6699         PerlMem_free(tmp);
6700         return NULL;
6701       }
6702       trnlnm_iter_count = 0;
6703       do {
6704         cp3 = tmp;
6705         while (*cp3 != ':' && *cp3) cp3++;
6706         *(cp3++) = '\0';
6707         if (strchr(cp3,']') != NULL) break;
6708         trnlnm_iter_count++;
6709         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6710       } while (vmstrnenv(tmp,tmp,0,fildev,0));
6711       if (ts && !buf &&
6712           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6713         retlen = devlen + dirlen;
6714         Renew(rslt,retlen+1+2*expand,char);
6715         cp1 = rslt;
6716       }
6717       cp3 = tmp;
6718       *(cp1++) = '/';
6719       while (*cp3) {
6720         *(cp1++) = *(cp3++);
6721         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6722             PerlMem_free(tmp);
6723             return NULL; /* No room */
6724         }
6725       }
6726       *(cp1++) = '/';
6727     }
6728     if ((*cp2 == '^')) {
6729         /* EFS file escape, pass the next character as is */
6730         /* Fix me: HEX encoding for Unicode not implemented */
6731         cp2++;
6732     }
6733     else if ( *cp2 == '.') {
6734       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6735         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6736         cp2 += 3;
6737       }
6738       else cp2++;
6739     }
6740   }
6741   PerlMem_free(tmp);
6742   for (; cp2 <= dirend; cp2++) {
6743     if ((*cp2 == '^')) {
6744         /* EFS file escape, pass the next character as is */
6745         /* Fix me: HEX encoding for Unicode not implemented */
6746         *(cp1++) = *(++cp2);
6747         /* An escaped dot stays as is -- don't convert to slash */
6748         if (*cp2 == '.') cp2++;
6749     }
6750     if (*cp2 == ':') {
6751       *(cp1++) = '/';
6752       if (*(cp2+1) == '[') cp2++;
6753     }
6754     else if (*cp2 == ']' || *cp2 == '>') {
6755       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6756     }
6757     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6758       *(cp1++) = '/';
6759       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6760         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6761                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6762         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6763             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6764       }
6765       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6766         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6767         cp2 += 2;
6768       }
6769     }
6770     else if (*cp2 == '-') {
6771       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6772         while (*cp2 == '-') {
6773           cp2++;
6774           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6775         }
6776         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6777           if (ts) Safefree(rslt);                        /* filespecs like */
6778           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
6779           return NULL;
6780         }
6781       }
6782       else *(cp1++) = *cp2;
6783     }
6784     else *(cp1++) = *cp2;
6785   }
6786   while (*cp2) {
6787     if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++;  /* '^.' --> '.' */
6788     *(cp1++) = *(cp2++);
6789   }
6790   *cp1 = '\0';
6791
6792   /* This still leaves /000000/ when working with a
6793    * VMS device root or concealed root.
6794    */
6795   {
6796   int ulen;
6797   char * zeros;
6798
6799       ulen = strlen(rslt);
6800
6801       /* Get rid of "000000/ in rooted filespecs */
6802       if (ulen > 7) {
6803         zeros = strstr(rslt, "/000000/");
6804         if (zeros != NULL) {
6805           int mlen;
6806           mlen = ulen - (zeros - rslt) - 7;
6807           memmove(zeros, &zeros[7], mlen);
6808           ulen = ulen - 7;
6809           rslt[ulen] = '\0';
6810         }
6811       }
6812   }
6813
6814   return rslt;
6815
6816 }  /* end of do_tounixspec() */
6817 /*}}}*/
6818 /* External entry points */
6819 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6820   { return do_tounixspec(spec,buf,0, NULL); }
6821 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6822   { return do_tounixspec(spec,buf,1, NULL); }
6823 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6824   { return do_tounixspec(spec,buf,0, utf8_fl); }
6825 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6826   { return do_tounixspec(spec,buf,1, utf8_fl); }
6827
6828 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6829
6830 /*
6831  This procedure is used to identify if a path is based in either
6832  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6833  it returns the OpenVMS format directory for it.
6834
6835  It is expecting specifications of only '/' or '/xxxx/'
6836
6837  If a posix root does not exist, or 'xxxx' is not a directory
6838  in the posix root, it returns a failure.
6839
6840  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6841
6842  It is used only internally by posix_to_vmsspec_hardway().
6843  */
6844
6845 static int posix_root_to_vms
6846   (char *vmspath, int vmspath_len,
6847    const char *unixpath,
6848    const int * utf8_fl)
6849 {
6850 int sts;
6851 struct FAB myfab = cc$rms_fab;
6852 rms_setup_nam(mynam);
6853 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6854 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6855 char * esa, * esal, * rsa, * rsal;
6856 char *vms_delim;
6857 int dir_flag;
6858 int unixlen;
6859
6860     dir_flag = 0;
6861     vmspath[0] = '\0';
6862     unixlen = strlen(unixpath);
6863     if (unixlen == 0) {
6864       return RMS$_FNF;
6865     }
6866
6867 #if __CRTL_VER >= 80200000
6868   /* If not a posix spec already, convert it */
6869   if (decc_posix_compliant_pathnames) {
6870     if (strncmp(unixpath,"\"^UP^",5) != 0) {
6871       sprintf(vmspath,"\"^UP^%s\"",unixpath);
6872     }
6873     else {
6874       /* This is already a VMS specification, no conversion */
6875       unixlen--;
6876       strncpy(vmspath,unixpath, vmspath_len);
6877     }
6878   }
6879   else
6880 #endif
6881   {
6882   int path_len;
6883   int i,j;
6884
6885      /* Check to see if this is under the POSIX root */
6886      if (decc_disable_posix_root) {
6887         return RMS$_FNF;
6888      }
6889
6890      /* Skip leading / */
6891      if (unixpath[0] == '/') {
6892         unixpath++;
6893         unixlen--;
6894      }
6895
6896
6897      strcpy(vmspath,"SYS$POSIX_ROOT:");
6898
6899      /* If this is only the / , or blank, then... */
6900      if (unixpath[0] == '\0') {
6901         /* by definition, this is the answer */
6902         return SS$_NORMAL;
6903      }
6904
6905      /* Need to look up a directory */
6906      vmspath[15] = '[';
6907      vmspath[16] = '\0';
6908
6909      /* Copy and add '^' escape characters as needed */
6910      j = 16;
6911      i = 0;
6912      while (unixpath[i] != 0) {
6913      int k;
6914
6915         j += copy_expand_unix_filename_escape
6916             (&vmspath[j], &unixpath[i], &k, utf8_fl);
6917         i += k;
6918      }
6919
6920      path_len = strlen(vmspath);
6921      if (vmspath[path_len - 1] == '/')
6922         path_len--;
6923      vmspath[path_len] = ']';
6924      path_len++;
6925      vmspath[path_len] = '\0';
6926
6927   }
6928   vmspath[vmspath_len] = 0;
6929   if (unixpath[unixlen - 1] == '/')
6930   dir_flag = 1;
6931   esal = PerlMem_malloc(VMS_MAXRSS);
6932   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6933   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6934   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6935   rsal = PerlMem_malloc(VMS_MAXRSS);
6936   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6937   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6938   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6939   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
6940   rms_bind_fab_nam(myfab, mynam);
6941   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
6942   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
6943   if (decc_efs_case_preserve)
6944     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6945 #ifdef NAML$M_OPEN_SPECIAL
6946   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6947 #endif
6948
6949   /* Set up the remaining naml fields */
6950   sts = sys$parse(&myfab);
6951
6952   /* It failed! Try again as a UNIX filespec */
6953   if (!(sts & 1)) {
6954     PerlMem_free(esal);
6955     PerlMem_free(esa);
6956     PerlMem_free(rsal);
6957     PerlMem_free(rsa);
6958     return sts;
6959   }
6960
6961    /* get the Device ID and the FID */
6962    sts = sys$search(&myfab);
6963
6964    /* These are no longer needed */
6965    PerlMem_free(esa);
6966    PerlMem_free(rsal);
6967    PerlMem_free(rsa);
6968
6969    /* on any failure, returned the POSIX ^UP^ filespec */
6970    if (!(sts & 1)) {
6971       PerlMem_free(esal);
6972       return sts;
6973    }
6974    specdsc.dsc$a_pointer = vmspath;
6975    specdsc.dsc$w_length = vmspath_len;
6976
6977    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6978    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6979    sts = lib$fid_to_name
6980       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6981
6982   /* on any failure, returned the POSIX ^UP^ filespec */
6983   if (!(sts & 1)) {
6984      /* This can happen if user does not have permission to read directories */
6985      if (strncmp(unixpath,"\"^UP^",5) != 0)
6986        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6987      else
6988        strcpy(vmspath, unixpath);
6989   }
6990   else {
6991     vmspath[specdsc.dsc$w_length] = 0;
6992
6993     /* Are we expecting a directory? */
6994     if (dir_flag != 0) {
6995     int i;
6996     char *eptr;
6997
6998       eptr = NULL;
6999
7000       i = specdsc.dsc$w_length - 1;
7001       while (i > 0) {
7002       int zercnt;
7003         zercnt = 0;
7004         /* Version must be '1' */
7005         if (vmspath[i--] != '1')
7006           break;
7007         /* Version delimiter is one of ".;" */
7008         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7009           break;
7010         i--;
7011         if (vmspath[i--] != 'R')
7012           break;
7013         if (vmspath[i--] != 'I')
7014           break;
7015         if (vmspath[i--] != 'D')
7016           break;
7017         if (vmspath[i--] != '.')
7018           break;
7019         eptr = &vmspath[i+1];
7020         while (i > 0) {
7021           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7022             if (vmspath[i-1] != '^') {
7023               if (zercnt != 6) {
7024                 *eptr = vmspath[i];
7025                 eptr[1] = '\0';
7026                 vmspath[i] = '.';
7027                 break;
7028               }
7029               else {
7030                 /* Get rid of 6 imaginary zero directory filename */
7031                 vmspath[i+1] = '\0';
7032               }
7033             }
7034           }
7035           if (vmspath[i] == '0')
7036             zercnt++;
7037           else
7038             zercnt = 10;
7039           i--;
7040         }
7041         break;
7042       }
7043     }
7044   }
7045   PerlMem_free(esal);
7046   return sts;
7047 }
7048
7049 /* /dev/mumble needs to be handled special.
7050    /dev/null becomes NLA0:, And there is the potential for other stuff
7051    like /dev/tty which may need to be mapped to something.
7052 */
7053
7054 static int
7055 slash_dev_special_to_vms
7056    (const char * unixptr,
7057     char * vmspath,
7058     int vmspath_len)
7059 {
7060 char * nextslash;
7061 int len;
7062 int cmp;
7063 int islnm;
7064
7065     unixptr += 4;
7066     nextslash = strchr(unixptr, '/');
7067     len = strlen(unixptr);
7068     if (nextslash != NULL)
7069         len = nextslash - unixptr;
7070     cmp = strncmp("null", unixptr, 5);
7071     if (cmp == 0) {
7072         if (vmspath_len >= 6) {
7073             strcpy(vmspath, "_NLA0:");
7074             return SS$_NORMAL;
7075         }
7076     }
7077 }
7078
7079
7080 /* The built in routines do not understand perl's special needs, so
7081     doing a manual conversion from UNIX to VMS
7082
7083     If the utf8_fl is not null and points to a non-zero value, then
7084     treat 8 bit characters as UTF-8.
7085
7086     The sequence starting with '$(' and ending with ')' will be passed
7087     through with out interpretation instead of being escaped.
7088
7089   */
7090 static int posix_to_vmsspec_hardway
7091   (char *vmspath, int vmspath_len,
7092    const char *unixpath,
7093    int dir_flag,
7094    int * utf8_fl) {
7095
7096 char *esa;
7097 const char *unixptr;
7098 const char *unixend;
7099 char *vmsptr;
7100 const char *lastslash;
7101 const char *lastdot;
7102 int unixlen;
7103 int vmslen;
7104 int dir_start;
7105 int dir_dot;
7106 int quoted;
7107 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7108 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7109
7110   if (utf8_fl != NULL)
7111     *utf8_fl = 0;
7112
7113   unixptr = unixpath;
7114   dir_dot = 0;
7115
7116   /* Ignore leading "/" characters */
7117   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7118     unixptr++;
7119   }
7120   unixlen = strlen(unixptr);
7121
7122   /* Do nothing with blank paths */
7123   if (unixlen == 0) {
7124     vmspath[0] = '\0';
7125     return SS$_NORMAL;
7126   }
7127
7128   quoted = 0;
7129   /* This could have a "^UP^ on the front */
7130   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7131     quoted = 1;
7132     unixptr+= 5;
7133     unixlen-= 5;
7134   }
7135
7136   lastslash = strrchr(unixptr,'/');
7137   lastdot = strrchr(unixptr,'.');
7138   unixend = strrchr(unixptr,'\"');
7139   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7140     unixend = unixptr + unixlen;
7141   }
7142
7143   /* last dot is last dot or past end of string */
7144   if (lastdot == NULL)
7145     lastdot = unixptr + unixlen;
7146
7147   /* if no directories, set last slash to beginning of string */
7148   if (lastslash == NULL) {
7149     lastslash = unixptr;
7150   }
7151   else {
7152     /* Watch out for trailing "." after last slash, still a directory */
7153     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7154       lastslash = unixptr + unixlen;
7155     }
7156
7157     /* Watch out for traiing ".." after last slash, still a directory */
7158     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7159       lastslash = unixptr + unixlen;
7160     }
7161
7162     /* dots in directories are aways escaped */
7163     if (lastdot < lastslash)
7164       lastdot = unixptr + unixlen;
7165   }
7166
7167   /* if (unixptr < lastslash) then we are in a directory */
7168
7169   dir_start = 0;
7170
7171   vmsptr = vmspath;
7172   vmslen = 0;
7173
7174   /* Start with the UNIX path */
7175   if (*unixptr != '/') {
7176     /* relative paths */
7177
7178     /* If allowing logical names on relative pathnames, then handle here */
7179     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7180         !decc_posix_compliant_pathnames) {
7181     char * nextslash;
7182     int seg_len;
7183     char * trn;
7184     int islnm;
7185
7186         /* Find the next slash */
7187         nextslash = strchr(unixptr,'/');
7188
7189         esa = PerlMem_malloc(vmspath_len);
7190         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7191
7192         trn = PerlMem_malloc(VMS_MAXRSS);
7193         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7194
7195         if (nextslash != NULL) {
7196
7197             seg_len = nextslash - unixptr;
7198             strncpy(esa, unixptr, seg_len);
7199             esa[seg_len] = 0;
7200         }
7201         else {
7202             strcpy(esa, unixptr);
7203             seg_len = strlen(unixptr);
7204         }
7205         /* trnlnm(section) */
7206         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7207
7208         if (islnm) {
7209             /* Now fix up the directory */
7210
7211             /* Split up the path to find the components */
7212             sts = vms_split_path
7213                   (trn,
7214                    &v_spec,
7215                    &v_len,
7216                    &r_spec,
7217                    &r_len,
7218                    &d_spec,
7219                    &d_len,
7220                    &n_spec,
7221                    &n_len,
7222                    &e_spec,
7223                    &e_len,
7224                    &vs_spec,
7225                    &vs_len);
7226
7227             while (sts == 0) {
7228             char * strt;
7229             int cmp;
7230
7231                 /* A logical name must be a directory  or the full
7232                    specification.  It is only a full specification if
7233                    it is the only component */
7234                 if ((unixptr[seg_len] == '\0') ||
7235                     (unixptr[seg_len+1] == '\0')) {
7236
7237                     /* Is a directory being required? */
7238                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7239                         /* Not a logical name */
7240                         break;
7241                     }
7242
7243
7244                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7245                         /* This must be a directory */
7246                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7247                             strcpy(vmsptr, esa);
7248                             vmslen=strlen(vmsptr);
7249                             vmsptr[vmslen] = ':';
7250                             vmslen++;
7251                             vmsptr[vmslen] = '\0';
7252                             return SS$_NORMAL;
7253                         }
7254                     }
7255
7256                 }
7257
7258
7259                 /* must be dev/directory - ignore version */
7260                 if ((n_len + e_len) != 0)
7261                     break;
7262
7263                 /* transfer the volume */
7264                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7265                     strncpy(vmsptr, v_spec, v_len);
7266                     vmsptr += v_len;
7267                     vmsptr[0] = '\0';
7268                     vmslen += v_len;
7269                 }
7270
7271                 /* unroot the rooted directory */
7272                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7273                     r_spec[0] = '[';
7274                     r_spec[r_len - 1] = ']';
7275
7276                     /* This should not be there, but nothing is perfect */
7277                     if (r_len > 9) {
7278                         cmp = strcmp(&r_spec[1], "000000.");
7279                         if (cmp == 0) {
7280                             r_spec += 7;
7281                             r_spec[7] = '[';
7282                             r_len -= 7;
7283                             if (r_len == 2)
7284                                 r_len = 0;
7285                         }
7286                     }
7287                     if (r_len > 0) {
7288                         strncpy(vmsptr, r_spec, r_len);
7289                         vmsptr += r_len;
7290                         vmslen += r_len;
7291                         vmsptr[0] = '\0';
7292                     }
7293                 }
7294                 /* Bring over the directory. */
7295                 if ((d_len > 0) &&
7296                     ((d_len + vmslen) < vmspath_len)) {
7297                     d_spec[0] = '[';
7298                     d_spec[d_len - 1] = ']';
7299                     if (d_len > 9) {
7300                         cmp = strcmp(&d_spec[1], "000000.");
7301                         if (cmp == 0) {
7302                             d_spec += 7;
7303                             d_spec[7] = '[';
7304                             d_len -= 7;
7305                             if (d_len == 2)
7306                                 d_len = 0;
7307                         }
7308                     }
7309
7310                     if (r_len > 0) {
7311                         /* Remove the redundant root */
7312                         if (r_len > 0) {
7313                             /* remove the ][ */
7314                             vmsptr--;
7315                             vmslen--;
7316                             d_spec++;
7317                             d_len--;
7318                         }
7319                         strncpy(vmsptr, d_spec, d_len);
7320                             vmsptr += d_len;
7321                             vmslen += d_len;
7322                             vmsptr[0] = '\0';
7323                     }
7324                 }
7325                 break;
7326             }
7327         }
7328
7329         PerlMem_free(esa);
7330         PerlMem_free(trn);
7331     }
7332
7333     if (lastslash > unixptr) {
7334     int dotdir_seen;
7335
7336       /* skip leading ./ */
7337       dotdir_seen = 0;
7338       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7339         dotdir_seen = 1;
7340         unixptr++;
7341         unixptr++;
7342       }
7343
7344       /* Are we still in a directory? */
7345       if (unixptr <= lastslash) {
7346         *vmsptr++ = '[';
7347         vmslen = 1;
7348         dir_start = 1;
7349
7350         /* if not backing up, then it is relative forward. */
7351         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7352               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7353           *vmsptr++ = '.';
7354           vmslen++;
7355           dir_dot = 1;
7356           }
7357        }
7358        else {
7359          if (dotdir_seen) {
7360            /* Perl wants an empty directory here to tell the difference
7361             * between a DCL commmand and a filename
7362             */
7363           *vmsptr++ = '[';
7364           *vmsptr++ = ']';
7365           vmslen = 2;
7366         }
7367       }
7368     }
7369     else {
7370       /* Handle two special files . and .. */
7371       if (unixptr[0] == '.') {
7372         if (&unixptr[1] == unixend) {
7373           *vmsptr++ = '[';
7374           *vmsptr++ = ']';
7375           vmslen += 2;
7376           *vmsptr++ = '\0';
7377           return SS$_NORMAL;
7378         }
7379         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7380           *vmsptr++ = '[';
7381           *vmsptr++ = '-';
7382           *vmsptr++ = ']';
7383           vmslen += 3;
7384           *vmsptr++ = '\0';
7385           return SS$_NORMAL;
7386         }
7387       }
7388     }
7389   }
7390   else {        /* Absolute PATH handling */
7391   int sts;
7392   char * nextslash;
7393   int seg_len;
7394     /* Need to find out where root is */
7395
7396     /* In theory, this procedure should never get an absolute POSIX pathname
7397      * that can not be found on the POSIX root.
7398      * In practice, that can not be relied on, and things will show up
7399      * here that are a VMS device name or concealed logical name instead.
7400      * So to make things work, this procedure must be tolerant.
7401      */
7402     esa = PerlMem_malloc(vmspath_len);
7403     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7404
7405     sts = SS$_NORMAL;
7406     nextslash = strchr(&unixptr[1],'/');
7407     seg_len = 0;
7408     if (nextslash != NULL) {
7409     int cmp;
7410       seg_len = nextslash - &unixptr[1];
7411       strncpy(vmspath, unixptr, seg_len + 1);
7412       vmspath[seg_len+1] = 0;
7413       cmp = 1;
7414       if (seg_len == 3) {
7415         cmp = strncmp(vmspath, "dev", 4);
7416         if (cmp == 0) {
7417             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7418             if (sts = SS$_NORMAL)
7419                 return SS$_NORMAL;
7420         }
7421       }
7422       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7423     }
7424
7425     if ($VMS_STATUS_SUCCESS(sts)) {
7426       /* This is verified to be a real path */
7427
7428       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7429       if ($VMS_STATUS_SUCCESS(sts)) {
7430         strcpy(vmspath, esa);
7431         vmslen = strlen(vmspath);
7432         vmsptr = vmspath + vmslen;
7433         unixptr++;
7434         if (unixptr < lastslash) {
7435         char * rptr;
7436           vmsptr--;
7437           *vmsptr++ = '.';
7438           dir_start = 1;
7439           dir_dot = 1;
7440           if (vmslen > 7) {
7441           int cmp;
7442             rptr = vmsptr - 7;
7443             cmp = strcmp(rptr,"000000.");
7444             if (cmp == 0) {
7445               vmslen -= 7;
7446               vmsptr -= 7;
7447               vmsptr[1] = '\0';
7448             } /* removing 6 zeros */
7449           } /* vmslen < 7, no 6 zeros possible */
7450         } /* Not in a directory */
7451       } /* Posix root found */
7452       else {
7453         /* No posix root, fall back to default directory */
7454         strcpy(vmspath, "SYS$DISK:[");
7455         vmsptr = &vmspath[10];
7456         vmslen = 10;
7457         if (unixptr > lastslash) {
7458            *vmsptr = ']';
7459            vmsptr++;
7460            vmslen++;
7461         }
7462         else {
7463            dir_start = 1;
7464         }
7465       }
7466     } /* end of verified real path handling */
7467     else {
7468     int add_6zero;
7469     int islnm;
7470
7471       /* Ok, we have a device or a concealed root that is not in POSIX
7472        * or we have garbage.  Make the best of it.
7473        */
7474
7475       /* Posix to VMS destroyed this, so copy it again */
7476       strncpy(vmspath, &unixptr[1], seg_len);
7477       vmspath[seg_len] = 0;
7478       vmslen = seg_len;
7479       vmsptr = &vmsptr[vmslen];
7480       islnm = 0;
7481
7482       /* Now do we need to add the fake 6 zero directory to it? */
7483       add_6zero = 1;
7484       if ((*lastslash == '/') && (nextslash < lastslash)) {
7485         /* No there is another directory */
7486         add_6zero = 0;
7487       }
7488       else {
7489       int trnend;
7490       int cmp;
7491
7492         /* now we have foo:bar or foo:[000000]bar to decide from */
7493         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7494
7495         if (!islnm && !decc_posix_compliant_pathnames) {
7496
7497             cmp = strncmp("bin", vmspath, 4);
7498             if (cmp == 0) {
7499                 /* bin => SYS$SYSTEM: */
7500                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7501             }
7502             else {
7503                 /* tmp => SYS$SCRATCH: */
7504                 cmp = strncmp("tmp", vmspath, 4);
7505                 if (cmp == 0) {
7506                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7507                 }
7508             }
7509         }
7510
7511         trnend = islnm ? islnm - 1 : 0;
7512
7513         /* if this was a logical name, ']' or '>' must be present */
7514         /* if not a logical name, then assume a device and hope. */
7515         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7516
7517         /* if log name and trailing '.' then rooted - treat as device */
7518         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7519
7520         /* Fix me, if not a logical name, a device lookup should be
7521          * done to see if the device is file structured.  If the device
7522          * is not file structured, the 6 zeros should not be put on.
7523          *
7524          * As it is, perl is occasionally looking for dev:[000000]tty.
7525          * which looks a little strange.
7526          *
7527          * Not that easy to detect as "/dev" may be file structured with
7528          * special device files.
7529          */
7530
7531         if ((add_6zero == 0) && (*nextslash == '/') &&
7532             (&nextslash[1] == unixend)) {
7533           /* No real directory present */
7534           add_6zero = 1;
7535         }
7536       }
7537
7538       /* Put the device delimiter on */
7539       *vmsptr++ = ':';
7540       vmslen++;
7541       unixptr = nextslash;
7542       unixptr++;
7543
7544       /* Start directory if needed */
7545       if (!islnm || add_6zero) {
7546         *vmsptr++ = '[';
7547         vmslen++;
7548         dir_start = 1;
7549       }
7550
7551       /* add fake 000000] if needed */
7552       if (add_6zero) {
7553         *vmsptr++ = '0';
7554         *vmsptr++ = '0';
7555         *vmsptr++ = '0';
7556         *vmsptr++ = '0';
7557         *vmsptr++ = '0';
7558         *vmsptr++ = '0';
7559         *vmsptr++ = ']';
7560         vmslen += 7;
7561         dir_start = 0;
7562       }
7563
7564     } /* non-POSIX translation */
7565     PerlMem_free(esa);
7566   } /* End of relative/absolute path handling */
7567
7568   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7569   int dash_flag;
7570   int in_cnt;
7571   int out_cnt;
7572
7573     dash_flag = 0;
7574
7575     if (dir_start != 0) {
7576
7577       /* First characters in a directory are handled special */
7578       while ((*unixptr == '/') ||
7579              ((*unixptr == '.') &&
7580               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7581                 (&unixptr[1]==unixend)))) {
7582       int loop_flag;
7583
7584         loop_flag = 0;
7585
7586         /* Skip redundant / in specification */
7587         while ((*unixptr == '/') && (dir_start != 0)) {
7588           loop_flag = 1;
7589           unixptr++;
7590           if (unixptr == lastslash)
7591             break;
7592         }
7593         if (unixptr == lastslash)
7594           break;
7595
7596         /* Skip redundant ./ characters */
7597         while ((*unixptr == '.') &&
7598                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
7599           loop_flag = 1;
7600           unixptr++;
7601           if (unixptr == lastslash)
7602             break;
7603           if (*unixptr == '/')
7604             unixptr++;
7605         }
7606         if (unixptr == lastslash)
7607           break;
7608
7609         /* Skip redundant ../ characters */
7610         while ((*unixptr == '.') && (unixptr[1] == '.') &&
7611              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
7612           /* Set the backing up flag */
7613           loop_flag = 1;
7614           dir_dot = 0;
7615           dash_flag = 1;
7616           *vmsptr++ = '-';
7617           vmslen++;
7618           unixptr++; /* first . */
7619           unixptr++; /* second . */
7620           if (unixptr == lastslash)
7621             break;
7622           if (*unixptr == '/') /* The slash */
7623             unixptr++;
7624         }
7625         if (unixptr == lastslash)
7626           break;
7627
7628         /* To do: Perl expects /.../ to be translated to [...] on VMS */
7629         /* Not needed when VMS is pretending to be UNIX. */
7630
7631         /* Is this loop stuck because of too many dots? */
7632         if (loop_flag == 0) {
7633           /* Exit the loop and pass the rest through */
7634           break;
7635         }
7636       }
7637
7638       /* Are we done with directories yet? */
7639       if (unixptr >= lastslash) {
7640
7641         /* Watch out for trailing dots */
7642         if (dir_dot != 0) {
7643             vmslen --;
7644             vmsptr--;
7645         }
7646         *vmsptr++ = ']';
7647         vmslen++;
7648         dash_flag = 0;
7649         dir_start = 0;
7650         if (*unixptr == '/')
7651           unixptr++;
7652       }
7653       else {
7654         /* Have we stopped backing up? */
7655         if (dash_flag) {
7656           *vmsptr++ = '.';
7657           vmslen++;
7658           dash_flag = 0;
7659           /* dir_start continues to be = 1 */
7660         }
7661         if (*unixptr == '-') {
7662           *vmsptr++ = '^';
7663           *vmsptr++ = *unixptr++;
7664           vmslen += 2;
7665           dir_start = 0;
7666
7667           /* Now are we done with directories yet? */
7668           if (unixptr >= lastslash) {
7669
7670             /* Watch out for trailing dots */
7671             if (dir_dot != 0) {
7672               vmslen --;
7673               vmsptr--;
7674             }
7675
7676             *vmsptr++ = ']';
7677             vmslen++;
7678             dash_flag = 0;
7679             dir_start = 0;
7680           }
7681         }
7682       }
7683     }
7684
7685     /* All done? */
7686     if (unixptr >= unixend)
7687       break;
7688
7689     /* Normal characters - More EFS work probably needed */
7690     dir_start = 0;
7691     dir_dot = 0;
7692
7693     switch(*unixptr) {
7694     case '/':
7695         /* remove multiple / */
7696         while (unixptr[1] == '/') {
7697            unixptr++;
7698         }
7699         if (unixptr == lastslash) {
7700           /* Watch out for trailing dots */
7701           if (dir_dot != 0) {
7702             vmslen --;
7703             vmsptr--;
7704           }
7705           *vmsptr++ = ']';
7706         }
7707         else {
7708           dir_start = 1;
7709           *vmsptr++ = '.';
7710           dir_dot = 1;
7711
7712           /* To do: Perl expects /.../ to be translated to [...] on VMS */
7713           /* Not needed when VMS is pretending to be UNIX. */
7714
7715         }
7716         dash_flag = 0;
7717         if (unixptr != unixend)
7718           unixptr++;
7719         vmslen++;
7720         break;
7721     case '.':
7722         if ((unixptr < lastdot) || (unixptr < lastslash) ||
7723             (&unixptr[1] == unixend)) {
7724           *vmsptr++ = '^';
7725           *vmsptr++ = '.';
7726           vmslen += 2;
7727           unixptr++;
7728
7729           /* trailing dot ==> '^..' on VMS */
7730           if (unixptr == unixend) {
7731             *vmsptr++ = '.';
7732             vmslen++;
7733             unixptr++;
7734           }
7735           break;
7736         }
7737
7738         *vmsptr++ = *unixptr++;
7739         vmslen ++;
7740         break;
7741     case '"':
7742         if (quoted && (&unixptr[1] == unixend)) {
7743             unixptr++;
7744             break;
7745         }
7746         in_cnt = copy_expand_unix_filename_escape
7747                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7748         vmsptr += out_cnt;
7749         unixptr += in_cnt;
7750         break;
7751     case '~':
7752     case ';':
7753     case '\\':
7754     case '?':
7755     case ' ':
7756     default:
7757         in_cnt = copy_expand_unix_filename_escape
7758                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7759         vmsptr += out_cnt;
7760         unixptr += in_cnt;
7761         break;
7762     }
7763   }
7764
7765   /* Make sure directory is closed */
7766   if (unixptr == lastslash) {
7767     char *vmsptr2;
7768     vmsptr2 = vmsptr - 1;
7769
7770     if (*vmsptr2 != ']') {
7771       *vmsptr2--;
7772
7773       /* directories do not end in a dot bracket */
7774       if (*vmsptr2 == '.') {
7775         vmsptr2--;
7776
7777         /* ^. is allowed */
7778         if (*vmsptr2 != '^') {
7779           vmsptr--; /* back up over the dot */
7780         }
7781       }
7782       *vmsptr++ = ']';
7783     }
7784   }
7785   else {
7786     char *vmsptr2;
7787     /* Add a trailing dot if a file with no extension */
7788     vmsptr2 = vmsptr - 1;
7789     if ((vmslen > 1) &&
7790         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7791         (*vmsptr2 != ')') && (*lastdot != '.')) {
7792         *vmsptr++ = '.';
7793         vmslen++;
7794     }
7795   }
7796
7797   *vmsptr = '\0';
7798   return SS$_NORMAL;
7799 }
7800 #endif
7801
7802  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7803 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7804 {
7805 char * result;
7806 int utf8_flag;
7807
7808    /* If a UTF8 flag is being passed, honor it */
7809    utf8_flag = 0;
7810    if (utf8_fl != NULL) {
7811      utf8_flag = *utf8_fl;
7812     *utf8_fl = 0;
7813    }
7814
7815    if (utf8_flag) {
7816      /* If there is a possibility of UTF8, then if any UTF8 characters
7817         are present, then they must be converted to VTF-7
7818       */
7819      result = strcpy(rslt, path); /* FIX-ME */
7820    }
7821    else
7822      result = strcpy(rslt, path);
7823
7824    return result;
7825 }
7826
7827
7828 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7829 static char *mp_do_tovmsspec
7830    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7831   static char __tovmsspec_retbuf[VMS_MAXRSS];
7832   char *rslt, *dirend;
7833   char *lastdot;
7834   char *vms_delim;
7835   register char *cp1;
7836   const char *cp2;
7837   unsigned long int infront = 0, hasdir = 1;
7838   int rslt_len;
7839   int no_type_seen;
7840   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7841   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7842
7843   if (path == NULL) return NULL;
7844   rslt_len = VMS_MAXRSS-1;
7845   if (buf) rslt = buf;
7846   else if (ts) Newx(rslt, VMS_MAXRSS, char);
7847   else rslt = __tovmsspec_retbuf;
7848
7849   /* '.' and '..' are "[]" and "[-]" for a quick check */
7850   if (path[0] == '.') {
7851     if (path[1] == '\0') {
7852       strcpy(rslt,"[]");
7853       if (utf8_flag != NULL)
7854         *utf8_flag = 0;
7855       return rslt;
7856     }
7857     else {
7858       if (path[1] == '.' && path[2] == '\0') {
7859         strcpy(rslt,"[-]");
7860         if (utf8_flag != NULL)
7861            *utf8_flag = 0;
7862         return rslt;
7863       }
7864     }
7865   }
7866
7867    /* Posix specifications are now a native VMS format */
7868   /*--------------------------------------------------*/
7869 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7870   if (decc_posix_compliant_pathnames) {
7871     if (strncmp(path,"\"^UP^",5) == 0) {
7872       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7873       return rslt;
7874     }
7875   }
7876 #endif
7877
7878   /* This is really the only way to see if this is already in VMS format */
7879   sts = vms_split_path
7880        (path,
7881         &v_spec,
7882         &v_len,
7883         &r_spec,
7884         &r_len,
7885         &d_spec,
7886         &d_len,
7887         &n_spec,
7888         &n_len,
7889         &e_spec,
7890         &e_len,
7891         &vs_spec,
7892         &vs_len);
7893   if (sts == 0) {
7894     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7895        replacement, because the above parse just took care of most of
7896        what is needed to do vmspath when the specification is already
7897        in VMS format.
7898
7899        And if it is not already, it is easier to do the conversion as
7900        part of this routine than to call this routine and then work on
7901        the result.
7902      */
7903
7904     /* If VMS punctuation was found, it is already VMS format */
7905     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7906       if (utf8_flag != NULL)
7907         *utf8_flag = 0;
7908       strcpy(rslt, path);
7909       return rslt;
7910     }
7911     /* Now, what to do with trailing "." cases where there is no
7912        extension?  If this is a UNIX specification, and EFS characters
7913        are enabled, then the trailing "." should be converted to a "^.".
7914        But if this was already a VMS specification, then it should be
7915        left alone.
7916
7917        So in the case of ambiguity, leave the specification alone.
7918      */
7919
7920
7921     /* If there is a possibility of UTF8, then if any UTF8 characters
7922         are present, then they must be converted to VTF-7
7923      */
7924     if (utf8_flag != NULL)
7925       *utf8_flag = 0;
7926     strcpy(rslt, path);
7927     return rslt;
7928   }
7929
7930   dirend = strrchr(path,'/');
7931
7932   if (dirend == NULL) {
7933      /* If we get here with no UNIX directory delimiters, then this is
7934         not a complete file specification, either garbage a UNIX glob
7935         specification that can not be converted to a VMS wildcard, or
7936         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7937         so apparently other programs expect this also.
7938
7939         utf8 flag setting needs to be preserved.
7940       */
7941       strcpy(rslt, path);
7942       return rslt;
7943   }
7944
7945 /* If POSIX mode active, handle the conversion */
7946 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7947   if (decc_efs_charset) {
7948     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7949     return rslt;
7950   }
7951 #endif
7952
7953   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7954     if (!*(dirend+2)) dirend +=2;
7955     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7956     if (decc_efs_charset == 0) {
7957       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7958     }
7959   }
7960
7961   cp1 = rslt;
7962   cp2 = path;
7963   lastdot = strrchr(cp2,'.');
7964   if (*cp2 == '/') {
7965     char *trndev;
7966     int islnm, rooted;
7967     STRLEN trnend;
7968
7969     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7970     if (!*(cp2+1)) {
7971       if (decc_disable_posix_root) {
7972         strcpy(rslt,"sys$disk:[000000]");
7973       }
7974       else {
7975         strcpy(rslt,"sys$posix_root:[000000]");
7976       }
7977       if (utf8_flag != NULL)
7978         *utf8_flag = 0;
7979       return rslt;
7980     }
7981     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7982     *cp1 = '\0';
7983     trndev = PerlMem_malloc(VMS_MAXRSS);
7984     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7985     islnm =  my_trnlnm(rslt,trndev,0);
7986
7987      /* DECC special handling */
7988     if (!islnm) {
7989       if (strcmp(rslt,"bin") == 0) {
7990         strcpy(rslt,"sys$system");
7991         cp1 = rslt + 10;
7992         *cp1 = 0;
7993         islnm =  my_trnlnm(rslt,trndev,0);
7994       }
7995       else if (strcmp(rslt,"tmp") == 0) {
7996         strcpy(rslt,"sys$scratch");
7997         cp1 = rslt + 11;
7998         *cp1 = 0;
7999         islnm =  my_trnlnm(rslt,trndev,0);
8000       }
8001       else if (!decc_disable_posix_root) {
8002         strcpy(rslt, "sys$posix_root");
8003         cp1 = rslt + 13;
8004         *cp1 = 0;
8005         cp2 = path;
8006         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8007         islnm =  my_trnlnm(rslt,trndev,0);
8008       }
8009       else if (strcmp(rslt,"dev") == 0) {
8010         if (strncmp(cp2,"/null", 5) == 0) {
8011           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8012             strcpy(rslt,"NLA0");
8013             cp1 = rslt + 4;
8014             *cp1 = 0;
8015             cp2 = cp2 + 5;
8016             islnm =  my_trnlnm(rslt,trndev,0);
8017           }
8018         }
8019       }
8020     }
8021
8022     trnend = islnm ? strlen(trndev) - 1 : 0;
8023     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8024     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8025     /* If the first element of the path is a logical name, determine
8026      * whether it has to be translated so we can add more directories. */
8027     if (!islnm || rooted) {
8028       *(cp1++) = ':';
8029       *(cp1++) = '[';
8030       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8031       else cp2++;
8032     }
8033     else {
8034       if (cp2 != dirend) {
8035         strcpy(rslt,trndev);
8036         cp1 = rslt + trnend;
8037         if (*cp2 != 0) {
8038           *(cp1++) = '.';
8039           cp2++;
8040         }
8041       }
8042       else {
8043         if (decc_disable_posix_root) {
8044           *(cp1++) = ':';
8045           hasdir = 0;
8046         }
8047       }
8048     }
8049     PerlMem_free(trndev);
8050   }
8051   else {
8052     *(cp1++) = '[';
8053     if (*cp2 == '.') {
8054       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8055         cp2 += 2;         /* skip over "./" - it's redundant */
8056         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8057       }
8058       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8059         *(cp1++) = '-';                                 /* "../" --> "-" */
8060         cp2 += 3;
8061       }
8062       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8063                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8064         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8065         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8066         cp2 += 4;
8067       }
8068       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8069         /* Escape the extra dots in EFS file specifications */
8070         *(cp1++) = '^';
8071       }
8072       if (cp2 > dirend) cp2 = dirend;
8073     }
8074     else *(cp1++) = '.';
8075   }
8076   for (; cp2 < dirend; cp2++) {
8077     if (*cp2 == '/') {
8078       if (*(cp2-1) == '/') continue;
8079       if (*(cp1-1) != '.') *(cp1++) = '.';
8080       infront = 0;
8081     }
8082     else if (!infront && *cp2 == '.') {
8083       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8084       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8085       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8086         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8087         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8088         else {  /* back up over previous directory name */
8089           cp1--;
8090           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8091           if (*(cp1-1) == '[') {
8092             memcpy(cp1,"000000.",7);
8093             cp1 += 7;
8094           }
8095         }
8096         cp2 += 2;
8097         if (cp2 == dirend) break;
8098       }
8099       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8100                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8101         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8102         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8103         if (!*(cp2+3)) {
8104           *(cp1++) = '.';  /* Simulate trailing '/' */
8105           cp2 += 2;  /* for loop will incr this to == dirend */
8106         }
8107         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8108       }
8109       else {
8110         if (decc_efs_charset == 0)
8111           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8112         else {
8113           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8114           *(cp1++) = '.';
8115         }
8116       }
8117     }
8118     else {
8119       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8120       if (*cp2 == '.') {
8121         if (decc_efs_charset == 0)
8122           *(cp1++) = '_';
8123         else {
8124           *(cp1++) = '^';
8125           *(cp1++) = '.';
8126         }
8127       }
8128       else                  *(cp1++) =  *cp2;
8129       infront = 1;
8130     }
8131   }
8132   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8133   if (hasdir) *(cp1++) = ']';
8134   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8135   /* fixme for ODS5 */
8136   no_type_seen = 0;
8137   if (cp2 > lastdot)
8138     no_type_seen = 1;
8139   while (*cp2) {
8140     switch(*cp2) {
8141     case '?':
8142         if (decc_efs_charset == 0)
8143           *(cp1++) = '%';
8144         else
8145           *(cp1++) = '?';
8146         cp2++;
8147     case ' ':
8148         *(cp1)++ = '^';
8149         *(cp1)++ = '_';
8150         cp2++;
8151         break;
8152     case '.':
8153         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8154             decc_readdir_dropdotnotype) {
8155           *(cp1)++ = '^';
8156           *(cp1)++ = '.';
8157           cp2++;
8158
8159           /* trailing dot ==> '^..' on VMS */
8160           if (*cp2 == '\0') {
8161             *(cp1++) = '.';
8162             no_type_seen = 0;
8163           }
8164         }
8165         else {
8166           *(cp1++) = *(cp2++);
8167           no_type_seen = 0;
8168         }
8169         break;
8170     case '$':
8171          /* This could be a macro to be passed through */
8172         *(cp1++) = *(cp2++);
8173         if (*cp2 == '(') {
8174         const char * save_cp2;
8175         char * save_cp1;
8176         int is_macro;
8177
8178             /* paranoid check */
8179             save_cp2 = cp2;
8180             save_cp1 = cp1;
8181             is_macro = 0;
8182
8183             /* Test through */
8184             *(cp1++) = *(cp2++);
8185             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8186                 *(cp1++) = *(cp2++);
8187                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8188                     *(cp1++) = *(cp2++);
8189                 }
8190                 if (*cp2 == ')') {
8191                     *(cp1++) = *(cp2++);
8192                     is_macro = 1;
8193                 }
8194             }
8195             if (is_macro == 0) {
8196                 /* Not really a macro - never mind */
8197                 cp2 = save_cp2;
8198                 cp1 = save_cp1;
8199             }
8200         }
8201         break;
8202     case '\"':
8203     case '~':
8204     case '`':
8205     case '!':
8206     case '#':
8207     case '%':
8208     case '^':
8209         /* Don't escape again if following character is
8210          * already something we escape.
8211          */
8212         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8213             *(cp1++) = *(cp2++);
8214             break;
8215         }
8216         /* But otherwise fall through and escape it. */
8217     case '&':
8218     case '(':
8219     case ')':
8220     case '=':
8221     case '+':
8222     case '\'':
8223     case '@':
8224     case '[':
8225     case ']':
8226     case '{':
8227     case '}':
8228     case ':':
8229     case '\\':
8230     case '|':
8231     case '<':
8232     case '>':
8233         *(cp1++) = '^';
8234         *(cp1++) = *(cp2++);
8235         break;
8236     case ';':
8237         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8238          * which is wrong.  UNIX notation should be ".dir." unless
8239          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8240          * changing this behavior could break more things at this time.
8241          * efs character set effectively does not allow "." to be a version
8242          * delimiter as a further complication about changing this.
8243          */
8244         if (decc_filename_unix_report != 0) {
8245           *(cp1++) = '^';
8246         }
8247         *(cp1++) = *(cp2++);
8248         break;
8249     default:
8250         *(cp1++) = *(cp2++);
8251     }
8252   }
8253   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8254   char *lcp1;
8255     lcp1 = cp1;
8256     lcp1--;
8257      /* Fix me for "^]", but that requires making sure that you do
8258       * not back up past the start of the filename
8259       */
8260     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8261       *cp1++ = '.';
8262   }
8263   *cp1 = '\0';
8264
8265   if (utf8_flag != NULL)
8266     *utf8_flag = 0;
8267   return rslt;
8268
8269 }  /* end of do_tovmsspec() */
8270 /*}}}*/
8271 /* External entry points */
8272 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8273   { return do_tovmsspec(path,buf,0,NULL); }
8274 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8275   { return do_tovmsspec(path,buf,1,NULL); }
8276 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8277   { return do_tovmsspec(path,buf,0,utf8_fl); }
8278 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8279   { return do_tovmsspec(path,buf,1,utf8_fl); }
8280
8281 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8282 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8283   static char __tovmspath_retbuf[VMS_MAXRSS];
8284   int vmslen;
8285   char *pathified, *vmsified, *cp;
8286
8287   if (path == NULL) return NULL;
8288   pathified = PerlMem_malloc(VMS_MAXRSS);
8289   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8290   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8291     PerlMem_free(pathified);
8292     return NULL;
8293   }
8294
8295   vmsified = NULL;
8296   if (buf == NULL)
8297      Newx(vmsified, VMS_MAXRSS, char);
8298   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8299     PerlMem_free(pathified);
8300     if (vmsified) Safefree(vmsified);
8301     return NULL;
8302   }
8303   PerlMem_free(pathified);
8304   if (buf) {
8305     return buf;
8306   }
8307   else if (ts) {
8308     vmslen = strlen(vmsified);
8309     Newx(cp,vmslen+1,char);
8310     memcpy(cp,vmsified,vmslen);
8311     cp[vmslen] = '\0';
8312     Safefree(vmsified);
8313     return cp;
8314   }
8315   else {
8316     strcpy(__tovmspath_retbuf,vmsified);
8317     Safefree(vmsified);
8318     return __tovmspath_retbuf;
8319   }
8320
8321 }  /* end of do_tovmspath() */
8322 /*}}}*/
8323 /* External entry points */
8324 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8325   { return do_tovmspath(path,buf,0, NULL); }
8326 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8327   { return do_tovmspath(path,buf,1, NULL); }
8328 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8329   { return do_tovmspath(path,buf,0,utf8_fl); }
8330 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8331   { return do_tovmspath(path,buf,1,utf8_fl); }
8332
8333
8334 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8335 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8336   static char __tounixpath_retbuf[VMS_MAXRSS];
8337   int unixlen;
8338   char *pathified, *unixified, *cp;
8339
8340   if (path == NULL) return NULL;
8341   pathified = PerlMem_malloc(VMS_MAXRSS);
8342   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8343   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8344     PerlMem_free(pathified);
8345     return NULL;
8346   }
8347
8348   unixified = NULL;
8349   if (buf == NULL) {
8350       Newx(unixified, VMS_MAXRSS, char);
8351   }
8352   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8353     PerlMem_free(pathified);
8354     if (unixified) Safefree(unixified);
8355     return NULL;
8356   }
8357   PerlMem_free(pathified);
8358   if (buf) {
8359     return buf;
8360   }
8361   else if (ts) {
8362     unixlen = strlen(unixified);
8363     Newx(cp,unixlen+1,char);
8364     memcpy(cp,unixified,unixlen);
8365     cp[unixlen] = '\0';
8366     Safefree(unixified);
8367     return cp;
8368   }
8369   else {
8370     strcpy(__tounixpath_retbuf,unixified);
8371     Safefree(unixified);
8372     return __tounixpath_retbuf;
8373   }
8374
8375 }  /* end of do_tounixpath() */
8376 /*}}}*/
8377 /* External entry points */
8378 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8379   { return do_tounixpath(path,buf,0,NULL); }
8380 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8381   { return do_tounixpath(path,buf,1,NULL); }
8382 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8383   { return do_tounixpath(path,buf,0,utf8_fl); }
8384 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8385   { return do_tounixpath(path,buf,1,utf8_fl); }
8386
8387 /*
8388  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8389  *
8390  *****************************************************************************
8391  *                                                                           *
8392  *  Copyright (C) 1989-1994, 2007 by                                         *
8393  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8394  *                                                                           *
8395  *  Permission is hereby granted for the reproduction of this software       *
8396  *  on condition that this copyright notice is included in source            *
8397  *  distributions of the software.  The code may be modified and             *
8398  *  distributed under the same terms as Perl itself.                         *
8399  *                                                                           *
8400  *  27-Aug-1994 Modified for inclusion in perl5                              *
8401  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8402  *****************************************************************************
8403  */
8404
8405 /*
8406  * getredirection() is intended to aid in porting C programs
8407  * to VMS (Vax-11 C).  The native VMS environment does not support
8408  * '>' and '<' I/O redirection, or command line wild card expansion,
8409  * or a command line pipe mechanism using the '|' AND background
8410  * command execution '&'.  All of these capabilities are provided to any
8411  * C program which calls this procedure as the first thing in the
8412  * main program.
8413  * The piping mechanism will probably work with almost any 'filter' type
8414  * of program.  With suitable modification, it may useful for other
8415  * portability problems as well.
8416  *
8417  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8418  */
8419 struct list_item
8420     {
8421     struct list_item *next;
8422     char *value;
8423     };
8424
8425 static void add_item(struct list_item **head,
8426                      struct list_item **tail,
8427                      char *value,
8428                      int *count);
8429
8430 static void mp_expand_wild_cards(pTHX_ char *item,
8431                                 struct list_item **head,
8432                                 struct list_item **tail,
8433                                 int *count);
8434
8435 static int background_process(pTHX_ int argc, char **argv);
8436
8437 static void pipe_and_fork(pTHX_ char **cmargv);
8438
8439 /*{{{ void getredirection(int *ac, char ***av)*/
8440 static void
8441 mp_getredirection(pTHX_ int *ac, char ***av)
8442 /*
8443  * Process vms redirection arg's.  Exit if any error is seen.
8444  * If getredirection() processes an argument, it is erased
8445  * from the vector.  getredirection() returns a new argc and argv value.
8446  * In the event that a background command is requested (by a trailing "&"),
8447  * this routine creates a background subprocess, and simply exits the program.
8448  *
8449  * Warning: do not try to simplify the code for vms.  The code
8450  * presupposes that getredirection() is called before any data is
8451  * read from stdin or written to stdout.
8452  *
8453  * Normal usage is as follows:
8454  *
8455  *      main(argc, argv)
8456  *      int             argc;
8457  *      char            *argv[];
8458  *      {
8459  *              getredirection(&argc, &argv);
8460  *      }
8461  */
8462 {
8463     int                 argc = *ac;     /* Argument Count         */
8464     char                **argv = *av;   /* Argument Vector        */
8465     char                *ap;            /* Argument pointer       */
8466     int                 j;              /* argv[] index           */
8467     int                 item_count = 0; /* Count of Items in List */
8468     struct list_item    *list_head = 0; /* First Item in List       */
8469     struct list_item    *list_tail;     /* Last Item in List        */
8470     char                *in = NULL;     /* Input File Name          */
8471     char                *out = NULL;    /* Output File Name         */
8472     char                *outmode = "w"; /* Mode to Open Output File */
8473     char                *err = NULL;    /* Error File Name          */
8474     char                *errmode = "w"; /* Mode to Open Error File  */
8475     int                 cmargc = 0;     /* Piped Command Arg Count  */
8476     char                **cmargv = NULL;/* Piped Command Arg Vector */
8477
8478     /*
8479      * First handle the case where the last thing on the line ends with
8480      * a '&'.  This indicates the desire for the command to be run in a
8481      * subprocess, so we satisfy that desire.
8482      */
8483     ap = argv[argc-1];
8484     if (0 == strcmp("&", ap))
8485        exit(background_process(aTHX_ --argc, argv));
8486     if (*ap && '&' == ap[strlen(ap)-1])
8487         {
8488         ap[strlen(ap)-1] = '\0';
8489        exit(background_process(aTHX_ argc, argv));
8490         }
8491     /*
8492      * Now we handle the general redirection cases that involve '>', '>>',
8493      * '<', and pipes '|'.
8494      */
8495     for (j = 0; j < argc; ++j)
8496         {
8497         if (0 == strcmp("<", argv[j]))
8498             {
8499             if (j+1 >= argc)
8500                 {
8501                 fprintf(stderr,"No input file after < on command line");
8502                 exit(LIB$_WRONUMARG);
8503                 }
8504             in = argv[++j];
8505             continue;
8506             }
8507         if ('<' == *(ap = argv[j]))
8508             {
8509             in = 1 + ap;
8510             continue;
8511             }
8512         if (0 == strcmp(">", ap))
8513             {
8514             if (j+1 >= argc)
8515                 {
8516                 fprintf(stderr,"No output file after > on command line");
8517                 exit(LIB$_WRONUMARG);
8518                 }
8519             out = argv[++j];
8520             continue;
8521             }
8522         if ('>' == *ap)
8523             {
8524             if ('>' == ap[1])
8525                 {
8526                 outmode = "a";
8527                 if ('\0' == ap[2])
8528                     out = argv[++j];
8529                 else
8530                     out = 2 + ap;
8531                 }
8532             else
8533                 out = 1 + ap;
8534             if (j >= argc)
8535                 {
8536                 fprintf(stderr,"No output file after > or >> on command line");
8537                 exit(LIB$_WRONUMARG);
8538                 }
8539             continue;
8540             }
8541         if (('2' == *ap) && ('>' == ap[1]))
8542             {
8543             if ('>' == ap[2])
8544                 {
8545                 errmode = "a";
8546                 if ('\0' == ap[3])
8547                     err = argv[++j];
8548                 else
8549                     err = 3 + ap;
8550                 }
8551             else
8552                 if ('\0' == ap[2])
8553                     err = argv[++j];
8554                 else
8555                     err = 2 + ap;
8556             if (j >= argc)
8557                 {
8558                 fprintf(stderr,"No output file after 2> or 2>> on command line");
8559                 exit(LIB$_WRONUMARG);
8560                 }
8561             continue;
8562             }
8563         if (0 == strcmp("|", argv[j]))
8564             {
8565             if (j+1 >= argc)
8566                 {
8567                 fprintf(stderr,"No command into which to pipe on command line");
8568                 exit(LIB$_WRONUMARG);
8569                 }
8570             cmargc = argc-(j+1);
8571             cmargv = &argv[j+1];
8572             argc = j;
8573             continue;
8574             }
8575         if ('|' == *(ap = argv[j]))
8576             {
8577             ++argv[j];
8578             cmargc = argc-j;
8579             cmargv = &argv[j];
8580             argc = j;
8581             continue;
8582             }
8583         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
8584         }
8585     /*
8586      * Allocate and fill in the new argument vector, Some Unix's terminate
8587      * the list with an extra null pointer.
8588      */
8589     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
8590     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8591     *av = argv;
8592     for (j = 0; j < item_count; ++j, list_head = list_head->next)
8593         argv[j] = list_head->value;
8594     *ac = item_count;
8595     if (cmargv != NULL)
8596         {
8597         if (out != NULL)
8598             {
8599             fprintf(stderr,"'|' and '>' may not both be specified on command line");
8600             exit(LIB$_INVARGORD);
8601             }
8602         pipe_and_fork(aTHX_ cmargv);
8603         }
8604
8605     /* Check for input from a pipe (mailbox) */
8606
8607     if (in == NULL && 1 == isapipe(0))
8608         {
8609         char mbxname[L_tmpnam];
8610         long int bufsize;
8611         long int dvi_item = DVI$_DEVBUFSIZ;
8612         $DESCRIPTOR(mbxnam, "");
8613         $DESCRIPTOR(mbxdevnam, "");
8614
8615         /* Input from a pipe, reopen it in binary mode to disable       */
8616         /* carriage control processing.                                 */
8617
8618         fgetname(stdin, mbxname);
8619         mbxnam.dsc$a_pointer = mbxname;
8620         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
8621         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
8622         mbxdevnam.dsc$a_pointer = mbxname;
8623         mbxdevnam.dsc$w_length = sizeof(mbxname);
8624         dvi_item = DVI$_DEVNAM;
8625         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
8626         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
8627         set_errno(0);
8628         set_vaxc_errno(1);
8629         freopen(mbxname, "rb", stdin);
8630         if (errno != 0)
8631             {
8632             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
8633             exit(vaxc$errno);
8634             }
8635         }
8636     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8637         {
8638         fprintf(stderr,"Can't open input file %s as stdin",in);
8639         exit(vaxc$errno);
8640         }
8641     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8642         {
8643         fprintf(stderr,"Can't open output file %s as stdout",out);
8644         exit(vaxc$errno);
8645         }
8646         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8647
8648     if (err != NULL) {
8649         if (strcmp(err,"&1") == 0) {
8650             dup2(fileno(stdout), fileno(stderr));
8651             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8652         } else {
8653         FILE *tmperr;
8654         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8655             {
8656             fprintf(stderr,"Can't open error file %s as stderr",err);
8657             exit(vaxc$errno);
8658             }
8659             fclose(tmperr);
8660            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8661                 {
8662                 exit(vaxc$errno);
8663                 }
8664             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8665         }
8666         }
8667 #ifdef ARGPROC_DEBUG
8668     PerlIO_printf(Perl_debug_log, "Arglist:\n");
8669     for (j = 0; j < *ac;  ++j)
8670         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8671 #endif
8672    /* Clear errors we may have hit expanding wildcards, so they don't
8673       show up in Perl's $! later */
8674    set_errno(0); set_vaxc_errno(1);
8675 }  /* end of getredirection() */
8676 /*}}}*/
8677
8678 static void add_item(struct list_item **head,
8679                      struct list_item **tail,
8680                      char *value,
8681                      int *count)
8682 {
8683     if (*head == 0)
8684         {
8685         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8686         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8687         *tail = *head;
8688         }
8689     else {
8690         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8691         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8692         *tail = (*tail)->next;
8693         }
8694     (*tail)->value = value;
8695     ++(*count);
8696 }
8697
8698 static void mp_expand_wild_cards(pTHX_ char *item,
8699                               struct list_item **head,
8700                               struct list_item **tail,
8701                               int *count)
8702 {
8703 int expcount = 0;
8704 unsigned long int context = 0;
8705 int isunix = 0;
8706 int item_len = 0;
8707 char *had_version;
8708 char *had_device;
8709 int had_directory;
8710 char *devdir,*cp;
8711 char *vmsspec;
8712 $DESCRIPTOR(filespec, "");
8713 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8714 $DESCRIPTOR(resultspec, "");
8715 unsigned long int lff_flags = 0;
8716 int sts;
8717 int rms_sts;
8718
8719 #ifdef VMS_LONGNAME_SUPPORT
8720     lff_flags = LIB$M_FIL_LONG_NAMES;
8721 #endif
8722
8723     for (cp = item; *cp; cp++) {
8724         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8725         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8726     }
8727     if (!*cp || isspace(*cp))
8728         {
8729         add_item(head, tail, item, count);
8730         return;
8731         }
8732     else
8733         {
8734      /* "double quoted" wild card expressions pass as is */
8735      /* From DCL that means using e.g.:                  */
8736      /* perl program """perl.*"""                        */
8737      item_len = strlen(item);
8738      if ( '"' == *item && '"' == item[item_len-1] )
8739        {
8740        item++;
8741        item[item_len-2] = '\0';
8742        add_item(head, tail, item, count);
8743        return;
8744        }
8745      }
8746     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8747     resultspec.dsc$b_class = DSC$K_CLASS_D;
8748     resultspec.dsc$a_pointer = NULL;
8749     vmsspec = PerlMem_malloc(VMS_MAXRSS);
8750     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8751     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8752       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8753     if (!isunix || !filespec.dsc$a_pointer)
8754       filespec.dsc$a_pointer = item;
8755     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8756     /*
8757      * Only return version specs, if the caller specified a version
8758      */
8759     had_version = strchr(item, ';');
8760     /*
8761      * Only return device and directory specs, if the caller specifed either.
8762      */
8763     had_device = strchr(item, ':');
8764     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8765
8766     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8767                                  (&filespec, &resultspec, &context,
8768                                   &defaultspec, 0, &rms_sts, &lff_flags)))
8769         {
8770         char *string;
8771         char *c;
8772
8773         string = PerlMem_malloc(resultspec.dsc$w_length+1);
8774         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8775         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8776         string[resultspec.dsc$w_length] = '\0';
8777         if (NULL == had_version)
8778             *(strrchr(string, ';')) = '\0';
8779         if ((!had_directory) && (had_device == NULL))
8780             {
8781             if (NULL == (devdir = strrchr(string, ']')))
8782                 devdir = strrchr(string, '>');
8783             strcpy(string, devdir + 1);
8784             }
8785         /*
8786          * Be consistent with what the C RTL has already done to the rest of
8787          * the argv items and lowercase all of these names.
8788          */
8789         if (!decc_efs_case_preserve) {
8790             for (c = string; *c; ++c)
8791             if (isupper(*c))
8792                 *c = tolower(*c);
8793         }
8794         if (isunix) trim_unixpath(string,item,1);
8795         add_item(head, tail, string, count);
8796         ++expcount;
8797     }
8798     PerlMem_free(vmsspec);
8799     if (sts != RMS$_NMF)
8800         {
8801         set_vaxc_errno(sts);
8802         switch (sts)
8803             {
8804             case RMS$_FNF: case RMS$_DNF:
8805                 set_errno(ENOENT); break;
8806             case RMS$_DIR:
8807                 set_errno(ENOTDIR); break;
8808             case RMS$_DEV:
8809                 set_errno(ENODEV); break;
8810             case RMS$_FNM: case RMS$_SYN:
8811                 set_errno(EINVAL); break;
8812             case RMS$_PRV:
8813                 set_errno(EACCES); break;
8814             default:
8815                 _ckvmssts_noperl(sts);
8816             }
8817         }
8818     if (expcount == 0)
8819         add_item(head, tail, item, count);
8820     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8821     _ckvmssts_noperl(lib$find_file_end(&context));
8822 }
8823
8824 static int child_st[2];/* Event Flag set when child process completes   */
8825
8826 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
8827
8828 static unsigned long int exit_handler(int *status)
8829 {
8830 short iosb[4];
8831
8832     if (0 == child_st[0])
8833         {
8834 #ifdef ARGPROC_DEBUG
8835         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8836 #endif
8837         fflush(stdout);     /* Have to flush pipe for binary data to    */
8838                             /* terminate properly -- <tp@mccall.com>    */
8839         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8840         sys$dassgn(child_chan);
8841         fclose(stdout);
8842         sys$synch(0, child_st);
8843         }
8844     return(1);
8845 }
8846
8847 static void sig_child(int chan)
8848 {
8849 #ifdef ARGPROC_DEBUG
8850     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8851 #endif
8852     if (child_st[0] == 0)
8853         child_st[0] = 1;
8854 }
8855
8856 static struct exit_control_block exit_block =
8857     {
8858     0,
8859     exit_handler,
8860     1,
8861     &exit_block.exit_status,
8862     0
8863     };
8864
8865 static void
8866 pipe_and_fork(pTHX_ char **cmargv)
8867 {
8868     PerlIO *fp;
8869     struct dsc$descriptor_s *vmscmd;
8870     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8871     int sts, j, l, ismcr, quote, tquote = 0;
8872
8873     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8874     vms_execfree(vmscmd);
8875
8876     j = l = 0;
8877     p = subcmd;
8878     q = cmargv[0];
8879     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
8880               && toupper(*(q+2)) == 'R' && !*(q+3);
8881
8882     while (q && l < MAX_DCL_LINE_LENGTH) {
8883         if (!*q) {
8884             if (j > 0 && quote) {
8885                 *p++ = '"';
8886                 l++;
8887             }
8888             q = cmargv[++j];
8889             if (q) {
8890                 if (ismcr && j > 1) quote = 1;
8891                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
8892                 *p++ = ' ';
8893                 l++;
8894                 if (quote || tquote) {
8895                     *p++ = '"';
8896                     l++;
8897                 }
8898             }
8899         } else {
8900             if ((quote||tquote) && *q == '"') {
8901                 *p++ = '"';
8902                 l++;
8903             }
8904             *p++ = *q++;
8905             l++;
8906         }
8907     }
8908     *p = '\0';
8909
8910     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8911     if (fp == NULL) {
8912         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8913     }
8914 }
8915
8916 static int background_process(pTHX_ int argc, char **argv)
8917 {
8918 char command[MAX_DCL_SYMBOL + 1] = "$";
8919 $DESCRIPTOR(value, "");
8920 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8921 static $DESCRIPTOR(null, "NLA0:");
8922 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8923 char pidstring[80];
8924 $DESCRIPTOR(pidstr, "");
8925 int pid;
8926 unsigned long int flags = 17, one = 1, retsts;
8927 int len;
8928
8929     strcat(command, argv[0]);
8930     len = strlen(command);
8931     while (--argc && (len < MAX_DCL_SYMBOL))
8932         {
8933         strcat(command, " \"");
8934         strcat(command, *(++argv));
8935         strcat(command, "\"");
8936         len = strlen(command);
8937         }
8938     value.dsc$a_pointer = command;
8939     value.dsc$w_length = strlen(value.dsc$a_pointer);
8940     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8941     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8942     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8943         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8944     }
8945     else {
8946         _ckvmssts_noperl(retsts);
8947     }
8948 #ifdef ARGPROC_DEBUG
8949     PerlIO_printf(Perl_debug_log, "%s\n", command);
8950 #endif
8951     sprintf(pidstring, "%08X", pid);
8952     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8953     pidstr.dsc$a_pointer = pidstring;
8954     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8955     lib$set_symbol(&pidsymbol, &pidstr);
8956     return(SS$_NORMAL);
8957 }
8958 /*}}}*/
8959 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8960
8961
8962 /* OS-specific initialization at image activation (not thread startup) */
8963 /* Older VAXC header files lack these constants */
8964 #ifndef JPI$_RIGHTS_SIZE
8965 #  define JPI$_RIGHTS_SIZE 817
8966 #endif
8967 #ifndef KGB$M_SUBSYSTEM
8968 #  define KGB$M_SUBSYSTEM 0x8
8969 #endif
8970
8971 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8972
8973 /*{{{void vms_image_init(int *, char ***)*/
8974 void
8975 vms_image_init(int *argcp, char ***argvp)
8976 {
8977   char eqv[LNM$C_NAMLENGTH+1] = "";
8978   unsigned int len, tabct = 8, tabidx = 0;
8979   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8980   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8981   unsigned short int dummy, rlen;
8982   struct dsc$descriptor_s **tabvec;
8983 #if defined(PERL_IMPLICIT_CONTEXT)
8984   pTHX = NULL;
8985 #endif
8986   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8987                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8988                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8989                                  {          0,                0,    0,      0} };
8990
8991 #ifdef KILL_BY_SIGPRC
8992     Perl_csighandler_init();
8993 #endif
8994
8995   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8996   _ckvmssts_noperl(iosb[0]);
8997   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8998     if (iprv[i]) {           /* Running image installed with privs? */
8999       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
9000       will_taint = TRUE;
9001       break;
9002     }
9003   }
9004   /* Rights identifiers might trigger tainting as well. */
9005   if (!will_taint && (rlen || rsz)) {
9006     while (rlen < rsz) {
9007       /* We didn't get all the identifiers on the first pass.  Allocate a
9008        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9009        * were needed to hold all identifiers at time of last call; we'll
9010        * allocate that many unsigned long ints), and go back and get 'em.
9011        * If it gave us less than it wanted to despite ample buffer space,
9012        * something's broken.  Is your system missing a system identifier?
9013        */
9014       if (rsz <= jpilist[1].buflen) {
9015          /* Perl_croak accvios when used this early in startup. */
9016          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9017                          rsz, (unsigned long) jpilist[1].buflen,
9018                          "Check your rights database for corruption.\n");
9019          exit(SS$_ABORT);
9020       }
9021       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9022       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9023       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9024       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9025       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9026       _ckvmssts_noperl(iosb[0]);
9027     }
9028     mask = jpilist[1].bufadr;
9029     /* Check attribute flags for each identifier (2nd longword); protected
9030      * subsystem identifiers trigger tainting.
9031      */
9032     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9033       if (mask[i] & KGB$M_SUBSYSTEM) {
9034         will_taint = TRUE;
9035         break;
9036       }
9037     }
9038     if (mask != rlst) PerlMem_free(mask);
9039   }
9040
9041   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9042    * logical, some versions of the CRTL will add a phanthom /000000/
9043    * directory.  This needs to be removed.
9044    */
9045   if (decc_filename_unix_report) {
9046   char * zeros;
9047   int ulen;
9048     ulen = strlen(argvp[0][0]);
9049     if (ulen > 7) {
9050       zeros = strstr(argvp[0][0], "/000000/");
9051       if (zeros != NULL) {
9052         int mlen;
9053         mlen = ulen - (zeros - argvp[0][0]) - 7;
9054         memmove(zeros, &zeros[7], mlen);
9055         ulen = ulen - 7;
9056         argvp[0][0][ulen] = '\0';
9057       }
9058     }
9059     /* It also may have a trailing dot that needs to be removed otherwise
9060      * it will be converted to VMS mode incorrectly.
9061      */
9062     ulen--;
9063     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9064       argvp[0][0][ulen] = '\0';
9065   }
9066
9067   /* We need to use this hack to tell Perl it should run with tainting,
9068    * since its tainting flag may be part of the PL_curinterp struct, which
9069    * hasn't been allocated when vms_image_init() is called.
9070    */
9071   if (will_taint) {
9072     char **newargv, **oldargv;
9073     oldargv = *argvp;
9074     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9075     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9076     newargv[0] = oldargv[0];
9077     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9078     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9079     strcpy(newargv[1], "-T");
9080     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9081     (*argcp)++;
9082     newargv[*argcp] = NULL;
9083     /* We orphan the old argv, since we don't know where it's come from,
9084      * so we don't know how to free it.
9085      */
9086     *argvp = newargv;
9087   }
9088   else {  /* Did user explicitly request tainting? */
9089     int i;
9090     char *cp, **av = *argvp;
9091     for (i = 1; i < *argcp; i++) {
9092       if (*av[i] != '-') break;
9093       for (cp = av[i]+1; *cp; cp++) {
9094         if (*cp == 'T') { will_taint = 1; break; }
9095         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9096                   strchr("DFIiMmx",*cp)) break;
9097       }
9098       if (will_taint) break;
9099     }
9100   }
9101
9102   for (tabidx = 0;
9103        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9104        tabidx++) {
9105     if (!tabidx) {
9106       tabvec = (struct dsc$descriptor_s **)
9107             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9108       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9109     }
9110     else if (tabidx >= tabct) {
9111       tabct += 8;
9112       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9113       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9114     }
9115     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9116     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9117     tabvec[tabidx]->dsc$w_length  = 0;
9118     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9119     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9120     tabvec[tabidx]->dsc$a_pointer = NULL;
9121     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9122   }
9123   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9124
9125   getredirection(argcp,argvp);
9126 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9127   {
9128 # include <reentrancy.h>
9129   decc$set_reentrancy(C$C_MULTITHREAD);
9130   }
9131 #endif
9132   return;
9133 }
9134 /*}}}*/
9135
9136
9137 /* trim_unixpath()
9138  * Trim Unix-style prefix off filespec, so it looks like what a shell
9139  * glob expansion would return (i.e. from specified prefix on, not
9140  * full path).  Note that returned filespec is Unix-style, regardless
9141  * of whether input filespec was VMS-style or Unix-style.
9142  *
9143  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9144  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9145  * vector of options; at present, only bit 0 is used, and if set tells
9146  * trim unixpath to try the current default directory as a prefix when
9147  * presented with a possibly ambiguous ... wildcard.
9148  *
9149  * Returns !=0 on success, with trimmed filespec replacing contents of
9150  * fspec, and 0 on failure, with contents of fpsec unchanged.
9151  */
9152 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9153 int
9154 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9155 {
9156   char *unixified, *unixwild,
9157        *template, *base, *end, *cp1, *cp2;
9158   register int tmplen, reslen = 0, dirs = 0;
9159
9160   unixwild = PerlMem_malloc(VMS_MAXRSS);
9161   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
9162   if (!wildspec || !fspec) return 0;
9163   template = unixwild;
9164   if (strpbrk(wildspec,"]>:") != NULL) {
9165     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
9166         PerlMem_free(unixwild);
9167         return 0;
9168     }
9169   }
9170   else {
9171     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9172     unixwild[VMS_MAXRSS-1] = 0;
9173   }
9174   unixified = PerlMem_malloc(VMS_MAXRSS);
9175   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
9176   if (strpbrk(fspec,"]>:") != NULL) {
9177     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
9178         PerlMem_free(unixwild);
9179         PerlMem_free(unixified);
9180         return 0;
9181     }
9182     else base = unixified;
9183     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9184      * check to see that final result fits into (isn't longer than) fspec */
9185     reslen = strlen(fspec);
9186   }
9187   else base = fspec;
9188
9189   /* No prefix or absolute path on wildcard, so nothing to remove */
9190   if (!*template || *template == '/') {
9191     PerlMem_free(unixwild);
9192     if (base == fspec) {
9193         PerlMem_free(unixified);
9194         return 1;
9195     }
9196     tmplen = strlen(unixified);
9197     if (tmplen > reslen) {
9198         PerlMem_free(unixified);
9199         return 0;  /* not enough space */
9200     }
9201     /* Copy unixified resultant, including trailing NUL */
9202     memmove(fspec,unixified,tmplen+1);
9203     PerlMem_free(unixified);
9204     return 1;
9205   }
9206
9207   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9208   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9209     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9210     for (cp1 = end ;cp1 >= base; cp1--)
9211       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9212         { cp1++; break; }
9213     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9214     PerlMem_free(unixified);
9215     PerlMem_free(unixwild);
9216     return 1;
9217   }
9218   else {
9219     char *tpl, *lcres;
9220     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9221     int ells = 1, totells, segdirs, match;
9222     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9223                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9224
9225     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9226     totells = ells;
9227     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9228     tpl = PerlMem_malloc(VMS_MAXRSS);
9229     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
9230     if (ellipsis == template && opts & 1) {
9231       /* Template begins with an ellipsis.  Since we can't tell how many
9232        * directory names at the front of the resultant to keep for an
9233        * arbitrary starting point, we arbitrarily choose the current
9234        * default directory as a starting point.  If it's there as a prefix,
9235        * clip it off.  If not, fall through and act as if the leading
9236        * ellipsis weren't there (i.e. return shortest possible path that
9237        * could match template).
9238        */
9239       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9240           PerlMem_free(tpl);
9241           PerlMem_free(unixified);
9242           PerlMem_free(unixwild);
9243           return 0;
9244       }
9245       if (!decc_efs_case_preserve) {
9246         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9247           if (_tolower(*cp1) != _tolower(*cp2)) break;
9248       }
9249       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9250       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9251       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9252         memmove(fspec,cp2+1,end - cp2);
9253         PerlMem_free(tpl);
9254         PerlMem_free(unixified);
9255         PerlMem_free(unixwild);
9256         return 1;
9257       }
9258     }
9259     /* First off, back up over constant elements at end of path */
9260     if (dirs) {
9261       for (front = end ; front >= base; front--)
9262          if (*front == '/' && !dirs--) { front++; break; }
9263     }
9264     lcres = PerlMem_malloc(VMS_MAXRSS);
9265     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
9266     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9267          cp1++,cp2++) {
9268             if (!decc_efs_case_preserve) {
9269                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9270             }
9271             else {
9272                 *cp2 = *cp1;
9273             }
9274     }
9275     if (cp1 != '\0') {
9276         PerlMem_free(tpl);
9277         PerlMem_free(unixified);
9278         PerlMem_free(unixwild);
9279         PerlMem_free(lcres);
9280         return 0;  /* Path too long. */
9281     }
9282     lcend = cp2;
9283     *cp2 = '\0';  /* Pick up with memcpy later */
9284     lcfront = lcres + (front - base);
9285     /* Now skip over each ellipsis and try to match the path in front of it. */
9286     while (ells--) {
9287       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9288         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9289             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9290       if (cp1 < template) break; /* template started with an ellipsis */
9291       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9292         ellipsis = cp1; continue;
9293       }
9294       wilddsc.dsc$a_pointer = tpl;
9295       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9296       nextell = cp1;
9297       for (segdirs = 0, cp2 = tpl;
9298            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9299            cp1++, cp2++) {
9300          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9301          else {
9302             if (!decc_efs_case_preserve) {
9303               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9304             }
9305             else {
9306               *cp2 = *cp1;  /* else preserve case for match */
9307             }
9308          }
9309          if (*cp2 == '/') segdirs++;
9310       }
9311       if (cp1 != ellipsis - 1) {
9312           PerlMem_free(tpl);
9313           PerlMem_free(unixified);
9314           PerlMem_free(unixwild);
9315           PerlMem_free(lcres);
9316           return 0; /* Path too long */
9317       }
9318       /* Back up at least as many dirs as in template before matching */
9319       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9320         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9321       for (match = 0; cp1 > lcres;) {
9322         resdsc.dsc$a_pointer = cp1;
9323         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9324           match++;
9325           if (match == 1) lcfront = cp1;
9326         }
9327         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9328       }
9329       if (!match) {
9330         PerlMem_free(tpl);
9331         PerlMem_free(unixified);
9332         PerlMem_free(unixwild);
9333         PerlMem_free(lcres);
9334         return 0;  /* Can't find prefix ??? */
9335       }
9336       if (match > 1 && opts & 1) {
9337         /* This ... wildcard could cover more than one set of dirs (i.e.
9338          * a set of similar dir names is repeated).  If the template
9339          * contains more than 1 ..., upstream elements could resolve the
9340          * ambiguity, but it's not worth a full backtracking setup here.
9341          * As a quick heuristic, clip off the current default directory
9342          * if it's present to find the trimmed spec, else use the
9343          * shortest string that this ... could cover.
9344          */
9345         char def[NAM$C_MAXRSS+1], *st;
9346
9347         if (getcwd(def, sizeof def,0) == NULL) {
9348             PerlMem_free(unixified);
9349             PerlMem_free(unixwild);
9350             PerlMem_free(lcres);
9351             PerlMem_free(tpl);
9352             return 0;
9353         }
9354         if (!decc_efs_case_preserve) {
9355           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9356             if (_tolower(*cp1) != _tolower(*cp2)) break;
9357         }
9358         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9359         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9360         if (*cp1 == '\0' && *cp2 == '/') {
9361           memmove(fspec,cp2+1,end - cp2);
9362           PerlMem_free(tpl);
9363           PerlMem_free(unixified);
9364           PerlMem_free(unixwild);
9365           PerlMem_free(lcres);
9366           return 1;
9367         }
9368         /* Nope -- stick with lcfront from above and keep going. */
9369       }
9370     }
9371     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9372     PerlMem_free(tpl);
9373     PerlMem_free(unixified);
9374     PerlMem_free(unixwild);
9375     PerlMem_free(lcres);
9376     return 1;
9377     ellipsis = nextell;
9378   }
9379
9380 }  /* end of trim_unixpath() */
9381 /*}}}*/
9382
9383
9384 /*
9385  *  VMS readdir() routines.
9386  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9387  *
9388  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9389  *  Minor modifications to original routines.
9390  */
9391
9392 /* readdir may have been redefined by reentr.h, so make sure we get
9393  * the local version for what we do here.
9394  */
9395 #ifdef readdir
9396 # undef readdir
9397 #endif
9398 #if !defined(PERL_IMPLICIT_CONTEXT)
9399 # define readdir Perl_readdir
9400 #else
9401 # define readdir(a) Perl_readdir(aTHX_ a)
9402 #endif
9403
9404     /* Number of elements in vms_versions array */
9405 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9406
9407 /*
9408  *  Open a directory, return a handle for later use.
9409  */
9410 /*{{{ DIR *opendir(char*name) */
9411 DIR *
9412 Perl_opendir(pTHX_ const char *name)
9413 {
9414     DIR *dd;
9415     char *dir;
9416     Stat_t sb;
9417
9418     Newx(dir, VMS_MAXRSS, char);
9419     if (do_tovmspath(name,dir,0,NULL) == NULL) {
9420       Safefree(dir);
9421       return NULL;
9422     }
9423     /* Check access before stat; otherwise stat does not
9424      * accurately report whether it's a directory.
9425      */
9426     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9427       /* cando_by_name has already set errno */
9428       Safefree(dir);
9429       return NULL;
9430     }
9431     if (flex_stat(dir,&sb) == -1) return NULL;
9432     if (!S_ISDIR(sb.st_mode)) {
9433       Safefree(dir);
9434       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
9435       return NULL;
9436     }
9437     /* Get memory for the handle, and the pattern. */
9438     Newx(dd,1,DIR);
9439     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9440
9441     /* Fill in the fields; mainly playing with the descriptor. */
9442     sprintf(dd->pattern, "%s*.*",dir);
9443     Safefree(dir);
9444     dd->context = 0;
9445     dd->count = 0;
9446     dd->flags = 0;
9447     /* By saying we always want the result of readdir() in unix format, we
9448      * are really saying we want all the escapes removed.  Otherwise the caller,
9449      * having no way to know whether it's already in VMS format, might send it
9450      * through tovmsspec again, thus double escaping.
9451      */
9452     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
9453     dd->pat.dsc$a_pointer = dd->pattern;
9454     dd->pat.dsc$w_length = strlen(dd->pattern);
9455     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9456     dd->pat.dsc$b_class = DSC$K_CLASS_S;
9457 #if defined(USE_ITHREADS)
9458     Newx(dd->mutex,1,perl_mutex);
9459     MUTEX_INIT( (perl_mutex *) dd->mutex );
9460 #else
9461     dd->mutex = NULL;
9462 #endif
9463
9464     return dd;
9465 }  /* end of opendir() */
9466 /*}}}*/
9467
9468 /*
9469  *  Set the flag to indicate we want versions or not.
9470  */
9471 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9472 void
9473 vmsreaddirversions(DIR *dd, int flag)
9474 {
9475     if (flag)
9476         dd->flags |= PERL_VMSDIR_M_VERSIONS;
9477     else
9478         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9479 }
9480 /*}}}*/
9481
9482 /*
9483  *  Free up an opened directory.
9484  */
9485 /*{{{ void closedir(DIR *dd)*/
9486 void
9487 Perl_closedir(DIR *dd)
9488 {
9489     int sts;
9490
9491     sts = lib$find_file_end(&dd->context);
9492     Safefree(dd->pattern);
9493 #if defined(USE_ITHREADS)
9494     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
9495     Safefree(dd->mutex);
9496 #endif
9497     Safefree(dd);
9498 }
9499 /*}}}*/
9500
9501 /*
9502  *  Collect all the version numbers for the current file.
9503  */
9504 static void
9505 collectversions(pTHX_ DIR *dd)
9506 {
9507     struct dsc$descriptor_s     pat;
9508     struct dsc$descriptor_s     res;
9509     struct dirent *e;
9510     char *p, *text, *buff;
9511     int i;
9512     unsigned long context, tmpsts;
9513
9514     /* Convenient shorthand. */
9515     e = &dd->entry;
9516
9517     /* Add the version wildcard, ignoring the "*.*" put on before */
9518     i = strlen(dd->pattern);
9519     Newx(text,i + e->d_namlen + 3,char);
9520     strcpy(text, dd->pattern);
9521     sprintf(&text[i - 3], "%s;*", e->d_name);
9522
9523     /* Set up the pattern descriptor. */
9524     pat.dsc$a_pointer = text;
9525     pat.dsc$w_length = i + e->d_namlen - 1;
9526     pat.dsc$b_dtype = DSC$K_DTYPE_T;
9527     pat.dsc$b_class = DSC$K_CLASS_S;
9528
9529     /* Set up result descriptor. */
9530     Newx(buff, VMS_MAXRSS, char);
9531     res.dsc$a_pointer = buff;
9532     res.dsc$w_length = VMS_MAXRSS - 1;
9533     res.dsc$b_dtype = DSC$K_DTYPE_T;
9534     res.dsc$b_class = DSC$K_CLASS_S;
9535
9536     /* Read files, collecting versions. */
9537     for (context = 0, e->vms_verscount = 0;
9538          e->vms_verscount < VERSIZE(e);
9539          e->vms_verscount++) {
9540         unsigned long rsts;
9541         unsigned long flags = 0;
9542
9543 #ifdef VMS_LONGNAME_SUPPORT
9544         flags = LIB$M_FIL_LONG_NAMES;
9545 #endif
9546         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
9547         if (tmpsts == RMS$_NMF || context == 0) break;
9548         _ckvmssts(tmpsts);
9549         buff[VMS_MAXRSS - 1] = '\0';
9550         if ((p = strchr(buff, ';')))
9551             e->vms_versions[e->vms_verscount] = atoi(p + 1);
9552         else
9553             e->vms_versions[e->vms_verscount] = -1;
9554     }
9555
9556     _ckvmssts(lib$find_file_end(&context));
9557     Safefree(text);
9558     Safefree(buff);
9559
9560 }  /* end of collectversions() */
9561
9562 /*
9563  *  Read the next entry from the directory.
9564  */
9565 /*{{{ struct dirent *readdir(DIR *dd)*/
9566 struct dirent *
9567 Perl_readdir(pTHX_ DIR *dd)
9568 {
9569     struct dsc$descriptor_s     res;
9570     char *p, *buff;
9571     unsigned long int tmpsts;
9572     unsigned long rsts;
9573     unsigned long flags = 0;
9574     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
9575     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
9576
9577     /* Set up result descriptor, and get next file. */
9578     Newx(buff, VMS_MAXRSS, char);
9579     res.dsc$a_pointer = buff;
9580     res.dsc$w_length = VMS_MAXRSS - 1;
9581     res.dsc$b_dtype = DSC$K_DTYPE_T;
9582     res.dsc$b_class = DSC$K_CLASS_S;
9583
9584 #ifdef VMS_LONGNAME_SUPPORT
9585     flags = LIB$M_FIL_LONG_NAMES;
9586 #endif
9587
9588     tmpsts = lib$find_file
9589         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
9590     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
9591     if (!(tmpsts & 1)) {
9592       set_vaxc_errno(tmpsts);
9593       switch (tmpsts) {
9594         case RMS$_PRV:
9595           set_errno(EACCES); break;
9596         case RMS$_DEV:
9597           set_errno(ENODEV); break;
9598         case RMS$_DIR:
9599           set_errno(ENOTDIR); break;
9600         case RMS$_FNF: case RMS$_DNF:
9601           set_errno(ENOENT); break;
9602         default:
9603           set_errno(EVMSERR);
9604       }
9605       Safefree(buff);
9606       return NULL;
9607     }
9608     dd->count++;
9609     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
9610     buff[res.dsc$w_length] = '\0';
9611     p = buff + res.dsc$w_length;
9612     while (--p >= buff) if (!isspace(*p)) break;
9613     *p = '\0';
9614     if (!decc_efs_case_preserve) {
9615       for (p = buff; *p; p++) *p = _tolower(*p);
9616     }
9617
9618     /* Skip any directory component and just copy the name. */
9619     sts = vms_split_path
9620        (buff,
9621         &v_spec,
9622         &v_len,
9623         &r_spec,
9624         &r_len,
9625         &d_spec,
9626         &d_len,
9627         &n_spec,
9628         &n_len,
9629         &e_spec,
9630         &e_len,
9631         &vs_spec,
9632         &vs_len);
9633
9634     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9635
9636         /* In Unix report mode, remove the ".dir;1" from the name */
9637         /* if it is a real directory. */
9638         if (decc_filename_unix_report || decc_efs_charset) {
9639             if ((e_len == 4) && (vs_len == 2) && (vs_spec[1] == '1')) {
9640                 if ((toupper(e_spec[1]) == 'D') &&
9641                     (toupper(e_spec[2]) == 'I') &&
9642                     (toupper(e_spec[3]) == 'R')) {
9643                     Stat_t statbuf;
9644                     int ret_sts;
9645
9646                     ret_sts = stat(buff, (stat_t *)&statbuf);
9647                     if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
9648                         e_len = 0;
9649                         e_spec[0] = 0;
9650                     }
9651                 }
9652             }
9653         }
9654
9655         /* Drop NULL extensions on UNIX file specification */
9656         if ((e_len == 1) && decc_readdir_dropdotnotype) {
9657             e_len = 0;
9658             e_spec[0] = '\0';
9659         }
9660     }
9661
9662     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9663     dd->entry.d_name[n_len + e_len] = '\0';
9664     dd->entry.d_namlen = strlen(dd->entry.d_name);
9665
9666     /* Convert the filename to UNIX format if needed */
9667     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9668
9669         /* Translate the encoded characters. */
9670         /* Fixme: Unicode handling could result in embedded 0 characters */
9671         if (strchr(dd->entry.d_name, '^') != NULL) {
9672             char new_name[256];
9673             char * q;
9674             p = dd->entry.d_name;
9675             q = new_name;
9676             while (*p != 0) {
9677                 int inchars_read, outchars_added;
9678                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9679                 p += inchars_read;
9680                 q += outchars_added;
9681                 /* fix-me */
9682                 /* if outchars_added > 1, then this is a wide file specification */
9683                 /* Wide file specifications need to be passed in Perl */
9684                 /* counted strings apparently with a Unicode flag */
9685             }
9686             *q = 0;
9687             strcpy(dd->entry.d_name, new_name);
9688             dd->entry.d_namlen = strlen(dd->entry.d_name);
9689         }
9690     }
9691
9692     dd->entry.vms_verscount = 0;
9693     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9694     Safefree(buff);
9695     return &dd->entry;
9696
9697 }  /* end of readdir() */
9698 /*}}}*/
9699
9700 /*
9701  *  Read the next entry from the directory -- thread-safe version.
9702  */
9703 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9704 int
9705 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9706 {
9707     int retval;
9708
9709     MUTEX_LOCK( (perl_mutex *) dd->mutex );
9710
9711     entry = readdir(dd);
9712     *result = entry;
9713     retval = ( *result == NULL ? errno : 0 );
9714
9715     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9716
9717     return retval;
9718
9719 }  /* end of readdir_r() */
9720 /*}}}*/
9721
9722 /*
9723  *  Return something that can be used in a seekdir later.
9724  */
9725 /*{{{ long telldir(DIR *dd)*/
9726 long
9727 Perl_telldir(DIR *dd)
9728 {
9729     return dd->count;
9730 }
9731 /*}}}*/
9732
9733 /*
9734  *  Return to a spot where we used to be.  Brute force.
9735  */
9736 /*{{{ void seekdir(DIR *dd,long count)*/
9737 void
9738 Perl_seekdir(pTHX_ DIR *dd, long count)
9739 {
9740     int old_flags;
9741
9742     /* If we haven't done anything yet... */
9743     if (dd->count == 0)
9744         return;
9745
9746     /* Remember some state, and clear it. */
9747     old_flags = dd->flags;
9748     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9749     _ckvmssts(lib$find_file_end(&dd->context));
9750     dd->context = 0;
9751
9752     /* The increment is in readdir(). */
9753     for (dd->count = 0; dd->count < count; )
9754         readdir(dd);
9755
9756     dd->flags = old_flags;
9757
9758 }  /* end of seekdir() */
9759 /*}}}*/
9760
9761 /* VMS subprocess management
9762  *
9763  * my_vfork() - just a vfork(), after setting a flag to record that
9764  * the current script is trying a Unix-style fork/exec.
9765  *
9766  * vms_do_aexec() and vms_do_exec() are called in response to the
9767  * perl 'exec' function.  If this follows a vfork call, then they
9768  * call out the regular perl routines in doio.c which do an
9769  * execvp (for those who really want to try this under VMS).
9770  * Otherwise, they do exactly what the perl docs say exec should
9771  * do - terminate the current script and invoke a new command
9772  * (See below for notes on command syntax.)
9773  *
9774  * do_aspawn() and do_spawn() implement the VMS side of the perl
9775  * 'system' function.
9776  *
9777  * Note on command arguments to perl 'exec' and 'system': When handled
9778  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9779  * are concatenated to form a DCL command string.  If the first non-numeric
9780  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
9781  * the command string is handed off to DCL directly.  Otherwise,
9782  * the first token of the command is taken as the filespec of an image
9783  * to run.  The filespec is expanded using a default type of '.EXE' and
9784  * the process defaults for device, directory, etc., and if found, the resultant
9785  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9786  * the command string as parameters.  This is perhaps a bit complicated,
9787  * but I hope it will form a happy medium between what VMS folks expect
9788  * from lib$spawn and what Unix folks expect from exec.
9789  */
9790
9791 static int vfork_called;
9792
9793 /*{{{int my_vfork()*/
9794 int
9795 my_vfork()
9796 {
9797   vfork_called++;
9798   return vfork();
9799 }
9800 /*}}}*/
9801
9802
9803 static void
9804 vms_execfree(struct dsc$descriptor_s *vmscmd)
9805 {
9806   if (vmscmd) {
9807       if (vmscmd->dsc$a_pointer) {
9808           PerlMem_free(vmscmd->dsc$a_pointer);
9809       }
9810       PerlMem_free(vmscmd);
9811   }
9812 }
9813
9814 static char *
9815 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9816 {
9817   char *junk, *tmps = NULL;
9818   register size_t cmdlen = 0;
9819   size_t rlen;
9820   register SV **idx;
9821   STRLEN n_a;
9822
9823   idx = mark;
9824   if (really) {
9825     tmps = SvPV(really,rlen);
9826     if (*tmps) {
9827       cmdlen += rlen + 1;
9828       idx++;
9829     }
9830   }
9831
9832   for (idx++; idx <= sp; idx++) {
9833     if (*idx) {
9834       junk = SvPVx(*idx,rlen);
9835       cmdlen += rlen ? rlen + 1 : 0;
9836     }
9837   }
9838   Newx(PL_Cmd, cmdlen+1, char);
9839
9840   if (tmps && *tmps) {
9841     strcpy(PL_Cmd,tmps);
9842     mark++;
9843   }
9844   else *PL_Cmd = '\0';
9845   while (++mark <= sp) {
9846     if (*mark) {
9847       char *s = SvPVx(*mark,n_a);
9848       if (!*s) continue;
9849       if (*PL_Cmd) strcat(PL_Cmd," ");
9850       strcat(PL_Cmd,s);
9851     }
9852   }
9853   return PL_Cmd;
9854
9855 }  /* end of setup_argstr() */
9856
9857
9858 static unsigned long int
9859 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9860                    struct dsc$descriptor_s **pvmscmd)
9861 {
9862   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9863   char image_name[NAM$C_MAXRSS+1];
9864   char image_argv[NAM$C_MAXRSS+1];
9865   $DESCRIPTOR(defdsc,".EXE");
9866   $DESCRIPTOR(defdsc2,".");
9867   $DESCRIPTOR(resdsc,resspec);
9868   struct dsc$descriptor_s *vmscmd;
9869   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9870   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9871   register char *s, *rest, *cp, *wordbreak;
9872   char * cmd;
9873   int cmdlen;
9874   register int isdcl;
9875
9876   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9877   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9878
9879   /* Make a copy for modification */
9880   cmdlen = strlen(incmd);
9881   cmd = PerlMem_malloc(cmdlen+1);
9882   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9883   strncpy(cmd, incmd, cmdlen);
9884   cmd[cmdlen] = 0;
9885   image_name[0] = 0;
9886   image_argv[0] = 0;
9887
9888   vmscmd->dsc$a_pointer = NULL;
9889   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
9890   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
9891   vmscmd->dsc$w_length = 0;
9892   if (pvmscmd) *pvmscmd = vmscmd;
9893
9894   if (suggest_quote) *suggest_quote = 0;
9895
9896   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9897     PerlMem_free(cmd);
9898     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
9899   }
9900
9901   s = cmd;
9902
9903   while (*s && isspace(*s)) s++;
9904
9905   if (*s == '@' || *s == '$') {
9906     vmsspec[0] = *s;  rest = s + 1;
9907     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9908   }
9909   else { cp = vmsspec; rest = s; }
9910   if (*rest == '.' || *rest == '/') {
9911     char *cp2;
9912     for (cp2 = resspec;
9913          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9914          rest++, cp2++) *cp2 = *rest;
9915     *cp2 = '\0';
9916     if (do_tovmsspec(resspec,cp,0,NULL)) {
9917       s = vmsspec;
9918
9919       /* When a UNIX spec with no file type is translated to VMS, */
9920       /* A trailing '.' is appended under ODS-5 rules.            */
9921       /* Here we do not want that trailing "." as it prevents     */
9922       /* Looking for a implied ".exe" type. */
9923       if (decc_efs_charset) {
9924           int i;
9925           i = strlen(vmsspec);
9926           if (vmsspec[i-1] == '.') {
9927               vmsspec[i-1] = '\0';
9928           }
9929       }
9930
9931       if (*rest) {
9932         for (cp2 = vmsspec + strlen(vmsspec);
9933              *rest && cp2 - vmsspec < sizeof vmsspec;
9934              rest++, cp2++) *cp2 = *rest;
9935         *cp2 = '\0';
9936       }
9937     }
9938   }
9939   /* Intuit whether verb (first word of cmd) is a DCL command:
9940    *   - if first nonspace char is '@', it's a DCL indirection
9941    * otherwise
9942    *   - if verb contains a filespec separator, it's not a DCL command
9943    *   - if it doesn't, caller tells us whether to default to a DCL
9944    *     command, or to a local image unless told it's DCL (by leading '$')
9945    */
9946   if (*s == '@') {
9947       isdcl = 1;
9948       if (suggest_quote) *suggest_quote = 1;
9949   } else {
9950     register char *filespec = strpbrk(s,":<[.;");
9951     rest = wordbreak = strpbrk(s," \"\t/");
9952     if (!wordbreak) wordbreak = s + strlen(s);
9953     if (*s == '$') check_img = 0;
9954     if (filespec && (filespec < wordbreak)) isdcl = 0;
9955     else isdcl = !check_img;
9956   }
9957
9958   if (!isdcl) {
9959     int rsts;
9960     imgdsc.dsc$a_pointer = s;
9961     imgdsc.dsc$w_length = wordbreak - s;
9962     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9963     if (!(retsts&1)) {
9964         _ckvmssts(lib$find_file_end(&cxt));
9965         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9966       if (!(retsts & 1) && *s == '$') {
9967         _ckvmssts(lib$find_file_end(&cxt));
9968         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9969         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9970         if (!(retsts&1)) {
9971           _ckvmssts(lib$find_file_end(&cxt));
9972           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9973         }
9974       }
9975     }
9976     _ckvmssts(lib$find_file_end(&cxt));
9977
9978     if (retsts & 1) {
9979       FILE *fp;
9980       s = resspec;
9981       while (*s && !isspace(*s)) s++;
9982       *s = '\0';
9983
9984       /* check that it's really not DCL with no file extension */
9985       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9986       if (fp) {
9987         char b[256] = {0,0,0,0};
9988         read(fileno(fp), b, 256);
9989         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9990         if (isdcl) {
9991           int shebang_len;
9992
9993           /* Check for script */
9994           shebang_len = 0;
9995           if ((b[0] == '#') && (b[1] == '!'))
9996              shebang_len = 2;
9997 #ifdef ALTERNATE_SHEBANG
9998           else {
9999             shebang_len = strlen(ALTERNATE_SHEBANG);
10000             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10001               char * perlstr;
10002                 perlstr = strstr("perl",b);
10003                 if (perlstr == NULL)
10004                   shebang_len = 0;
10005             }
10006             else
10007               shebang_len = 0;
10008           }
10009 #endif
10010
10011           if (shebang_len > 0) {
10012           int i;
10013           int j;
10014           char tmpspec[NAM$C_MAXRSS + 1];
10015
10016             i = shebang_len;
10017              /* Image is following after white space */
10018             /*--------------------------------------*/
10019             while (isprint(b[i]) && isspace(b[i]))
10020                 i++;
10021
10022             j = 0;
10023             while (isprint(b[i]) && !isspace(b[i])) {
10024                 tmpspec[j++] = b[i++];
10025                 if (j >= NAM$C_MAXRSS)
10026                    break;
10027             }
10028             tmpspec[j] = '\0';
10029
10030              /* There may be some default parameters to the image */
10031             /*---------------------------------------------------*/
10032             j = 0;
10033             while (isprint(b[i])) {
10034                 image_argv[j++] = b[i++];
10035                 if (j >= NAM$C_MAXRSS)
10036                    break;
10037             }
10038             while ((j > 0) && !isprint(image_argv[j-1]))
10039                 j--;
10040             image_argv[j] = 0;
10041
10042             /* It will need to be converted to VMS format and validated */
10043             if (tmpspec[0] != '\0') {
10044               char * iname;
10045
10046                /* Try to find the exact program requested to be run */
10047               /*---------------------------------------------------*/
10048               iname = do_rmsexpand
10049                  (tmpspec, image_name, 0, ".exe",
10050                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10051               if (iname != NULL) {
10052                 if (cando_by_name_int
10053                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10054                   /* MCR prefix needed */
10055                   isdcl = 0;
10056                 }
10057                 else {
10058                    /* Try again with a null type */
10059                   /*----------------------------*/
10060                   iname = do_rmsexpand
10061                     (tmpspec, image_name, 0, ".",
10062                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10063                   if (iname != NULL) {
10064                     if (cando_by_name_int
10065                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10066                       /* MCR prefix needed */
10067                       isdcl = 0;
10068                     }
10069                   }
10070                 }
10071
10072                  /* Did we find the image to run the script? */
10073                 /*------------------------------------------*/
10074                 if (isdcl) {
10075                   char *tchr;
10076
10077                    /* Assume DCL or foreign command exists */
10078                   /*--------------------------------------*/
10079                   tchr = strrchr(tmpspec, '/');
10080                   if (tchr != NULL) {
10081                     tchr++;
10082                   }
10083                   else {
10084                     tchr = tmpspec;
10085                   }
10086                   strcpy(image_name, tchr);
10087                 }
10088               }
10089             }
10090           }
10091         }
10092         fclose(fp);
10093       }
10094       if (check_img && isdcl) return RMS$_FNF;
10095
10096       if (cando_by_name(S_IXUSR,0,resspec)) {
10097         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10098         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10099         if (!isdcl) {
10100             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10101             if (image_name[0] != 0) {
10102                 strcat(vmscmd->dsc$a_pointer, image_name);
10103                 strcat(vmscmd->dsc$a_pointer, " ");
10104             }
10105         } else if (image_name[0] != 0) {
10106             strcpy(vmscmd->dsc$a_pointer, image_name);
10107             strcat(vmscmd->dsc$a_pointer, " ");
10108         } else {
10109             strcpy(vmscmd->dsc$a_pointer,"@");
10110         }
10111         if (suggest_quote) *suggest_quote = 1;
10112
10113         /* If there is an image name, use original command */
10114         if (image_name[0] == 0)
10115             strcat(vmscmd->dsc$a_pointer,resspec);
10116         else {
10117             rest = cmd;
10118             while (*rest && isspace(*rest)) rest++;
10119         }
10120
10121         if (image_argv[0] != 0) {
10122           strcat(vmscmd->dsc$a_pointer,image_argv);
10123           strcat(vmscmd->dsc$a_pointer, " ");
10124         }
10125         if (rest) {
10126            int rest_len;
10127            int vmscmd_len;
10128
10129            rest_len = strlen(rest);
10130            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10131            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10132               strcat(vmscmd->dsc$a_pointer,rest);
10133            else
10134              retsts = CLI$_BUFOVF;
10135         }
10136         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10137         PerlMem_free(cmd);
10138         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10139       }
10140       else
10141         retsts = RMS$_PRV;
10142     }
10143   }
10144   /* It's either a DCL command or we couldn't find a suitable image */
10145   vmscmd->dsc$w_length = strlen(cmd);
10146
10147   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10148   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10149   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10150
10151   PerlMem_free(cmd);
10152
10153   /* check if it's a symbol (for quoting purposes) */
10154   if (suggest_quote && !*suggest_quote) {
10155     int iss;
10156     char equiv[LNM$C_NAMLENGTH];
10157     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10158     eqvdsc.dsc$a_pointer = equiv;
10159
10160     iss = lib$get_symbol(vmscmd,&eqvdsc);
10161     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10162   }
10163   if (!(retsts & 1)) {
10164     /* just hand off status values likely to be due to user error */
10165     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10166         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10167        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10168     else { _ckvmssts(retsts); }
10169   }
10170
10171   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10172
10173 }  /* end of setup_cmddsc() */
10174
10175
10176 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10177 bool
10178 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10179 {
10180 bool exec_sts;
10181 char * cmd;
10182
10183   if (sp > mark) {
10184     if (vfork_called) {           /* this follows a vfork - act Unixish */
10185       vfork_called--;
10186       if (vfork_called < 0) {
10187         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10188         vfork_called = 0;
10189       }
10190       else return do_aexec(really,mark,sp);
10191     }
10192                                            /* no vfork - act VMSish */
10193     cmd = setup_argstr(aTHX_ really,mark,sp);
10194     exec_sts = vms_do_exec(cmd);
10195     Safefree(cmd);  /* Clean up from setup_argstr() */
10196     return exec_sts;
10197   }
10198
10199   return FALSE;
10200 }  /* end of vms_do_aexec() */
10201 /*}}}*/
10202
10203 /* {{{bool vms_do_exec(char *cmd) */
10204 bool
10205 Perl_vms_do_exec(pTHX_ const char *cmd)
10206 {
10207   struct dsc$descriptor_s *vmscmd;
10208
10209   if (vfork_called) {             /* this follows a vfork - act Unixish */
10210     vfork_called--;
10211     if (vfork_called < 0) {
10212       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10213       vfork_called = 0;
10214     }
10215     else return do_exec(cmd);
10216   }
10217
10218   {                               /* no vfork - act VMSish */
10219     unsigned long int retsts;
10220
10221     TAINT_ENV();
10222     TAINT_PROPER("exec");
10223     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10224       retsts = lib$do_command(vmscmd);
10225
10226     switch (retsts) {
10227       case RMS$_FNF: case RMS$_DNF:
10228         set_errno(ENOENT); break;
10229       case RMS$_DIR:
10230         set_errno(ENOTDIR); break;
10231       case RMS$_DEV:
10232         set_errno(ENODEV); break;
10233       case RMS$_PRV:
10234         set_errno(EACCES); break;
10235       case RMS$_SYN:
10236         set_errno(EINVAL); break;
10237       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10238         set_errno(E2BIG); break;
10239       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10240         _ckvmssts(retsts); /* fall through */
10241       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10242         set_errno(EVMSERR);
10243     }
10244     set_vaxc_errno(retsts);
10245     if (ckWARN(WARN_EXEC)) {
10246       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10247              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10248     }
10249     vms_execfree(vmscmd);
10250   }
10251
10252   return FALSE;
10253
10254 }  /* end of vms_do_exec() */
10255 /*}}}*/
10256
10257 int do_spawn2(pTHX_ const char *, int);
10258
10259 int
10260 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10261 {
10262 unsigned long int sts;
10263 char * cmd;
10264 int flags = 0;
10265
10266   if (sp > mark) {
10267
10268     /* We'll copy the (undocumented?) Win32 behavior and allow a
10269      * numeric first argument.  But the only value we'll support
10270      * through do_aspawn is a value of 1, which means spawn without
10271      * waiting for completion -- other values are ignored.
10272      */
10273     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10274         ++mark;
10275         flags = SvIVx(*mark);
10276     }
10277
10278     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10279         flags = CLI$M_NOWAIT;
10280     else
10281         flags = 0;
10282
10283     cmd = setup_argstr(aTHX_ really, mark, sp);
10284     sts = do_spawn2(aTHX_ cmd, flags);
10285     /* pp_sys will clean up cmd */
10286     return sts;
10287   }
10288   return SS$_ABORT;
10289 }  /* end of do_aspawn() */
10290 /*}}}*/
10291
10292
10293 /* {{{int do_spawn(char* cmd) */
10294 int
10295 Perl_do_spawn(pTHX_ char* cmd)
10296 {
10297     PERL_ARGS_ASSERT_DO_SPAWN;
10298
10299     return do_spawn2(aTHX_ cmd, 0);
10300 }
10301 /*}}}*/
10302
10303 /* {{{int do_spawn_nowait(char* cmd) */
10304 int
10305 Perl_do_spawn_nowait(pTHX_ char* cmd)
10306 {
10307     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10308
10309     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10310 }
10311 /*}}}*/
10312
10313 /* {{{int do_spawn2(char *cmd) */
10314 int
10315 do_spawn2(pTHX_ const char *cmd, int flags)
10316 {
10317   unsigned long int sts, substs;
10318
10319   /* The caller of this routine expects to Safefree(PL_Cmd) */
10320   Newx(PL_Cmd,10,char);
10321
10322   TAINT_ENV();
10323   TAINT_PROPER("spawn");
10324   if (!cmd || !*cmd) {
10325     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10326     if (!(sts & 1)) {
10327       switch (sts) {
10328         case RMS$_FNF:  case RMS$_DNF:
10329           set_errno(ENOENT); break;
10330         case RMS$_DIR:
10331           set_errno(ENOTDIR); break;
10332         case RMS$_DEV:
10333           set_errno(ENODEV); break;
10334         case RMS$_PRV:
10335           set_errno(EACCES); break;
10336         case RMS$_SYN:
10337           set_errno(EINVAL); break;
10338         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10339           set_errno(E2BIG); break;
10340         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10341           _ckvmssts(sts); /* fall through */
10342         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10343           set_errno(EVMSERR);
10344       }
10345       set_vaxc_errno(sts);
10346       if (ckWARN(WARN_EXEC)) {
10347         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10348                     Strerror(errno));
10349       }
10350     }
10351     sts = substs;
10352   }
10353   else {
10354     char mode[3];
10355     PerlIO * fp;
10356     if (flags & CLI$M_NOWAIT)
10357         strcpy(mode, "n");
10358     else
10359         strcpy(mode, "nW");
10360
10361     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10362     if (fp != NULL)
10363       my_pclose(fp);
10364     /* sts will be the pid in the nowait case */
10365   }
10366   return sts;
10367 }  /* end of do_spawn2() */
10368 /*}}}*/
10369
10370
10371 static unsigned int *sockflags, sockflagsize;
10372
10373 /*
10374  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10375  * routines found in some versions of the CRTL can't deal with sockets.
10376  * We don't shim the other file open routines since a socket isn't
10377  * likely to be opened by a name.
10378  */
10379 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10380 FILE *my_fdopen(int fd, const char *mode)
10381 {
10382   FILE *fp = fdopen(fd, mode);
10383
10384   if (fp) {
10385     unsigned int fdoff = fd / sizeof(unsigned int);
10386     Stat_t sbuf; /* native stat; we don't need flex_stat */
10387     if (!sockflagsize || fdoff > sockflagsize) {
10388       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
10389       else           Newx  (sockflags,fdoff+2,unsigned int);
10390       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10391       sockflagsize = fdoff + 2;
10392     }
10393     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
10394       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10395   }
10396   return fp;
10397
10398 }
10399 /*}}}*/
10400
10401
10402 /*
10403  * Clear the corresponding bit when the (possibly) socket stream is closed.
10404  * There still a small hole: we miss an implicit close which might occur
10405  * via freopen().  >> Todo
10406  */
10407 /*{{{ int my_fclose(FILE *fp)*/
10408 int my_fclose(FILE *fp) {
10409   if (fp) {
10410     unsigned int fd = fileno(fp);
10411     unsigned int fdoff = fd / sizeof(unsigned int);
10412
10413     if (sockflagsize && fdoff < sockflagsize)
10414       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10415   }
10416   return fclose(fp);
10417 }
10418 /*}}}*/
10419
10420
10421 /*
10422  * A simple fwrite replacement which outputs itmsz*nitm chars without
10423  * introducing record boundaries every itmsz chars.
10424  * We are using fputs, which depends on a terminating null.  We may
10425  * well be writing binary data, so we need to accommodate not only
10426  * data with nulls sprinkled in the middle but also data with no null
10427  * byte at the end.
10428  */
10429 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10430 int
10431 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
10432 {
10433   register char *cp, *end, *cpd, *data;
10434   register unsigned int fd = fileno(dest);
10435   register unsigned int fdoff = fd / sizeof(unsigned int);
10436   int retval;
10437   int bufsize = itmsz * nitm + 1;
10438
10439   if (fdoff < sockflagsize &&
10440       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10441     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10442     return nitm;
10443   }
10444
10445   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
10446   memcpy( data, src, itmsz*nitm );
10447   data[itmsz*nitm] = '\0';
10448
10449   end = data + itmsz * nitm;
10450   retval = (int) nitm; /* on success return # items written */
10451
10452   cpd = data;
10453   while (cpd <= end) {
10454     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10455     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
10456     if (cp < end)
10457       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10458     cpd = cp + 1;
10459   }
10460
10461   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
10462   return retval;
10463
10464 }  /* end of my_fwrite() */
10465 /*}}}*/
10466
10467 /*{{{ int my_flush(FILE *fp)*/
10468 int
10469 Perl_my_flush(pTHX_ FILE *fp)
10470 {
10471     int res;
10472     if ((res = fflush(fp)) == 0 && fp) {
10473 #ifdef VMS_DO_SOCKETS
10474         Stat_t s;
10475         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
10476 #endif
10477             res = fsync(fileno(fp));
10478     }
10479 /*
10480  * If the flush succeeded but set end-of-file, we need to clear
10481  * the error because our caller may check ferror().  BTW, this
10482  * probably means we just flushed an empty file.
10483  */
10484     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10485
10486     return res;
10487 }
10488 /*}}}*/
10489
10490 /*
10491  * Here are replacements for the following Unix routines in the VMS environment:
10492  *      getpwuid    Get information for a particular UIC or UID
10493  *      getpwnam    Get information for a named user
10494  *      getpwent    Get information for each user in the rights database
10495  *      setpwent    Reset search to the start of the rights database
10496  *      endpwent    Finish searching for users in the rights database
10497  *
10498  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10499  * (defined in pwd.h), which contains the following fields:-
10500  *      struct passwd {
10501  *              char        *pw_name;    Username (in lower case)
10502  *              char        *pw_passwd;  Hashed password
10503  *              unsigned int pw_uid;     UIC
10504  *              unsigned int pw_gid;     UIC group  number
10505  *              char        *pw_unixdir; Default device/directory (VMS-style)
10506  *              char        *pw_gecos;   Owner name
10507  *              char        *pw_dir;     Default device/directory (Unix-style)
10508  *              char        *pw_shell;   Default CLI name (eg. DCL)
10509  *      };
10510  * If the specified user does not exist, getpwuid and getpwnam return NULL.
10511  *
10512  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10513  * not the UIC member number (eg. what's returned by getuid()),
10514  * getpwuid() can accept either as input (if uid is specified, the caller's
10515  * UIC group is used), though it won't recognise gid=0.
10516  *
10517  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10518  * information about other users in your group or in other groups, respectively.
10519  * If the required privilege is not available, then these routines fill only
10520  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10521  * string).
10522  *
10523  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10524  */
10525
10526 /* sizes of various UAF record fields */
10527 #define UAI$S_USERNAME 12
10528 #define UAI$S_IDENT    31
10529 #define UAI$S_OWNER    31
10530 #define UAI$S_DEFDEV   31
10531 #define UAI$S_DEFDIR   63
10532 #define UAI$S_DEFCLI   31
10533 #define UAI$S_PWD       8
10534
10535 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
10536                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10537                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
10538
10539 static char __empty[]= "";
10540 static struct passwd __passwd_empty=
10541     {(char *) __empty, (char *) __empty, 0, 0,
10542      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10543 static int contxt= 0;
10544 static struct passwd __pwdcache;
10545 static char __pw_namecache[UAI$S_IDENT+1];
10546
10547 /*
10548  * This routine does most of the work extracting the user information.
10549  */
10550 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
10551 {
10552     static struct {
10553         unsigned char length;
10554         char pw_gecos[UAI$S_OWNER+1];
10555     } owner;
10556     static union uicdef uic;
10557     static struct {
10558         unsigned char length;
10559         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
10560     } defdev;
10561     static struct {
10562         unsigned char length;
10563         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
10564     } defdir;
10565     static struct {
10566         unsigned char length;
10567         char pw_shell[UAI$S_DEFCLI+1];
10568     } defcli;
10569     static char pw_passwd[UAI$S_PWD+1];
10570
10571     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
10572     struct dsc$descriptor_s name_desc;
10573     unsigned long int sts;
10574
10575     static struct itmlst_3 itmlst[]= {
10576         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
10577         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
10578         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
10579         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
10580         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
10581         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
10582         {0,                0,           NULL,    NULL}};
10583
10584     name_desc.dsc$w_length=  strlen(name);
10585     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10586     name_desc.dsc$b_class=   DSC$K_CLASS_S;
10587     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
10588
10589 /*  Note that sys$getuai returns many fields as counted strings. */
10590     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
10591     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
10592       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
10593     }
10594     else { _ckvmssts(sts); }
10595     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
10596
10597     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
10598     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
10599     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
10600     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
10601     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
10602     owner.pw_gecos[lowner]=            '\0';
10603     defdev.pw_dir[ldefdev+ldefdir]= '\0';
10604     defcli.pw_shell[ldefcli]=          '\0';
10605     if (valid_uic(uic)) {
10606         pwd->pw_uid= uic.uic$l_uic;
10607         pwd->pw_gid= uic.uic$v_group;
10608     }
10609     else
10610       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
10611     pwd->pw_passwd=  pw_passwd;
10612     pwd->pw_gecos=   owner.pw_gecos;
10613     pwd->pw_dir=     defdev.pw_dir;
10614     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
10615     pwd->pw_shell=   defcli.pw_shell;
10616     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
10617         int ldir;
10618         ldir= strlen(pwd->pw_unixdir) - 1;
10619         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
10620     }
10621     else
10622         strcpy(pwd->pw_unixdir, pwd->pw_dir);
10623     if (!decc_efs_case_preserve)
10624         __mystrtolower(pwd->pw_unixdir);
10625     return 1;
10626 }
10627
10628 /*
10629  * Get information for a named user.
10630 */
10631 /*{{{struct passwd *getpwnam(char *name)*/
10632 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
10633 {
10634     struct dsc$descriptor_s name_desc;
10635     union uicdef uic;
10636     unsigned long int status, sts;
10637
10638     __pwdcache = __passwd_empty;
10639     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
10640       /* We still may be able to determine pw_uid and pw_gid */
10641       name_desc.dsc$w_length=  strlen(name);
10642       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10643       name_desc.dsc$b_class=   DSC$K_CLASS_S;
10644       name_desc.dsc$a_pointer= (char *) name;
10645       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
10646         __pwdcache.pw_uid= uic.uic$l_uic;
10647         __pwdcache.pw_gid= uic.uic$v_group;
10648       }
10649       else {
10650         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
10651           set_vaxc_errno(sts);
10652           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
10653           return NULL;
10654         }
10655         else { _ckvmssts(sts); }
10656       }
10657     }
10658     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
10659     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
10660     __pwdcache.pw_name= __pw_namecache;
10661     return &__pwdcache;
10662 }  /* end of my_getpwnam() */
10663 /*}}}*/
10664
10665 /*
10666  * Get information for a particular UIC or UID.
10667  * Called by my_getpwent with uid=-1 to list all users.
10668 */
10669 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
10670 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
10671 {
10672     const $DESCRIPTOR(name_desc,__pw_namecache);
10673     unsigned short lname;
10674     union uicdef uic;
10675     unsigned long int status;
10676
10677     if (uid == (unsigned int) -1) {
10678       do {
10679         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
10680         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
10681           set_vaxc_errno(status);
10682           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10683           my_endpwent();
10684           return NULL;
10685         }
10686         else { _ckvmssts(status); }
10687       } while (!valid_uic (uic));
10688     }
10689     else {
10690       uic.uic$l_uic= uid;
10691       if (!uic.uic$v_group)
10692         uic.uic$v_group= PerlProc_getgid();
10693       if (valid_uic(uic))
10694         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
10695       else status = SS$_IVIDENT;
10696       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
10697           status == RMS$_PRV) {
10698         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10699         return NULL;
10700       }
10701       else { _ckvmssts(status); }
10702     }
10703     __pw_namecache[lname]= '\0';
10704     __mystrtolower(__pw_namecache);
10705
10706     __pwdcache = __passwd_empty;
10707     __pwdcache.pw_name = __pw_namecache;
10708
10709 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10710     The identifier's value is usually the UIC, but it doesn't have to be,
10711     so if we can, we let fillpasswd update this. */
10712     __pwdcache.pw_uid =  uic.uic$l_uic;
10713     __pwdcache.pw_gid =  uic.uic$v_group;
10714
10715     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10716     return &__pwdcache;
10717
10718 }  /* end of my_getpwuid() */
10719 /*}}}*/
10720
10721 /*
10722  * Get information for next user.
10723 */
10724 /*{{{struct passwd *my_getpwent()*/
10725 struct passwd *Perl_my_getpwent(pTHX)
10726 {
10727     return (my_getpwuid((unsigned int) -1));
10728 }
10729 /*}}}*/
10730
10731 /*
10732  * Finish searching rights database for users.
10733 */
10734 /*{{{void my_endpwent()*/
10735 void Perl_my_endpwent(pTHX)
10736 {
10737     if (contxt) {
10738       _ckvmssts(sys$finish_rdb(&contxt));
10739       contxt= 0;
10740     }
10741 }
10742 /*}}}*/
10743
10744 #ifdef HOMEGROWN_POSIX_SIGNALS
10745   /* Signal handling routines, pulled into the core from POSIX.xs.
10746    *
10747    * We need these for threads, so they've been rolled into the core,
10748    * rather than left in POSIX.xs.
10749    *
10750    * (DRS, Oct 23, 1997)
10751    */
10752
10753   /* sigset_t is atomic under VMS, so these routines are easy */
10754 /*{{{int my_sigemptyset(sigset_t *) */
10755 int my_sigemptyset(sigset_t *set) {
10756     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10757     *set = 0; return 0;
10758 }
10759 /*}}}*/
10760
10761
10762 /*{{{int my_sigfillset(sigset_t *)*/
10763 int my_sigfillset(sigset_t *set) {
10764     int i;
10765     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10766     for (i = 0; i < NSIG; i++) *set |= (1 << i);
10767     return 0;
10768 }
10769 /*}}}*/
10770
10771
10772 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10773 int my_sigaddset(sigset_t *set, int sig) {
10774     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10775     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10776     *set |= (1 << (sig - 1));
10777     return 0;
10778 }
10779 /*}}}*/
10780
10781
10782 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10783 int my_sigdelset(sigset_t *set, int sig) {
10784     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10785     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10786     *set &= ~(1 << (sig - 1));
10787     return 0;
10788 }
10789 /*}}}*/
10790
10791
10792 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10793 int my_sigismember(sigset_t *set, int sig) {
10794     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10795     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10796     return *set & (1 << (sig - 1));
10797 }
10798 /*}}}*/
10799
10800
10801 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10802 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10803     sigset_t tempmask;
10804
10805     /* If set and oset are both null, then things are badly wrong. Bail out. */
10806     if ((oset == NULL) && (set == NULL)) {
10807       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10808       return -1;
10809     }
10810
10811     /* If set's null, then we're just handling a fetch. */
10812     if (set == NULL) {
10813         tempmask = sigblock(0);
10814     }
10815     else {
10816       switch (how) {
10817       case SIG_SETMASK:
10818         tempmask = sigsetmask(*set);
10819         break;
10820       case SIG_BLOCK:
10821         tempmask = sigblock(*set);
10822         break;
10823       case SIG_UNBLOCK:
10824         tempmask = sigblock(0);
10825         sigsetmask(*oset & ~tempmask);
10826         break;
10827       default:
10828         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10829         return -1;
10830       }
10831     }
10832
10833     /* Did they pass us an oset? If so, stick our holding mask into it */
10834     if (oset)
10835       *oset = tempmask;
10836
10837     return 0;
10838 }
10839 /*}}}*/
10840 #endif  /* HOMEGROWN_POSIX_SIGNALS */
10841
10842
10843 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10844  * my_utime(), and flex_stat(), all of which operate on UTC unless
10845  * VMSISH_TIMES is true.
10846  */
10847 /* method used to handle UTC conversions:
10848  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
10849  */
10850 static int gmtime_emulation_type;
10851 /* number of secs to add to UTC POSIX-style time to get local time */
10852 static long int utc_offset_secs;
10853
10854 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10855  * in vmsish.h.  #undef them here so we can call the CRTL routines
10856  * directly.
10857  */
10858 #undef gmtime
10859 #undef localtime
10860 #undef time
10861
10862
10863 /*
10864  * DEC C previous to 6.0 corrupts the behavior of the /prefix
10865  * qualifier with the extern prefix pragma.  This provisional
10866  * hack circumvents this prefix pragma problem in previous
10867  * precompilers.
10868  */
10869 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10870 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10871 #    pragma __extern_prefix save
10872 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
10873 #    define gmtime decc$__utctz_gmtime
10874 #    define localtime decc$__utctz_localtime
10875 #    define time decc$__utc_time
10876 #    pragma __extern_prefix restore
10877
10878      struct tm *gmtime(), *localtime();
10879
10880 #  endif
10881 #endif
10882
10883
10884 static time_t toutc_dst(time_t loc) {
10885   struct tm *rsltmp;
10886
10887   if ((rsltmp = localtime(&loc)) == NULL) return -1;
10888   loc -= utc_offset_secs;
10889   if (rsltmp->tm_isdst) loc -= 3600;
10890   return loc;
10891 }
10892 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10893        ((gmtime_emulation_type || my_time(NULL)), \
10894        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10895        ((secs) - utc_offset_secs))))
10896
10897 static time_t toloc_dst(time_t utc) {
10898   struct tm *rsltmp;
10899
10900   utc += utc_offset_secs;
10901   if ((rsltmp = localtime(&utc)) == NULL) return -1;
10902   if (rsltmp->tm_isdst) utc += 3600;
10903   return utc;
10904 }
10905 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10906        ((gmtime_emulation_type || my_time(NULL)), \
10907        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10908        ((secs) + utc_offset_secs))))
10909
10910 #ifndef RTL_USES_UTC
10911 /*
10912
10913     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
10914         DST starts on 1st sun of april      at 02:00  std time
10915             ends on last sun of october     at 02:00  dst time
10916     see the UCX management command reference, SET CONFIG TIMEZONE
10917     for formatting info.
10918
10919     No, it's not as general as it should be, but then again, NOTHING
10920     will handle UK times in a sensible way.
10921 */
10922
10923
10924 /*
10925     parse the DST start/end info:
10926     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10927 */
10928
10929 static char *
10930 tz_parse_startend(char *s, struct tm *w, int *past)
10931 {
10932     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10933     int ly, dozjd, d, m, n, hour, min, sec, j, k;
10934     time_t g;
10935
10936     if (!s)    return 0;
10937     if (!w) return 0;
10938     if (!past) return 0;
10939
10940     ly = 0;
10941     if (w->tm_year % 4        == 0) ly = 1;
10942     if (w->tm_year % 100      == 0) ly = 0;
10943     if (w->tm_year+1900 % 400 == 0) ly = 1;
10944     if (ly) dinm[1]++;
10945
10946     dozjd = isdigit(*s);
10947     if (*s == 'J' || *s == 'j' || dozjd) {
10948         if (!dozjd && !isdigit(*++s)) return 0;
10949         d = *s++ - '0';
10950         if (isdigit(*s)) {
10951             d = d*10 + *s++ - '0';
10952             if (isdigit(*s)) {
10953                 d = d*10 + *s++ - '0';
10954             }
10955         }
10956         if (d == 0) return 0;
10957         if (d > 366) return 0;
10958         d--;
10959         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
10960         g = d * 86400;
10961         dozjd = 1;
10962     } else if (*s == 'M' || *s == 'm') {
10963         if (!isdigit(*++s)) return 0;
10964         m = *s++ - '0';
10965         if (isdigit(*s)) m = 10*m + *s++ - '0';
10966         if (*s != '.') return 0;
10967         if (!isdigit(*++s)) return 0;
10968         n = *s++ - '0';
10969         if (n < 1 || n > 5) return 0;
10970         if (*s != '.') return 0;
10971         if (!isdigit(*++s)) return 0;
10972         d = *s++ - '0';
10973         if (d > 6) return 0;
10974     }
10975
10976     if (*s == '/') {
10977         if (!isdigit(*++s)) return 0;
10978         hour = *s++ - '0';
10979         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10980         if (*s == ':') {
10981             if (!isdigit(*++s)) return 0;
10982             min = *s++ - '0';
10983             if (isdigit(*s)) min = 10*min + *s++ - '0';
10984             if (*s == ':') {
10985                 if (!isdigit(*++s)) return 0;
10986                 sec = *s++ - '0';
10987                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10988             }
10989         }
10990     } else {
10991         hour = 2;
10992         min = 0;
10993         sec = 0;
10994     }
10995
10996     if (dozjd) {
10997         if (w->tm_yday < d) goto before;
10998         if (w->tm_yday > d) goto after;
10999     } else {
11000         if (w->tm_mon+1 < m) goto before;
11001         if (w->tm_mon+1 > m) goto after;
11002
11003         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
11004         k = d - j; /* mday of first d */
11005         if (k <= 0) k += 7;
11006         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
11007         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11008         if (w->tm_mday < k) goto before;
11009         if (w->tm_mday > k) goto after;
11010     }
11011
11012     if (w->tm_hour < hour) goto before;
11013     if (w->tm_hour > hour) goto after;
11014     if (w->tm_min  < min)  goto before;
11015     if (w->tm_min  > min)  goto after;
11016     if (w->tm_sec  < sec)  goto before;
11017     goto after;
11018
11019 before:
11020     *past = 0;
11021     return s;
11022 after:
11023     *past = 1;
11024     return s;
11025 }
11026
11027
11028
11029
11030 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
11031
11032 static char *
11033 tz_parse_offset(char *s, int *offset)
11034 {
11035     int hour = 0, min = 0, sec = 0;
11036     int neg = 0;
11037     if (!s) return 0;
11038     if (!offset) return 0;
11039
11040     if (*s == '-') {neg++; s++;}
11041     if (*s == '+') s++;
11042     if (!isdigit(*s)) return 0;
11043     hour = *s++ - '0';
11044     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11045     if (hour > 24) return 0;
11046     if (*s == ':') {
11047         if (!isdigit(*++s)) return 0;
11048         min = *s++ - '0';
11049         if (isdigit(*s)) min = min*10 + (*s++ - '0');
11050         if (min > 59) return 0;
11051         if (*s == ':') {
11052             if (!isdigit(*++s)) return 0;
11053             sec = *s++ - '0';
11054             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11055             if (sec > 59) return 0;
11056         }
11057     }
11058
11059     *offset = (hour*60+min)*60 + sec;
11060     if (neg) *offset = -*offset;
11061     return s;
11062 }
11063
11064 /*
11065     input time is w, whatever type of time the CRTL localtime() uses.
11066     sets dst, the zone, and the gmtoff (seconds)
11067
11068     caches the value of TZ and UCX$TZ env variables; note that
11069     my_setenv looks for these and sets a flag if they're changed
11070     for efficiency.
11071
11072     We have to watch out for the "australian" case (dst starts in
11073     october, ends in april)...flagged by "reverse" and checked by
11074     scanning through the months of the previous year.
11075
11076 */
11077
11078 static int
11079 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11080 {
11081     time_t when;
11082     struct tm *w2;
11083     char *s,*s2;
11084     char *dstzone, *tz, *s_start, *s_end;
11085     int std_off, dst_off, isdst;
11086     int y, dststart, dstend;
11087     static char envtz[1025];  /* longer than any logical, symbol, ... */
11088     static char ucxtz[1025];
11089     static char reversed = 0;
11090
11091     if (!w) return 0;
11092
11093     if (tz_updated) {
11094         tz_updated = 0;
11095         reversed = -1;  /* flag need to check  */
11096         envtz[0] = ucxtz[0] = '\0';
11097         tz = my_getenv("TZ",0);
11098         if (tz) strcpy(envtz, tz);
11099         tz = my_getenv("UCX$TZ",0);
11100         if (tz) strcpy(ucxtz, tz);
11101         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
11102     }
11103     tz = envtz;
11104     if (!*tz) tz = ucxtz;
11105
11106     s = tz;
11107     while (isalpha(*s)) s++;
11108     s = tz_parse_offset(s, &std_off);
11109     if (!s) return 0;
11110     if (!*s) {                  /* no DST, hurray we're done! */
11111         isdst = 0;
11112         goto done;
11113     }
11114
11115     dstzone = s;
11116     while (isalpha(*s)) s++;
11117     s2 = tz_parse_offset(s, &dst_off);
11118     if (s2) {
11119         s = s2;
11120     } else {
11121         dst_off = std_off - 3600;
11122     }
11123
11124     if (!*s) {      /* default dst start/end?? */
11125         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
11126             s = strchr(ucxtz,',');
11127         }
11128         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
11129     }
11130     if (*s != ',') return 0;
11131
11132     when = *w;
11133     when = _toutc(when);      /* convert to utc */
11134     when = when - std_off;    /* convert to pseudolocal time*/
11135
11136     w2 = localtime(&when);
11137     y = w2->tm_year;
11138     s_start = s+1;
11139     s = tz_parse_startend(s_start,w2,&dststart);
11140     if (!s) return 0;
11141     if (*s != ',') return 0;
11142
11143     when = *w;
11144     when = _toutc(when);      /* convert to utc */
11145     when = when - dst_off;    /* convert to pseudolocal time*/
11146     w2 = localtime(&when);
11147     if (w2->tm_year != y) {   /* spans a year, just check one time */
11148         when += dst_off - std_off;
11149         w2 = localtime(&when);
11150     }
11151     s_end = s+1;
11152     s = tz_parse_startend(s_end,w2,&dstend);
11153     if (!s) return 0;
11154
11155     if (reversed == -1) {  /* need to check if start later than end */
11156         int j, ds, de;
11157
11158         when = *w;
11159         if (when < 2*365*86400) {
11160             when += 2*365*86400;
11161         } else {
11162             when -= 365*86400;
11163         }
11164         w2 =localtime(&when);
11165         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
11166
11167         for (j = 0; j < 12; j++) {
11168             w2 =localtime(&when);
11169             tz_parse_startend(s_start,w2,&ds);
11170             tz_parse_startend(s_end,w2,&de);
11171             if (ds != de) break;
11172             when += 30*86400;
11173         }
11174         reversed = 0;
11175         if (de && !ds) reversed = 1;
11176     }
11177
11178     isdst = dststart && !dstend;
11179     if (reversed) isdst = dststart  || !dstend;
11180
11181 done:
11182     if (dst)    *dst = isdst;
11183     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11184     if (isdst)  tz = dstzone;
11185     if (zone) {
11186         while(isalpha(*tz))  *zone++ = *tz++;
11187         *zone = '\0';
11188     }
11189     return 1;
11190 }
11191
11192 #endif /* !RTL_USES_UTC */
11193
11194 /* my_time(), my_localtime(), my_gmtime()
11195  * By default traffic in UTC time values, using CRTL gmtime() or
11196  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11197  * Note: We need to use these functions even when the CRTL has working
11198  * UTC support, since they also handle C<use vmsish qw(times);>
11199  *
11200  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11201  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11202  */
11203
11204 /*{{{time_t my_time(time_t *timep)*/
11205 time_t Perl_my_time(pTHX_ time_t *timep)
11206 {
11207   time_t when;
11208   struct tm *tm_p;
11209
11210   if (gmtime_emulation_type == 0) {
11211     int dstnow;
11212     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11213                               /* results of calls to gmtime() and localtime() */
11214                               /* for same &base */
11215
11216     gmtime_emulation_type++;
11217     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11218       char off[LNM$C_NAMLENGTH+1];;
11219
11220       gmtime_emulation_type++;
11221       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11222         gmtime_emulation_type++;
11223         utc_offset_secs = 0;
11224         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11225       }
11226       else { utc_offset_secs = atol(off); }
11227     }
11228     else { /* We've got a working gmtime() */
11229       struct tm gmt, local;
11230
11231       gmt = *tm_p;
11232       tm_p = localtime(&base);
11233       local = *tm_p;
11234       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11235       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11236       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11237       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11238     }
11239   }
11240
11241   when = time(NULL);
11242 # ifdef VMSISH_TIME
11243 # ifdef RTL_USES_UTC
11244   if (VMSISH_TIME) when = _toloc(when);
11245 # else
11246   if (!VMSISH_TIME) when = _toutc(when);
11247 # endif
11248 # endif
11249   if (timep != NULL) *timep = when;
11250   return when;
11251
11252 }  /* end of my_time() */
11253 /*}}}*/
11254
11255
11256 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11257 struct tm *
11258 Perl_my_gmtime(pTHX_ const time_t *timep)
11259 {
11260   char *p;
11261   time_t when;
11262   struct tm *rsltmp;
11263
11264   if (timep == NULL) {
11265     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11266     return NULL;
11267   }
11268   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11269
11270   when = *timep;
11271 # ifdef VMSISH_TIME
11272   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11273 #  endif
11274 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
11275   return gmtime(&when);
11276 # else
11277   /* CRTL localtime() wants local time as input, so does no tz correction */
11278   rsltmp = localtime(&when);
11279   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
11280   return rsltmp;
11281 #endif
11282 }  /* end of my_gmtime() */
11283 /*}}}*/
11284
11285
11286 /*{{{struct tm *my_localtime(const time_t *timep)*/
11287 struct tm *
11288 Perl_my_localtime(pTHX_ const time_t *timep)
11289 {
11290   time_t when, whenutc;
11291   struct tm *rsltmp;
11292   int dst, offset;
11293
11294   if (timep == NULL) {
11295     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11296     return NULL;
11297   }
11298   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11299   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11300
11301   when = *timep;
11302 # ifdef RTL_USES_UTC
11303 # ifdef VMSISH_TIME
11304   if (VMSISH_TIME) when = _toutc(when);
11305 # endif
11306   /* CRTL localtime() wants UTC as input, does tz correction itself */
11307   return localtime(&when);
11308
11309 # else /* !RTL_USES_UTC */
11310   whenutc = when;
11311 # ifdef VMSISH_TIME
11312   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
11313   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
11314 # endif
11315   dst = -1;
11316 #ifndef RTL_USES_UTC
11317   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
11318       when = whenutc - offset;                   /* pseudolocal time*/
11319   }
11320 # endif
11321   /* CRTL localtime() wants local time as input, so does no tz correction */
11322   rsltmp = localtime(&when);
11323   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11324   return rsltmp;
11325 # endif
11326
11327 } /*  end of my_localtime() */
11328 /*}}}*/
11329
11330 /* Reset definitions for later calls */
11331 #define gmtime(t)    my_gmtime(t)
11332 #define localtime(t) my_localtime(t)
11333 #define time(t)      my_time(t)
11334
11335
11336 /* my_utime - update modification/access time of a file
11337  *
11338  * VMS 7.3 and later implementation
11339  * Only the UTC translation is home-grown. The rest is handled by the
11340  * CRTL utime(), which will take into account the relevant feature
11341  * logicals and ODS-5 volume characteristics for true access times.
11342  *
11343  * pre VMS 7.3 implementation:
11344  * The calling sequence is identical to POSIX utime(), but under
11345  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11346  * not maintain access times.  Restrictions differ from the POSIX
11347  * definition in that the time can be changed as long as the
11348  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11349  * no separate checks are made to insure that the caller is the
11350  * owner of the file or has special privs enabled.
11351  * Code here is based on Joe Meadows' FILE utility.
11352  *
11353  */
11354
11355 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11356  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11357  * in 100 ns intervals.
11358  */
11359 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11360
11361 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11362 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11363 {
11364 #if __CRTL_VER >= 70300000
11365   struct utimbuf utc_utimes, *utc_utimesp;
11366
11367   if (utimes != NULL) {
11368     utc_utimes.actime = utimes->actime;
11369     utc_utimes.modtime = utimes->modtime;
11370 # ifdef VMSISH_TIME
11371     /* If input was local; convert to UTC for sys svc */
11372     if (VMSISH_TIME) {
11373       utc_utimes.actime = _toutc(utimes->actime);
11374       utc_utimes.modtime = _toutc(utimes->modtime);
11375     }
11376 # endif
11377     utc_utimesp = &utc_utimes;
11378   }
11379   else {
11380     utc_utimesp = NULL;
11381   }
11382
11383   return utime(file, utc_utimesp);
11384
11385 #else /* __CRTL_VER < 70300000 */
11386
11387   register int i;
11388   int sts;
11389   long int bintime[2], len = 2, lowbit, unixtime,
11390            secscale = 10000000; /* seconds --> 100 ns intervals */
11391   unsigned long int chan, iosb[2], retsts;
11392   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11393   struct FAB myfab = cc$rms_fab;
11394   struct NAM mynam = cc$rms_nam;
11395 #if defined (__DECC) && defined (__VAX)
11396   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11397    * at least through VMS V6.1, which causes a type-conversion warning.
11398    */
11399 #  pragma message save
11400 #  pragma message disable cvtdiftypes
11401 #endif
11402   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11403   struct fibdef myfib;
11404 #if defined (__DECC) && defined (__VAX)
11405   /* This should be right after the declaration of myatr, but due
11406    * to a bug in VAX DEC C, this takes effect a statement early.
11407    */
11408 #  pragma message restore
11409 #endif
11410   /* cast ok for read only parameter */
11411   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11412                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11413                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11414
11415   if (file == NULL || *file == '\0') {
11416     SETERRNO(ENOENT, LIB$_INVARG);
11417     return -1;
11418   }
11419
11420   /* Convert to VMS format ensuring that it will fit in 255 characters */
11421   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
11422       SETERRNO(ENOENT, LIB$_INVARG);
11423       return -1;
11424   }
11425   if (utimes != NULL) {
11426     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11427      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11428      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11429      * as input, we force the sign bit to be clear by shifting unixtime right
11430      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11431      */
11432     lowbit = (utimes->modtime & 1) ? secscale : 0;
11433     unixtime = (long int) utimes->modtime;
11434 #   ifdef VMSISH_TIME
11435     /* If input was UTC; convert to local for sys svc */
11436     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11437 #   endif
11438     unixtime >>= 1;  secscale <<= 1;
11439     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11440     if (!(retsts & 1)) {
11441       SETERRNO(EVMSERR, retsts);
11442       return -1;
11443     }
11444     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11445     if (!(retsts & 1)) {
11446       SETERRNO(EVMSERR, retsts);
11447       return -1;
11448     }
11449   }
11450   else {
11451     /* Just get the current time in VMS format directly */
11452     retsts = sys$gettim(bintime);
11453     if (!(retsts & 1)) {
11454       SETERRNO(EVMSERR, retsts);
11455       return -1;
11456     }
11457   }
11458
11459   myfab.fab$l_fna = vmsspec;
11460   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11461   myfab.fab$l_nam = &mynam;
11462   mynam.nam$l_esa = esa;
11463   mynam.nam$b_ess = (unsigned char) sizeof esa;
11464   mynam.nam$l_rsa = rsa;
11465   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11466   if (decc_efs_case_preserve)
11467       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11468
11469   /* Look for the file to be affected, letting RMS parse the file
11470    * specification for us as well.  I have set errno using only
11471    * values documented in the utime() man page for VMS POSIX.
11472    */
11473   retsts = sys$parse(&myfab,0,0);
11474   if (!(retsts & 1)) {
11475     set_vaxc_errno(retsts);
11476     if      (retsts == RMS$_PRV) set_errno(EACCES);
11477     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11478     else                         set_errno(EVMSERR);
11479     return -1;
11480   }
11481   retsts = sys$search(&myfab,0,0);
11482   if (!(retsts & 1)) {
11483     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11484     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11485     set_vaxc_errno(retsts);
11486     if      (retsts == RMS$_PRV) set_errno(EACCES);
11487     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11488     else                         set_errno(EVMSERR);
11489     return -1;
11490   }
11491
11492   devdsc.dsc$w_length = mynam.nam$b_dev;
11493   /* cast ok for read only parameter */
11494   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11495
11496   retsts = sys$assign(&devdsc,&chan,0,0);
11497   if (!(retsts & 1)) {
11498     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11499     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11500     set_vaxc_errno(retsts);
11501     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11502     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11503     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11504     else                               set_errno(EVMSERR);
11505     return -1;
11506   }
11507
11508   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11509   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11510
11511   memset((void *) &myfib, 0, sizeof myfib);
11512 #if defined(__DECC) || defined(__DECCXX)
11513   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11514   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11515   /* This prevents the revision time of the file being reset to the current
11516    * time as a result of our IO$_MODIFY $QIO. */
11517   myfib.fib$l_acctl = FIB$M_NORECORD;
11518 #else
11519   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11520   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11521   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11522 #endif
11523   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11524   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11525   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11526   _ckvmssts(sys$dassgn(chan));
11527   if (retsts & 1) retsts = iosb[0];
11528   if (!(retsts & 1)) {
11529     set_vaxc_errno(retsts);
11530     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11531     else                      set_errno(EVMSERR);
11532     return -1;
11533   }
11534
11535   return 0;
11536
11537 #endif /* #if __CRTL_VER >= 70300000 */
11538
11539 }  /* end of my_utime() */
11540 /*}}}*/
11541
11542 /*
11543  * flex_stat, flex_lstat, flex_fstat
11544  * basic stat, but gets it right when asked to stat
11545  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11546  */
11547
11548 #ifndef _USE_STD_STAT
11549 /* encode_dev packs a VMS device name string into an integer to allow
11550  * simple comparisons. This can be used, for example, to check whether two
11551  * files are located on the same device, by comparing their encoded device
11552  * names. Even a string comparison would not do, because stat() reuses the
11553  * device name buffer for each call; so without encode_dev, it would be
11554  * necessary to save the buffer and use strcmp (this would mean a number of
11555  * changes to the standard Perl code, to say nothing of what a Perl script
11556  * would have to do.
11557  *
11558  * The device lock id, if it exists, should be unique (unless perhaps compared
11559  * with lock ids transferred from other nodes). We have a lock id if the disk is
11560  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11561  * device names. Thus we use the lock id in preference, and only if that isn't
11562  * available, do we try to pack the device name into an integer (flagged by
11563  * the sign bit (LOCKID_MASK) being set).
11564  *
11565  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11566  * name and its encoded form, but it seems very unlikely that we will find
11567  * two files on different disks that share the same encoded device names,
11568  * and even more remote that they will share the same file id (if the test
11569  * is to check for the same file).
11570  *
11571  * A better method might be to use sys$device_scan on the first call, and to
11572  * search for the device, returning an index into the cached array.
11573  * The number returned would be more intelligible.
11574  * This is probably not worth it, and anyway would take quite a bit longer
11575  * on the first call.
11576  */
11577 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11578 static mydev_t encode_dev (pTHX_ const char *dev)
11579 {
11580   int i;
11581   unsigned long int f;
11582   mydev_t enc;
11583   char c;
11584   const char *q;
11585
11586   if (!dev || !dev[0]) return 0;
11587
11588 #if LOCKID_MASK
11589   {
11590     struct dsc$descriptor_s dev_desc;
11591     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11592
11593     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11594        can try that first. */
11595     dev_desc.dsc$w_length =  strlen (dev);
11596     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11597     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11598     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11599     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11600     if (!$VMS_STATUS_SUCCESS(status)) {
11601       switch (status) {
11602         case SS$_NOSUCHDEV:
11603           SETERRNO(ENODEV, status);
11604           return 0;
11605         default:
11606           _ckvmssts(status);
11607       }
11608     }
11609     if (lockid) return (lockid & ~LOCKID_MASK);
11610   }
11611 #endif
11612
11613   /* Otherwise we try to encode the device name */
11614   enc = 0;
11615   f = 1;
11616   i = 0;
11617   for (q = dev + strlen(dev); q--; q >= dev) {
11618     if (*q == ':')
11619         break;
11620     if (isdigit (*q))
11621       c= (*q) - '0';
11622     else if (isalpha (toupper (*q)))
11623       c= toupper (*q) - 'A' + (char)10;
11624     else
11625       continue; /* Skip '$'s */
11626     i++;
11627     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11628     if (i>1) f *= 36;
11629     enc += f * (unsigned long int) c;
11630   }
11631   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11632
11633 }  /* end of encode_dev() */
11634 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11635         device_no = encode_dev(aTHX_ devname)
11636 #else
11637 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11638         device_no = new_dev_no
11639 #endif
11640
11641 static int
11642 is_null_device(name)
11643     const char *name;
11644 {
11645   if (decc_bug_devnull != 0) {
11646     if (strncmp("/dev/null", name, 9) == 0)
11647       return 1;
11648   }
11649     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11650        The underscore prefix, controller letter, and unit number are
11651        independently optional; for our purposes, the colon punctuation
11652        is not.  The colon can be trailed by optional directory and/or
11653        filename, but two consecutive colons indicates a nodename rather
11654        than a device.  [pr]  */
11655   if (*name == '_') ++name;
11656   if (tolower(*name++) != 'n') return 0;
11657   if (tolower(*name++) != 'l') return 0;
11658   if (tolower(*name) == 'a') ++name;
11659   if (*name == '0') ++name;
11660   return (*name++ == ':') && (*name != ':');
11661 }
11662
11663
11664 static I32
11665 Perl_cando_by_name_int
11666    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11667 {
11668   char usrname[L_cuserid];
11669   struct dsc$descriptor_s usrdsc =
11670          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11671   char *vmsname = NULL, *fileified = NULL;
11672   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11673   unsigned short int retlen, trnlnm_iter_count;
11674   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11675   union prvdef curprv;
11676   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11677          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11678          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11679   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11680          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11681          {0,0,0,0}};
11682   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11683          {0,0,0,0}};
11684   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11685   Stat_t st;
11686   static int profile_context = -1;
11687
11688   if (!fname || !*fname) return FALSE;
11689
11690   /* Make sure we expand logical names, since sys$check_access doesn't */
11691   fileified = PerlMem_malloc(VMS_MAXRSS);
11692   if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
11693   if (!strpbrk(fname,"/]>:")) {
11694       strcpy(fileified,fname);
11695       trnlnm_iter_count = 0;
11696       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11697         trnlnm_iter_count++;
11698         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11699       }
11700       fname = fileified;
11701   }
11702
11703   vmsname = PerlMem_malloc(VMS_MAXRSS);
11704   if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11705   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11706     /* Don't know if already in VMS format, so make sure */
11707     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11708       PerlMem_free(fileified);
11709       PerlMem_free(vmsname);
11710       return FALSE;
11711     }
11712   }
11713   else {
11714     strcpy(vmsname,fname);
11715   }
11716
11717   /* sys$check_access needs a file spec, not a directory spec.
11718    * Don't use flex_stat here, as that depends on thread context
11719    * having been initialized, and we may get here during startup.
11720    */
11721
11722   retlen = namdsc.dsc$w_length = strlen(vmsname);
11723   if (vmsname[retlen-1] == ']'
11724       || vmsname[retlen-1] == '>'
11725       || vmsname[retlen-1] == ':'
11726       || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11727
11728       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11729         PerlMem_free(fileified);
11730         PerlMem_free(vmsname);
11731         return FALSE;
11732       }
11733       fname = fileified;
11734   }
11735   else {
11736       fname = vmsname;
11737   }
11738
11739   retlen = namdsc.dsc$w_length = strlen(fname);
11740   namdsc.dsc$a_pointer = (char *)fname;
11741
11742   switch (bit) {
11743     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11744       access = ARM$M_EXECUTE;
11745       flags = CHP$M_READ;
11746       break;
11747     case S_IRUSR: case S_IRGRP: case S_IROTH:
11748       access = ARM$M_READ;
11749       flags = CHP$M_READ | CHP$M_USEREADALL;
11750       break;
11751     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11752       access = ARM$M_WRITE;
11753       flags = CHP$M_READ | CHP$M_WRITE;
11754       break;
11755     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11756       access = ARM$M_DELETE;
11757       flags = CHP$M_READ | CHP$M_WRITE;
11758       break;
11759     default:
11760       if (fileified != NULL)
11761         PerlMem_free(fileified);
11762       if (vmsname != NULL)
11763         PerlMem_free(vmsname);
11764       return FALSE;
11765   }
11766
11767   /* Before we call $check_access, create a user profile with the current
11768    * process privs since otherwise it just uses the default privs from the
11769    * UAF and might give false positives or negatives.  This only works on
11770    * VMS versions v6.0 and later since that's when sys$create_user_profile
11771    * became available.
11772    */
11773
11774   /* get current process privs and username */
11775   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11776   _ckvmssts(iosb[0]);
11777
11778 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11779
11780   /* find out the space required for the profile */
11781   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11782                                     &usrprodsc.dsc$w_length,&profile_context));
11783
11784   /* allocate space for the profile and get it filled in */
11785   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11786   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11787   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11788                                     &usrprodsc.dsc$w_length,&profile_context));
11789
11790   /* use the profile to check access to the file; free profile & analyze results */
11791   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11792   PerlMem_free(usrprodsc.dsc$a_pointer);
11793   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11794
11795 #else
11796
11797   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11798
11799 #endif
11800
11801   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11802       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11803       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11804     set_vaxc_errno(retsts);
11805     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11806     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11807     else set_errno(ENOENT);
11808     if (fileified != NULL)
11809       PerlMem_free(fileified);
11810     if (vmsname != NULL)
11811       PerlMem_free(vmsname);
11812     return FALSE;
11813   }
11814   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11815     if (fileified != NULL)
11816       PerlMem_free(fileified);
11817     if (vmsname != NULL)
11818       PerlMem_free(vmsname);
11819     return TRUE;
11820   }
11821   _ckvmssts(retsts);
11822
11823   if (fileified != NULL)
11824     PerlMem_free(fileified);
11825   if (vmsname != NULL)
11826     PerlMem_free(vmsname);
11827   return FALSE;  /* Should never get here */
11828
11829 }
11830
11831 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
11832 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11833  * subset of the applicable information.
11834  */
11835 bool
11836 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11837 {
11838   return cando_by_name_int
11839         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11840 }  /* end of cando() */
11841 /*}}}*/
11842
11843
11844 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11845 I32
11846 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11847 {
11848    return cando_by_name_int(bit, effective, fname, 0);
11849
11850 }  /* end of cando_by_name() */
11851 /*}}}*/
11852
11853
11854 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11855 int
11856 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11857 {
11858   if (!fstat(fd,(stat_t *) statbufp)) {
11859     char *cptr;
11860     char *vms_filename;
11861     vms_filename = PerlMem_malloc(VMS_MAXRSS);
11862     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11863
11864     /* Save name for cando by name in VMS format */
11865     cptr = getname(fd, vms_filename, 1);
11866
11867     /* This should not happen, but just in case */
11868     if (cptr == NULL) {
11869         statbufp->st_devnam[0] = 0;
11870     }
11871     else {
11872         /* Make sure that the saved name fits in 255 characters */
11873         cptr = do_rmsexpand
11874                        (vms_filename,
11875                         statbufp->st_devnam,
11876                         0,
11877                         NULL,
11878                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11879                         NULL,
11880                         NULL);
11881         if (cptr == NULL)
11882             statbufp->st_devnam[0] = 0;
11883     }
11884     PerlMem_free(vms_filename);
11885
11886     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11887     VMS_DEVICE_ENCODE
11888         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11889
11890 #   ifdef RTL_USES_UTC
11891 #   ifdef VMSISH_TIME
11892     if (VMSISH_TIME) {
11893       statbufp->st_mtime = _toloc(statbufp->st_mtime);
11894       statbufp->st_atime = _toloc(statbufp->st_atime);
11895       statbufp->st_ctime = _toloc(statbufp->st_ctime);
11896     }
11897 #   endif
11898 #   else
11899 #   ifdef VMSISH_TIME
11900     if (!VMSISH_TIME) { /* Return UTC instead of local time */
11901 #   else
11902     if (1) {
11903 #   endif
11904       statbufp->st_mtime = _toutc(statbufp->st_mtime);
11905       statbufp->st_atime = _toutc(statbufp->st_atime);
11906       statbufp->st_ctime = _toutc(statbufp->st_ctime);
11907     }
11908 #endif
11909     return 0;
11910   }
11911   return -1;
11912
11913 }  /* end of flex_fstat() */
11914 /*}}}*/
11915
11916 #if !defined(__VAX) && __CRTL_VER >= 80200000
11917 #ifdef lstat
11918 #undef lstat
11919 #endif
11920 #else
11921 #ifdef lstat
11922 #undef lstat
11923 #endif
11924 #define lstat(_x, _y) stat(_x, _y)
11925 #endif
11926
11927 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11928
11929 static int
11930 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11931 {
11932     char fileified[VMS_MAXRSS];
11933     char temp_fspec[VMS_MAXRSS];
11934     char *save_spec;
11935     int retval = -1;
11936     int saved_errno, saved_vaxc_errno;
11937
11938     if (!fspec) return retval;
11939     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11940     strcpy(temp_fspec, fspec);
11941
11942     if (decc_bug_devnull != 0) {
11943       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11944         memset(statbufp,0,sizeof *statbufp);
11945         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11946         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11947         statbufp->st_uid = 0x00010001;
11948         statbufp->st_gid = 0x0001;
11949         time((time_t *)&statbufp->st_mtime);
11950         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11951         return 0;
11952       }
11953     }
11954
11955     /* Try for a directory name first.  If fspec contains a filename without
11956      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11957      * and sea:[wine.dark]water. exist, we prefer the directory here.
11958      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11959      * not sea:[wine.dark]., if the latter exists.  If the intended target is
11960      * the file with null type, specify this by calling flex_stat() with
11961      * a '.' at the end of fspec.
11962      *
11963      * If we are in Posix filespec mode, accept the filename as is.
11964      */
11965
11966
11967 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11968   /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11969    * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11970    */
11971   if (!decc_efs_charset)
11972     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11973 #endif
11974
11975 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11976   if (decc_posix_compliant_pathnames == 0) {
11977 #endif
11978     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11979       if (lstat_flag == 0)
11980         retval = stat(fileified,(stat_t *) statbufp);
11981       else
11982         retval = lstat(fileified,(stat_t *) statbufp);
11983       save_spec = fileified;
11984     }
11985     if (retval) {
11986       if (lstat_flag == 0)
11987         retval = stat(temp_fspec,(stat_t *) statbufp);
11988       else
11989         retval = lstat(temp_fspec,(stat_t *) statbufp);
11990       save_spec = temp_fspec;
11991     }
11992 /*
11993  * In debugging, on 8.3 Alpha, I found a case where stat was returning a
11994  * file not found error for a directory named foo:[bar.t] or /foo/bar/t
11995  * and lstat was working correctly for the same file.
11996  * The only syntax that was working for stat was "foo:[bar]t.dir".
11997  *
11998  * Other directories with the same syntax worked fine.
11999  * So work around the problem when it shows up here.
12000  */
12001     if (retval) {
12002         int save_errno = errno;
12003         if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
12004             if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
12005                 retval = stat(fileified, (stat_t *) statbufp);
12006                 save_spec = fileified;
12007             }
12008         }
12009         /* Restore the errno value if third stat does not succeed */
12010         if (retval != 0)
12011             errno = save_errno;
12012     }
12013 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12014   } else {
12015     if (lstat_flag == 0)
12016       retval = stat(temp_fspec,(stat_t *) statbufp);
12017     else
12018       retval = lstat(temp_fspec,(stat_t *) statbufp);
12019       save_spec = temp_fspec;
12020   }
12021 #endif
12022
12023 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12024   /* As you were... */
12025   if (!decc_efs_charset)
12026     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12027 #endif
12028
12029     if (!retval) {
12030     char * cptr;
12031     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12032
12033       /* If this is an lstat, do not follow the link */
12034       if (lstat_flag)
12035         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12036
12037       cptr = do_rmsexpand
12038        (save_spec, statbufp->st_devnam, 0, NULL, rmsex_flags, NULL, NULL);
12039       if (cptr == NULL)
12040         statbufp->st_devnam[0] = 0;
12041
12042       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12043       VMS_DEVICE_ENCODE
12044         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12045 #     ifdef RTL_USES_UTC
12046 #     ifdef VMSISH_TIME
12047       if (VMSISH_TIME) {
12048         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12049         statbufp->st_atime = _toloc(statbufp->st_atime);
12050         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12051       }
12052 #     endif
12053 #     else
12054 #     ifdef VMSISH_TIME
12055       if (!VMSISH_TIME) { /* Return UTC instead of local time */
12056 #     else
12057       if (1) {
12058 #     endif
12059         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12060         statbufp->st_atime = _toutc(statbufp->st_atime);
12061         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12062       }
12063 #     endif
12064     }
12065     /* If we were successful, leave errno where we found it */
12066     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
12067     return retval;
12068
12069 }  /* end of flex_stat_int() */
12070
12071
12072 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12073 int
12074 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12075 {
12076    return flex_stat_int(fspec, statbufp, 0);
12077 }
12078 /*}}}*/
12079
12080 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12081 int
12082 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12083 {
12084    return flex_stat_int(fspec, statbufp, 1);
12085 }
12086 /*}}}*/
12087
12088
12089 /*{{{char *my_getlogin()*/
12090 /* VMS cuserid == Unix getlogin, except calling sequence */
12091 char *
12092 my_getlogin(void)
12093 {
12094     static char user[L_cuserid];
12095     return cuserid(user);
12096 }
12097 /*}}}*/
12098
12099
12100 /*  rmscopy - copy a file using VMS RMS routines
12101  *
12102  *  Copies contents and attributes of spec_in to spec_out, except owner
12103  *  and protection information.  Name and type of spec_in are used as
12104  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12105  *  should try to propagate timestamps from the input file to the output file.
12106  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12107  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12108  *  propagated to the output file at creation iff the output file specification
12109  *  did not contain an explicit name or type, and the revision date is always
12110  *  updated at the end of the copy operation.  If it is greater than 0, then
12111  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12112  *  other than the revision date should be propagated, and bit 1 indicates
12113  *  that the revision date should be propagated.
12114  *
12115  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12116  *
12117  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12118  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12119  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12120  * as part of the Perl standard distribution under the terms of the
12121  * GNU General Public License or the Perl Artistic License.  Copies
12122  * of each may be found in the Perl standard distribution.
12123  */ /* FIXME */
12124 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12125 int
12126 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12127 {
12128     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12129          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12130     unsigned long int i, sts, sts2;
12131     int dna_len;
12132     struct FAB fab_in, fab_out;
12133     struct RAB rab_in, rab_out;
12134     rms_setup_nam(nam);
12135     rms_setup_nam(nam_out);
12136     struct XABDAT xabdat;
12137     struct XABFHC xabfhc;
12138     struct XABRDT xabrdt;
12139     struct XABSUM xabsum;
12140
12141     vmsin = PerlMem_malloc(VMS_MAXRSS);
12142     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
12143     vmsout = PerlMem_malloc(VMS_MAXRSS);
12144     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
12145     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
12146         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
12147       PerlMem_free(vmsin);
12148       PerlMem_free(vmsout);
12149       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12150       return 0;
12151     }
12152
12153     esa = PerlMem_malloc(VMS_MAXRSS);
12154     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
12155     esal = NULL;
12156 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12157     esal = PerlMem_malloc(VMS_MAXRSS);
12158     if (esal == NULL) _ckvmssts(SS$_INSFMEM);
12159 #endif
12160     fab_in = cc$rms_fab;
12161     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12162     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12163     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12164     fab_in.fab$l_fop = FAB$M_SQO;
12165     rms_bind_fab_nam(fab_in, nam);
12166     fab_in.fab$l_xab = (void *) &xabdat;
12167
12168     rsa = PerlMem_malloc(VMS_MAXRSS);
12169     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
12170     rsal = NULL;
12171 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12172     rsal = PerlMem_malloc(VMS_MAXRSS);
12173     if (rsal == NULL) _ckvmssts(SS$_INSFMEM);
12174 #endif
12175     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12176     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12177     rms_nam_esl(nam) = 0;
12178     rms_nam_rsl(nam) = 0;
12179     rms_nam_esll(nam) = 0;
12180     rms_nam_rsll(nam) = 0;
12181 #ifdef NAM$M_NO_SHORT_UPCASE
12182     if (decc_efs_case_preserve)
12183         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12184 #endif
12185
12186     xabdat = cc$rms_xabdat;        /* To get creation date */
12187     xabdat.xab$l_nxt = (void *) &xabfhc;
12188
12189     xabfhc = cc$rms_xabfhc;        /* To get record length */
12190     xabfhc.xab$l_nxt = (void *) &xabsum;
12191
12192     xabsum = cc$rms_xabsum;        /* To get key and area information */
12193
12194     if (!((sts = sys$open(&fab_in)) & 1)) {
12195       PerlMem_free(vmsin);
12196       PerlMem_free(vmsout);
12197       PerlMem_free(esa);
12198       if (esal != NULL)
12199         PerlMem_free(esal);
12200       PerlMem_free(rsa);
12201       if (rsal != NULL)
12202         PerlMem_free(rsal);
12203       set_vaxc_errno(sts);
12204       switch (sts) {
12205         case RMS$_FNF: case RMS$_DNF:
12206           set_errno(ENOENT); break;
12207         case RMS$_DIR:
12208           set_errno(ENOTDIR); break;
12209         case RMS$_DEV:
12210           set_errno(ENODEV); break;
12211         case RMS$_SYN:
12212           set_errno(EINVAL); break;
12213         case RMS$_PRV:
12214           set_errno(EACCES); break;
12215         default:
12216           set_errno(EVMSERR);
12217       }
12218       return 0;
12219     }
12220
12221     nam_out = nam;
12222     fab_out = fab_in;
12223     fab_out.fab$w_ifi = 0;
12224     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12225     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12226     fab_out.fab$l_fop = FAB$M_SQO;
12227     rms_bind_fab_nam(fab_out, nam_out);
12228     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12229     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12230     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12231     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12232     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
12233     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12234     if (rsa_out == NULL) _ckvmssts(SS$_INSFMEM);
12235     esal_out = NULL;
12236     rsal_out = NULL;
12237 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12238     esal_out = PerlMem_malloc(VMS_MAXRSS);
12239     if (esal_out == NULL) _ckvmssts(SS$_INSFMEM);
12240     rsal_out = PerlMem_malloc(VMS_MAXRSS);
12241     if (rsal_out == NULL) _ckvmssts(SS$_INSFMEM);
12242 #endif
12243     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12244     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12245
12246     if (preserve_dates == 0) {  /* Act like DCL COPY */
12247       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12248       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12249       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12250         PerlMem_free(vmsin);
12251         PerlMem_free(vmsout);
12252         PerlMem_free(esa);
12253         if (esal != NULL)
12254             PerlMem_free(esal);
12255         PerlMem_free(rsa);
12256         if (rsal != NULL)
12257             PerlMem_free(rsal);
12258         PerlMem_free(esa_out);
12259         if (esal_out != NULL)
12260             PerlMem_free(esal_out);
12261         PerlMem_free(rsa_out);
12262         if (rsal_out != NULL)
12263             PerlMem_free(rsal_out);
12264         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12265         set_vaxc_errno(sts);
12266         return 0;
12267       }
12268       fab_out.fab$l_xab = (void *) &xabdat;
12269       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12270         preserve_dates = 1;
12271     }
12272     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12273       preserve_dates =0;      /* bitmask from this point forward   */
12274
12275     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12276     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12277       PerlMem_free(vmsin);
12278       PerlMem_free(vmsout);
12279       PerlMem_free(esa);
12280       if (esal != NULL)
12281           PerlMem_free(esal);
12282       PerlMem_free(rsa);
12283       if (rsal != NULL)
12284           PerlMem_free(rsal);
12285       PerlMem_free(esa_out);
12286       if (esal_out != NULL)
12287           PerlMem_free(esal_out);
12288       PerlMem_free(rsa_out);
12289       if (rsal_out != NULL)
12290           PerlMem_free(rsal_out);
12291       set_vaxc_errno(sts);
12292       switch (sts) {
12293         case RMS$_DNF:
12294           set_errno(ENOENT); break;
12295         case RMS$_DIR:
12296           set_errno(ENOTDIR); break;
12297         case RMS$_DEV:
12298           set_errno(ENODEV); break;
12299         case RMS$_SYN:
12300           set_errno(EINVAL); break;
12301         case RMS$_PRV:
12302           set_errno(EACCES); break;
12303         default:
12304           set_errno(EVMSERR);
12305       }
12306       return 0;
12307     }
12308     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12309     if (preserve_dates & 2) {
12310       /* sys$close() will process xabrdt, not xabdat */
12311       xabrdt = cc$rms_xabrdt;
12312 #ifndef __GNUC__
12313       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12314 #else
12315       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12316        * is unsigned long[2], while DECC & VAXC use a struct */
12317       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12318 #endif
12319       fab_out.fab$l_xab = (void *) &xabrdt;
12320     }
12321
12322     ubf = PerlMem_malloc(32256);
12323     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
12324     rab_in = cc$rms_rab;
12325     rab_in.rab$l_fab = &fab_in;
12326     rab_in.rab$l_rop = RAB$M_BIO;
12327     rab_in.rab$l_ubf = ubf;
12328     rab_in.rab$w_usz = 32256;
12329     if (!((sts = sys$connect(&rab_in)) & 1)) {
12330       sys$close(&fab_in); sys$close(&fab_out);
12331       PerlMem_free(vmsin);
12332       PerlMem_free(vmsout);
12333       PerlMem_free(ubf);
12334       PerlMem_free(esa);
12335       if (esal != NULL)
12336           PerlMem_free(esal);
12337       PerlMem_free(rsa);
12338       if (rsal != NULL)
12339           PerlMem_free(rsal);
12340       PerlMem_free(esa_out);
12341       if (esal_out != NULL)
12342           PerlMem_free(esal_out);
12343       PerlMem_free(rsa_out);
12344       if (rsal_out != NULL)
12345           PerlMem_free(rsal_out);
12346       set_errno(EVMSERR); set_vaxc_errno(sts);
12347       return 0;
12348     }
12349
12350     rab_out = cc$rms_rab;
12351     rab_out.rab$l_fab = &fab_out;
12352     rab_out.rab$l_rbf = ubf;
12353     if (!((sts = sys$connect(&rab_out)) & 1)) {
12354       sys$close(&fab_in); sys$close(&fab_out);
12355       PerlMem_free(vmsin);
12356       PerlMem_free(vmsout);
12357       PerlMem_free(ubf);
12358       PerlMem_free(esa);
12359       if (esal != NULL)
12360           PerlMem_free(esal);
12361       PerlMem_free(rsa);
12362       if (rsal != NULL)
12363           PerlMem_free(rsal);
12364       PerlMem_free(esa_out);
12365       if (esal_out != NULL)
12366           PerlMem_free(esal_out);
12367       PerlMem_free(rsa_out);
12368       if (rsal_out != NULL)
12369           PerlMem_free(rsal_out);
12370       set_errno(EVMSERR); set_vaxc_errno(sts);
12371       return 0;
12372     }
12373
12374     while ((sts = sys$read(&rab_in))) {  /* always true  */
12375       if (sts == RMS$_EOF) break;
12376       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12377       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12378         sys$close(&fab_in); sys$close(&fab_out);
12379         PerlMem_free(vmsin);
12380         PerlMem_free(vmsout);
12381         PerlMem_free(ubf);
12382         PerlMem_free(esa);
12383         if (esal != NULL)
12384             PerlMem_free(esal);
12385         PerlMem_free(rsa);
12386         if (rsal != NULL)
12387             PerlMem_free(rsal);
12388         PerlMem_free(esa_out);
12389         if (esal_out != NULL)
12390             PerlMem_free(esal_out);
12391         PerlMem_free(rsa_out);
12392         if (rsal_out != NULL)
12393             PerlMem_free(rsal_out);
12394         set_errno(EVMSERR); set_vaxc_errno(sts);
12395         return 0;
12396       }
12397     }
12398
12399
12400     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12401     sys$close(&fab_in);  sys$close(&fab_out);
12402     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12403
12404     PerlMem_free(vmsin);
12405     PerlMem_free(vmsout);
12406     PerlMem_free(ubf);
12407     PerlMem_free(esa);
12408     if (esal != NULL)
12409         PerlMem_free(esal);
12410     PerlMem_free(rsa);
12411     if (rsal != NULL)
12412         PerlMem_free(rsal);
12413     PerlMem_free(esa_out);
12414     if (esal_out != NULL)
12415         PerlMem_free(esal_out);
12416     PerlMem_free(rsa_out);
12417     if (rsal_out != NULL)
12418         PerlMem_free(rsal_out);
12419
12420     if (!(sts & 1)) {
12421       set_errno(EVMSERR); set_vaxc_errno(sts);
12422       return 0;
12423     }
12424
12425     return 1;
12426
12427 }  /* end of rmscopy() */
12428 /*}}}*/
12429
12430
12431 /***  The following glue provides 'hooks' to make some of the routines
12432  * from this file available from Perl.  These routines are sufficiently
12433  * basic, and are required sufficiently early in the build process,
12434  * that's it's nice to have them available to miniperl as well as the
12435  * full Perl, so they're set up here instead of in an extension.  The
12436  * Perl code which handles importation of these names into a given
12437  * package lives in [.VMS]Filespec.pm in @INC.
12438  */
12439
12440 void
12441 rmsexpand_fromperl(pTHX_ CV *cv)
12442 {
12443   dXSARGS;
12444   char *fspec, *defspec = NULL, *rslt;
12445   STRLEN n_a;
12446   int fs_utf8, dfs_utf8;
12447
12448   fs_utf8 = 0;
12449   dfs_utf8 = 0;
12450   if (!items || items > 2)
12451     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12452   fspec = SvPV(ST(0),n_a);
12453   fs_utf8 = SvUTF8(ST(0));
12454   if (!fspec || !*fspec) XSRETURN_UNDEF;
12455   if (items == 2) {
12456     defspec = SvPV(ST(1),n_a);
12457     dfs_utf8 = SvUTF8(ST(1));
12458   }
12459   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12460   ST(0) = sv_newmortal();
12461   if (rslt != NULL) {
12462     sv_usepvn(ST(0),rslt,strlen(rslt));
12463     if (fs_utf8) {
12464         SvUTF8_on(ST(0));
12465     }
12466   }
12467   XSRETURN(1);
12468 }
12469
12470 void
12471 vmsify_fromperl(pTHX_ CV *cv)
12472 {
12473   dXSARGS;
12474   char *vmsified;
12475   STRLEN n_a;
12476   int utf8_fl;
12477
12478   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12479   utf8_fl = SvUTF8(ST(0));
12480   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12481   ST(0) = sv_newmortal();
12482   if (vmsified != NULL) {
12483     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12484     if (utf8_fl) {
12485         SvUTF8_on(ST(0));
12486     }
12487   }
12488   XSRETURN(1);
12489 }
12490
12491 void
12492 unixify_fromperl(pTHX_ CV *cv)
12493 {
12494   dXSARGS;
12495   char *unixified;
12496   STRLEN n_a;
12497   int utf8_fl;
12498
12499   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12500   utf8_fl = SvUTF8(ST(0));
12501   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12502   ST(0) = sv_newmortal();
12503   if (unixified != NULL) {
12504     sv_usepvn(ST(0),unixified,strlen(unixified));
12505     if (utf8_fl) {
12506         SvUTF8_on(ST(0));
12507     }
12508   }
12509   XSRETURN(1);
12510 }
12511
12512 void
12513 fileify_fromperl(pTHX_ CV *cv)
12514 {
12515   dXSARGS;
12516   char *fileified;
12517   STRLEN n_a;
12518   int utf8_fl;
12519
12520   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12521   utf8_fl = SvUTF8(ST(0));
12522   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12523   ST(0) = sv_newmortal();
12524   if (fileified != NULL) {
12525     sv_usepvn(ST(0),fileified,strlen(fileified));
12526     if (utf8_fl) {
12527         SvUTF8_on(ST(0));
12528     }
12529   }
12530   XSRETURN(1);
12531 }
12532
12533 void
12534 pathify_fromperl(pTHX_ CV *cv)
12535 {
12536   dXSARGS;
12537   char *pathified;
12538   STRLEN n_a;
12539   int utf8_fl;
12540
12541   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12542   utf8_fl = SvUTF8(ST(0));
12543   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12544   ST(0) = sv_newmortal();
12545   if (pathified != NULL) {
12546     sv_usepvn(ST(0),pathified,strlen(pathified));
12547     if (utf8_fl) {
12548         SvUTF8_on(ST(0));
12549     }
12550   }
12551   XSRETURN(1);
12552 }
12553
12554 void
12555 vmspath_fromperl(pTHX_ CV *cv)
12556 {
12557   dXSARGS;
12558   char *vmspath;
12559   STRLEN n_a;
12560   int utf8_fl;
12561
12562   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12563   utf8_fl = SvUTF8(ST(0));
12564   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12565   ST(0) = sv_newmortal();
12566   if (vmspath != NULL) {
12567     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12568     if (utf8_fl) {
12569         SvUTF8_on(ST(0));
12570     }
12571   }
12572   XSRETURN(1);
12573 }
12574
12575 void
12576 unixpath_fromperl(pTHX_ CV *cv)
12577 {
12578   dXSARGS;
12579   char *unixpath;
12580   STRLEN n_a;
12581   int utf8_fl;
12582
12583   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12584   utf8_fl = SvUTF8(ST(0));
12585   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12586   ST(0) = sv_newmortal();
12587   if (unixpath != NULL) {
12588     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12589     if (utf8_fl) {
12590         SvUTF8_on(ST(0));
12591     }
12592   }
12593   XSRETURN(1);
12594 }
12595
12596 void
12597 candelete_fromperl(pTHX_ CV *cv)
12598 {
12599   dXSARGS;
12600   char *fspec, *fsp;
12601   SV *mysv;
12602   IO *io;
12603   STRLEN n_a;
12604
12605   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12606
12607   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12608   Newx(fspec, VMS_MAXRSS, char);
12609   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12610   if (SvTYPE(mysv) == SVt_PVGV) {
12611     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12612       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12613       ST(0) = &PL_sv_no;
12614       Safefree(fspec);
12615       XSRETURN(1);
12616     }
12617     fsp = fspec;
12618   }
12619   else {
12620     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12621       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12622       ST(0) = &PL_sv_no;
12623       Safefree(fspec);
12624       XSRETURN(1);
12625     }
12626   }
12627
12628   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12629   Safefree(fspec);
12630   XSRETURN(1);
12631 }
12632
12633 void
12634 rmscopy_fromperl(pTHX_ CV *cv)
12635 {
12636   dXSARGS;
12637   char *inspec, *outspec, *inp, *outp;
12638   int date_flag;
12639   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
12640                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12641   unsigned long int sts;
12642   SV *mysv;
12643   IO *io;
12644   STRLEN n_a;
12645
12646   if (items < 2 || items > 3)
12647     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12648
12649   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12650   Newx(inspec, VMS_MAXRSS, char);
12651   if (SvTYPE(mysv) == SVt_PVGV) {
12652     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12653       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12654       ST(0) = &PL_sv_no;
12655       Safefree(inspec);
12656       XSRETURN(1);
12657     }
12658     inp = inspec;
12659   }
12660   else {
12661     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12662       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12663       ST(0) = &PL_sv_no;
12664       Safefree(inspec);
12665       XSRETURN(1);
12666     }
12667   }
12668   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12669   Newx(outspec, VMS_MAXRSS, char);
12670   if (SvTYPE(mysv) == SVt_PVGV) {
12671     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12672       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12673       ST(0) = &PL_sv_no;
12674       Safefree(inspec);
12675       Safefree(outspec);
12676       XSRETURN(1);
12677     }
12678     outp = outspec;
12679   }
12680   else {
12681     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12682       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12683       ST(0) = &PL_sv_no;
12684       Safefree(inspec);
12685       Safefree(outspec);
12686       XSRETURN(1);
12687     }
12688   }
12689   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12690
12691   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
12692   Safefree(inspec);
12693   Safefree(outspec);
12694   XSRETURN(1);
12695 }
12696
12697 /* The mod2fname is limited to shorter filenames by design, so it should
12698  * not be modified to support longer EFS pathnames
12699  */
12700 void
12701 mod2fname(pTHX_ CV *cv)
12702 {
12703   dXSARGS;
12704   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12705        workbuff[NAM$C_MAXRSS*1 + 1];
12706   int total_namelen = 3, counter, num_entries;
12707   /* ODS-5 ups this, but we want to be consistent, so... */
12708   int max_name_len = 39;
12709   AV *in_array = (AV *)SvRV(ST(0));
12710
12711   num_entries = av_len(in_array);
12712
12713   /* All the names start with PL_. */
12714   strcpy(ultimate_name, "PL_");
12715
12716   /* Clean up our working buffer */
12717   Zero(work_name, sizeof(work_name), char);
12718
12719   /* Run through the entries and build up a working name */
12720   for(counter = 0; counter <= num_entries; counter++) {
12721     /* If it's not the first name then tack on a __ */
12722     if (counter) {
12723       strcat(work_name, "__");
12724     }
12725     strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
12726   }
12727
12728   /* Check to see if we actually have to bother...*/
12729   if (strlen(work_name) + 3 <= max_name_len) {
12730     strcat(ultimate_name, work_name);
12731   } else {
12732     /* It's too darned big, so we need to go strip. We use the same */
12733     /* algorithm as xsubpp does. First, strip out doubled __ */
12734     char *source, *dest, last;
12735     dest = workbuff;
12736     last = 0;
12737     for (source = work_name; *source; source++) {
12738       if (last == *source && last == '_') {
12739         continue;
12740       }
12741       *dest++ = *source;
12742       last = *source;
12743     }
12744     /* Go put it back */
12745     strcpy(work_name, workbuff);
12746     /* Is it still too big? */
12747     if (strlen(work_name) + 3 > max_name_len) {
12748       /* Strip duplicate letters */
12749       last = 0;
12750       dest = workbuff;
12751       for (source = work_name; *source; source++) {
12752         if (last == toupper(*source)) {
12753         continue;
12754         }
12755         *dest++ = *source;
12756         last = toupper(*source);
12757       }
12758       strcpy(work_name, workbuff);
12759     }
12760
12761     /* Is it *still* too big? */
12762     if (strlen(work_name) + 3 > max_name_len) {
12763       /* Too bad, we truncate */
12764       work_name[max_name_len - 2] = 0;
12765     }
12766     strcat(ultimate_name, work_name);
12767   }
12768
12769   /* Okay, return it */
12770   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12771   XSRETURN(1);
12772 }
12773
12774 void
12775 hushexit_fromperl(pTHX_ CV *cv)
12776 {
12777     dXSARGS;
12778
12779     if (items > 0) {
12780         VMSISH_HUSHED = SvTRUE(ST(0));
12781     }
12782     ST(0) = boolSV(VMSISH_HUSHED);
12783     XSRETURN(1);
12784 }
12785
12786
12787 PerlIO *
12788 Perl_vms_start_glob
12789    (pTHX_ SV *tmpglob,
12790     IO *io)
12791 {
12792     PerlIO *fp;
12793     struct vs_str_st *rslt;
12794     char *vmsspec;
12795     char *rstr;
12796     char *begin, *cp;
12797     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12798     PerlIO *tmpfp;
12799     STRLEN i;
12800     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12801     struct dsc$descriptor_vs rsdsc;
12802     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12803     unsigned long hasver = 0, isunix = 0;
12804     unsigned long int lff_flags = 0;
12805     int rms_sts;
12806
12807     if (!SvOK(tmpglob)) {
12808         SETERRNO(ENOENT,RMS$_FNF);
12809         return NULL;
12810     }
12811
12812 #ifdef VMS_LONGNAME_SUPPORT
12813     lff_flags = LIB$M_FIL_LONG_NAMES;
12814 #endif
12815     /* The Newx macro will not allow me to assign a smaller array
12816      * to the rslt pointer, so we will assign it to the begin char pointer
12817      * and then copy the value into the rslt pointer.
12818      */
12819     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12820     rslt = (struct vs_str_st *)begin;
12821     rslt->length = 0;
12822     rstr = &rslt->str[0];
12823     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12824     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12825     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12826     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12827
12828     Newx(vmsspec, VMS_MAXRSS, char);
12829
12830         /* We could find out if there's an explicit dev/dir or version
12831            by peeking into lib$find_file's internal context at
12832            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12833            but that's unsupported, so I don't want to do it now and
12834            have it bite someone in the future. */
12835         /* Fix-me: vms_split_path() is the only way to do this, the
12836            existing method will fail with many legal EFS or UNIX specifications
12837          */
12838
12839     cp = SvPV(tmpglob,i);
12840
12841     for (; i; i--) {
12842         if (cp[i] == ';') hasver = 1;
12843         if (cp[i] == '.') {
12844             if (sts) hasver = 1;
12845             else sts = 1;
12846         }
12847         if (cp[i] == '/') {
12848             hasdir = isunix = 1;
12849             break;
12850         }
12851         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12852             hasdir = 1;
12853             break;
12854         }
12855     }
12856     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12857         int found = 0;
12858         Stat_t st;
12859         int stat_sts;
12860         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12861         if (!stat_sts && S_ISDIR(st.st_mode)) {
12862             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12863             ok = (wilddsc.dsc$a_pointer != NULL);
12864             /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12865             hasdir = 1;
12866         }
12867         else {
12868             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12869             ok = (wilddsc.dsc$a_pointer != NULL);
12870         }
12871         if (ok)
12872             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12873
12874         /* If not extended character set, replace ? with % */
12875         /* With extended character set, ? is a wildcard single character */
12876         if (!decc_efs_case_preserve) {
12877             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12878                 if (*cp == '?') *cp = '%';
12879         }
12880         sts = SS$_NORMAL;
12881         while (ok && $VMS_STATUS_SUCCESS(sts)) {
12882          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12883          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12884
12885             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12886                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
12887             if (!$VMS_STATUS_SUCCESS(sts))
12888                 break;
12889
12890             found++;
12891
12892             /* with varying string, 1st word of buffer contains result length */
12893             rstr[rslt->length] = '\0';
12894
12895              /* Find where all the components are */
12896              v_sts = vms_split_path
12897                        (rstr,
12898                         &v_spec,
12899                         &v_len,
12900                         &r_spec,
12901                         &r_len,
12902                         &d_spec,
12903                         &d_len,
12904                         &n_spec,
12905                         &n_len,
12906                         &e_spec,
12907                         &e_len,
12908                         &vs_spec,
12909                         &vs_len);
12910
12911             /* If no version on input, truncate the version on output */
12912             if (!hasver && (vs_len > 0)) {
12913                 *vs_spec = '\0';
12914                 vs_len = 0;
12915
12916                 /* No version & a null extension on UNIX handling */
12917                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12918                     e_len = 0;
12919                     *e_spec = '\0';
12920                 }
12921             }
12922
12923             if (!decc_efs_case_preserve) {
12924                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12925             }
12926
12927             if (hasdir) {
12928                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12929                 begin = rstr;
12930             }
12931             else {
12932                 /* Start with the name */
12933                 begin = n_spec;
12934             }
12935             strcat(begin,"\n");
12936             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12937         }
12938         if (cxt) (void)lib$find_file_end(&cxt);
12939
12940         if (!found) {
12941             /* Be POSIXish: return the input pattern when no matches */
12942             strcpy(rstr,SvPVX(tmpglob));
12943             strcat(rstr,"\n");
12944             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
12945         }
12946
12947         if (ok && sts != RMS$_NMF &&
12948             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12949         if (!ok) {
12950             if (!(sts & 1)) {
12951                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12952             }
12953             PerlIO_close(tmpfp);
12954             fp = NULL;
12955         }
12956         else {
12957             PerlIO_rewind(tmpfp);
12958             IoTYPE(io) = IoTYPE_RDONLY;
12959             IoIFP(io) = fp = tmpfp;
12960             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
12961         }
12962     }
12963     Safefree(vmsspec);
12964     Safefree(rslt);
12965     return fp;
12966 }
12967
12968
12969 static char *
12970 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
12971                    int *utf8_fl);
12972
12973 void
12974 unixrealpath_fromperl(pTHX_ CV *cv)
12975 {
12976     dXSARGS;
12977     char *fspec, *rslt_spec, *rslt;
12978     STRLEN n_a;
12979
12980     if (!items || items != 1)
12981         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
12982
12983     fspec = SvPV(ST(0),n_a);
12984     if (!fspec || !*fspec) XSRETURN_UNDEF;
12985
12986     Newx(rslt_spec, VMS_MAXRSS + 1, char);
12987     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12988
12989     ST(0) = sv_newmortal();
12990     if (rslt != NULL)
12991         sv_usepvn(ST(0),rslt,strlen(rslt));
12992     else
12993         Safefree(rslt_spec);
12994         XSRETURN(1);
12995 }
12996
12997 static char *
12998 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
12999                    int *utf8_fl);
13000
13001 void
13002 vmsrealpath_fromperl(pTHX_ CV *cv)
13003 {
13004     dXSARGS;
13005     char *fspec, *rslt_spec, *rslt;
13006     STRLEN n_a;
13007
13008     if (!items || items != 1)
13009         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13010
13011     fspec = SvPV(ST(0),n_a);
13012     if (!fspec || !*fspec) XSRETURN_UNDEF;
13013
13014     Newx(rslt_spec, VMS_MAXRSS + 1, char);
13015     rslt = do_vms_realname(fspec, rslt_spec, NULL);
13016
13017     ST(0) = sv_newmortal();
13018     if (rslt != NULL)
13019         sv_usepvn(ST(0),rslt,strlen(rslt));
13020     else
13021         Safefree(rslt_spec);
13022         XSRETURN(1);
13023 }
13024
13025 #ifdef HAS_SYMLINK
13026 /*
13027  * A thin wrapper around decc$symlink to make sure we follow the
13028  * standard and do not create a symlink with a zero-length name.
13029  *
13030  * Also in ODS-2 mode, existing tests assume that the link target
13031  * will be converted to UNIX format.
13032  */
13033 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13034 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
13035   if (!link_name || !*link_name) {
13036     SETERRNO(ENOENT, SS$_NOSUCHFILE);
13037     return -1;
13038   }
13039
13040   if (decc_efs_charset) {
13041       return symlink(contents, link_name);
13042   } else {
13043       int sts;
13044       char * utarget;
13045
13046       /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
13047       /* because in order to work, the symlink target must be in UNIX format */
13048
13049       /* As symbolic links can hold things other than files, we will only do */
13050       /* the conversion in in ODS-2 mode */
13051
13052       Newx(utarget, VMS_MAXRSS + 1, char);
13053       if (do_tounixspec(contents, utarget, 0, NULL) == NULL) {
13054
13055           /* This should not fail, as an untranslatable filename */
13056           /* should be passed through */
13057           utarget = (char *)contents;
13058       }
13059       sts = symlink(utarget, link_name);
13060       Safefree(utarget);
13061       return sts;
13062   }
13063
13064 }
13065 /*}}}*/
13066
13067 #endif /* HAS_SYMLINK */
13068
13069 int do_vms_case_tolerant(void);
13070
13071 void
13072 case_tolerant_process_fromperl(pTHX_ CV *cv)
13073 {
13074   dXSARGS;
13075   ST(0) = boolSV(do_vms_case_tolerant());
13076   XSRETURN(1);
13077 }
13078
13079 #ifdef USE_ITHREADS
13080
13081 void
13082 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13083                           struct interp_intern *dst)
13084 {
13085     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13086
13087     memcpy(dst,src,sizeof(struct interp_intern));
13088 }
13089
13090 #endif
13091
13092 void
13093 Perl_sys_intern_clear(pTHX)
13094 {
13095 }
13096
13097 void
13098 Perl_sys_intern_init(pTHX)
13099 {
13100     unsigned int ix = RAND_MAX;
13101     double x;
13102
13103     VMSISH_HUSHED = 0;
13104
13105     MY_POSIX_EXIT = vms_posix_exit;
13106
13107     x = (float)ix;
13108     MY_INV_RAND_MAX = 1./x;
13109 }
13110
13111 void
13112 init_os_extras(void)
13113 {
13114   dTHX;
13115   char* file = __FILE__;
13116   if (decc_disable_to_vms_logname_translation) {
13117     no_translate_barewords = TRUE;
13118   } else {
13119     no_translate_barewords = FALSE;
13120   }
13121
13122   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13123   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13124   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13125   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13126   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13127   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13128   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13129   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13130   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13131   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13132   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13133   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13134   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13135   newXSproto("VMS::Filespec::case_tolerant_process",
13136       case_tolerant_process_fromperl,file,"");
13137
13138   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13139
13140   return;
13141 }
13142
13143 #if __CRTL_VER == 80200000
13144 /* This missed getting in to the DECC SDK for 8.2 */
13145 char *realpath(const char *file_name, char * resolved_name, ...);
13146 #endif
13147
13148 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13149 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13150  * The perl fallback routine to provide realpath() is not as efficient
13151  * on OpenVMS.
13152  */
13153
13154 /* Hack, use old stat() as fastest way of getting ino_t and device */
13155 int decc$stat(const char *name, void * statbuf);
13156
13157
13158 /* Realpath is fragile.  In 8.3 it does not work if the feature
13159  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13160  * links are implemented in RMS, not the CRTL. It also can fail if the
13161  * user does not have read/execute access to some of the directories.
13162  * So in order for Do What I Mean mode to work, if realpath() fails,
13163  * fall back to looking up the filename by the device name and FID.
13164  */
13165
13166 int vms_fid_to_name(char * outname, int outlen, const char * name)
13167 {
13168 struct statbuf_t {
13169     char           * st_dev;
13170     unsigned short st_ino[3];
13171     unsigned short padw;
13172     unsigned long  padl[30];  /* plenty of room */
13173 } statbuf;
13174 int sts;
13175 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13176 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13177
13178     sts = decc$stat(name, &statbuf);
13179     if (sts == 0) {
13180
13181         dvidsc.dsc$a_pointer=statbuf.st_dev;
13182        dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13183
13184         specdsc.dsc$a_pointer = outname;
13185         specdsc.dsc$w_length = outlen-1;
13186
13187        sts = lib$fid_to_name
13188             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13189        if ($VMS_STATUS_SUCCESS(sts)) {
13190             outname[specdsc.dsc$w_length] = 0;
13191             return 0;
13192         }
13193     }
13194     return sts;
13195 }
13196
13197
13198
13199 static char *
13200 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13201                    int *utf8_fl)
13202 {
13203     char * rslt = NULL;
13204
13205 #ifdef HAS_SYMLINK
13206     if (decc_posix_compliant_pathnames > 0 ) {
13207         /* realpath currently only works if posix compliant pathnames are
13208          * enabled.  It may start working when they are not, but in that
13209          * case we still want the fallback behavior for backwards compatibility
13210          */
13211         rslt = realpath(filespec, outbuf);
13212     }
13213 #endif
13214
13215     if (rslt == NULL) {
13216         char * vms_spec;
13217         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13218         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13219         int file_len;
13220
13221         /* Fall back to fid_to_name */
13222
13223         Newx(vms_spec, VMS_MAXRSS + 1, char);
13224
13225         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
13226         if (sts == 0) {
13227
13228
13229             /* Now need to trim the version off */
13230             sts = vms_split_path
13231                   (vms_spec,
13232                    &v_spec,
13233                    &v_len,
13234                    &r_spec,
13235                    &r_len,
13236                    &d_spec,
13237                    &d_len,
13238                    &n_spec,
13239                    &n_len,
13240                    &e_spec,
13241                    &e_len,
13242                    &vs_spec,
13243                    &vs_len);
13244
13245
13246                 if (sts == 0) {
13247                     int haslower = 0;
13248                     const char *cp;
13249
13250                     /* Trim off the version */
13251                     int file_len = v_len + r_len + d_len + n_len + e_len;
13252                     vms_spec[file_len] = 0;
13253
13254                     /* The result is expected to be in UNIX format */
13255                     rslt = do_tounixspec(vms_spec, outbuf, 0, utf8_fl);
13256
13257                     /* Downcase if input had any lower case letters and
13258                      * case preservation is not in effect.
13259                      */
13260                     if (!decc_efs_case_preserve) {
13261                         for (cp = filespec; *cp; cp++)
13262                             if (islower(*cp)) { haslower = 1; break; }
13263
13264                         if (haslower) __mystrtolower(rslt);
13265                     }
13266                 }
13267         } else {
13268
13269             /* Now for some hacks to deal with backwards and forward */
13270             /* compatibilty */
13271             if (!decc_efs_charset) {
13272
13273                 /* 1. ODS-2 mode wants to do a syntax only translation */
13274                 rslt = do_rmsexpand(filespec, outbuf,
13275                                     0, NULL, 0, NULL, utf8_fl);
13276
13277             } else {
13278                 if (decc_filename_unix_report) {
13279                     char * dir_name;
13280                     char * vms_dir_name;
13281                     char * file_name;
13282
13283                     /* 2. ODS-5 / UNIX report mode should return a failure */
13284                     /*    if the parent directory also does not exist */
13285                     /*    Otherwise, get the real path for the parent */
13286                     /*    and add the child to it.
13287
13288                     /* basename / dirname only available for VMS 7.0+ */
13289                     /* So we may need to implement them as common routines */
13290
13291                     Newx(dir_name, VMS_MAXRSS + 1, char);
13292                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13293                     dir_name[0] = '\0';
13294                     file_name = NULL;
13295
13296                     /* First try a VMS parse */
13297                     sts = vms_split_path
13298                           (filespec,
13299                            &v_spec,
13300                            &v_len,
13301                            &r_spec,
13302                            &r_len,
13303                            &d_spec,
13304                            &d_len,
13305                            &n_spec,
13306                            &n_len,
13307                            &e_spec,
13308                            &e_len,
13309                            &vs_spec,
13310                            &vs_len);
13311
13312                     if (sts == 0) {
13313                         /* This is VMS */
13314
13315                         int dir_len = v_len + r_len + d_len + n_len;
13316                         if (dir_len > 0) {
13317                            strncpy(dir_name, filespec, dir_len);
13318                            dir_name[dir_len] = '\0';
13319                            file_name = (char *)&filespec[dir_len + 1];
13320                         }
13321                     } else {
13322                         /* This must be UNIX */
13323                         char * tchar;
13324
13325                         tchar = strrchr(filespec, '/');
13326
13327                         if (tchar != NULL) {
13328                             int dir_len = tchar - filespec;
13329                             strncpy(dir_name, filespec, dir_len);
13330                             dir_name[dir_len] = '\0';
13331                             file_name = (char *) &filespec[dir_len + 1];
13332                         }
13333                     }
13334
13335                     /* Dir name is defaulted */
13336                     if (dir_name[0] == 0) {
13337                         dir_name[0] = '.';
13338                         dir_name[1] = '\0';
13339                     }
13340
13341                     /* Need realpath for the directory */
13342                     sts = vms_fid_to_name(vms_dir_name,
13343                                           VMS_MAXRSS + 1,
13344                                           dir_name);
13345
13346                     if (sts == 0) {
13347                         /* Now need to pathify it.
13348                         char *tdir = do_pathify_dirspec(vms_dir_name,
13349                                                         outbuf, utf8_fl);
13350
13351                         /* And now add the original filespec to it */
13352                         if (file_name != NULL) {
13353                             strcat(outbuf, file_name);
13354                         }
13355                         return outbuf;
13356                     }
13357                     Safefree(vms_dir_name);
13358                     Safefree(dir_name);
13359                 }
13360             }
13361         }
13362         Safefree(vms_spec);
13363     }
13364     return rslt;
13365 }
13366
13367 static char *
13368 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13369                    int *utf8_fl)
13370 {
13371     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13372     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13373     int file_len;
13374
13375     /* Fall back to fid_to_name */
13376
13377     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
13378     if (sts != 0) {
13379         return NULL;
13380     }
13381     else {
13382
13383
13384         /* Now need to trim the version off */
13385         sts = vms_split_path
13386                   (outbuf,
13387                    &v_spec,
13388                    &v_len,
13389                    &r_spec,
13390                    &r_len,
13391                    &d_spec,
13392                    &d_len,
13393                    &n_spec,
13394                    &n_len,
13395                    &e_spec,
13396                    &e_len,
13397                    &vs_spec,
13398                    &vs_len);
13399
13400
13401         if (sts == 0) {
13402             int haslower = 0;
13403             const char *cp;
13404
13405             /* Trim off the version */
13406             int file_len = v_len + r_len + d_len + n_len + e_len;
13407             outbuf[file_len] = 0;
13408
13409             /* Downcase if input had any lower case letters and
13410              * case preservation is not in effect.
13411              */
13412             if (!decc_efs_case_preserve) {
13413                 for (cp = filespec; *cp; cp++)
13414                     if (islower(*cp)) { haslower = 1; break; }
13415
13416                 if (haslower) __mystrtolower(outbuf);
13417             }
13418         }
13419     }
13420     return outbuf;
13421 }
13422
13423
13424 /*}}}*/
13425 /* External entry points */
13426 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13427 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13428
13429 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13430 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13431
13432 /* case_tolerant */
13433
13434 /*{{{int do_vms_case_tolerant(void)*/
13435 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13436  * controlled by a process setting.
13437  */
13438 int do_vms_case_tolerant(void)
13439 {
13440     return vms_process_case_tolerant;
13441 }
13442 /*}}}*/
13443 /* External entry points */
13444 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13445 int Perl_vms_case_tolerant(void)
13446 { return do_vms_case_tolerant(); }
13447 #else
13448 int Perl_vms_case_tolerant(void)
13449 { return vms_process_case_tolerant; }
13450 #endif
13451
13452
13453  /* Start of DECC RTL Feature handling */
13454
13455 static int sys_trnlnm
13456    (const char * logname,
13457     char * value,
13458     int value_len)
13459 {
13460     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
13461     const unsigned long attr = LNM$M_CASE_BLIND;
13462     struct dsc$descriptor_s name_dsc;
13463     int status;
13464     unsigned short result;
13465     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
13466                                 {0, 0, 0, 0}};
13467
13468     name_dsc.dsc$w_length = strlen(logname);
13469     name_dsc.dsc$a_pointer = (char *)logname;
13470     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13471     name_dsc.dsc$b_class = DSC$K_CLASS_S;
13472
13473     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
13474
13475     if ($VMS_STATUS_SUCCESS(status)) {
13476
13477          /* Null terminate and return the string */
13478         /*--------------------------------------*/
13479         value[result] = 0;
13480     }
13481
13482     return status;
13483 }
13484
13485 static int sys_crelnm
13486    (const char * logname,
13487     const char * value)
13488 {
13489     int ret_val;
13490     const char * proc_table = "LNM$PROCESS_TABLE";
13491     struct dsc$descriptor_s proc_table_dsc;
13492     struct dsc$descriptor_s logname_dsc;
13493     struct itmlst_3 item_list[2];
13494
13495     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
13496     proc_table_dsc.dsc$w_length = strlen(proc_table);
13497     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13498     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
13499
13500     logname_dsc.dsc$a_pointer = (char *) logname;
13501     logname_dsc.dsc$w_length = strlen(logname);
13502     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13503     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
13504
13505     item_list[0].buflen = strlen(value);
13506     item_list[0].itmcode = LNM$_STRING;
13507     item_list[0].bufadr = (char *)value;
13508     item_list[0].retlen = NULL;
13509
13510     item_list[1].buflen = 0;
13511     item_list[1].itmcode = 0;
13512
13513     ret_val = sys$crelnm
13514                        (NULL,
13515                         (const struct dsc$descriptor_s *)&proc_table_dsc,
13516                         (const struct dsc$descriptor_s *)&logname_dsc,
13517                         NULL,
13518                         (const struct item_list_3 *) item_list);
13519
13520     return ret_val;
13521 }
13522
13523 /* C RTL Feature settings */
13524
13525 static int set_features
13526    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
13527     int (* cli_routine)(void),  /* Not documented */
13528     void *image_info)           /* Not documented */
13529 {
13530     int status;
13531     int s;
13532     int dflt;
13533     char* str;
13534     char val_str[10];
13535 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13536     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13537     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13538     unsigned long case_perm;
13539     unsigned long case_image;
13540 #endif
13541
13542     /* Allow an exception to bring Perl into the VMS debugger */
13543     vms_debug_on_exception = 0;
13544     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13545     if ($VMS_STATUS_SUCCESS(status)) {
13546        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13547          vms_debug_on_exception = 1;
13548        else
13549          vms_debug_on_exception = 0;
13550     }
13551
13552     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13553     vms_vtf7_filenames = 0;
13554     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13555     if ($VMS_STATUS_SUCCESS(status)) {
13556        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13557          vms_vtf7_filenames = 1;
13558        else
13559          vms_vtf7_filenames = 0;
13560     }
13561
13562
13563     /* unlink all versions on unlink() or rename() */
13564     vms_unlink_all_versions = 0;
13565     status = sys_trnlnm
13566         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13567     if ($VMS_STATUS_SUCCESS(status)) {
13568        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13569          vms_unlink_all_versions = 1;
13570        else
13571          vms_unlink_all_versions = 0;
13572     }
13573
13574     /* Dectect running under GNV Bash or other UNIX like shell */
13575 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13576     gnv_unix_shell = 0;
13577     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13578     if ($VMS_STATUS_SUCCESS(status)) {
13579          gnv_unix_shell = 1;
13580          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13581          set_feature_default("DECC$EFS_CHARSET", 1);
13582          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13583          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13584          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13585          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13586          vms_unlink_all_versions = 1;
13587          vms_posix_exit = 1;
13588     }
13589 #endif
13590
13591     /* hacks to see if known bugs are still present for testing */
13592
13593     /* Readdir is returning filenames in VMS syntax always */
13594     decc_bug_readdir_efs1 = 1;
13595     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
13596     if ($VMS_STATUS_SUCCESS(status)) {
13597        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13598          decc_bug_readdir_efs1 = 1;
13599        else
13600          decc_bug_readdir_efs1 = 0;
13601     }
13602
13603     /* PCP mode requires creating /dev/null special device file */
13604     decc_bug_devnull = 0;
13605     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13606     if ($VMS_STATUS_SUCCESS(status)) {
13607        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13608           decc_bug_devnull = 1;
13609        else
13610           decc_bug_devnull = 0;
13611     }
13612
13613     /* fgetname returning a VMS name in UNIX mode */
13614     decc_bug_fgetname = 1;
13615     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
13616     if ($VMS_STATUS_SUCCESS(status)) {
13617       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13618         decc_bug_fgetname = 1;
13619       else
13620         decc_bug_fgetname = 0;
13621     }
13622
13623     /* UNIX directory names with no paths are broken in a lot of places */
13624     decc_dir_barename = 1;
13625     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13626     if ($VMS_STATUS_SUCCESS(status)) {
13627       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13628         decc_dir_barename = 1;
13629       else
13630         decc_dir_barename = 0;
13631     }
13632
13633 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13634     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13635     if (s >= 0) {
13636         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13637         if (decc_disable_to_vms_logname_translation < 0)
13638             decc_disable_to_vms_logname_translation = 0;
13639     }
13640
13641     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13642     if (s >= 0) {
13643         decc_efs_case_preserve = decc$feature_get_value(s, 1);
13644         if (decc_efs_case_preserve < 0)
13645             decc_efs_case_preserve = 0;
13646     }
13647
13648     s = decc$feature_get_index("DECC$EFS_CHARSET");
13649     if (s >= 0) {
13650         decc_efs_charset = decc$feature_get_value(s, 1);
13651         if (decc_efs_charset < 0)
13652             decc_efs_charset = 0;
13653     }
13654
13655     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13656     if (s >= 0) {
13657         decc_filename_unix_report = decc$feature_get_value(s, 1);
13658         if (decc_filename_unix_report > 0) {
13659             decc_filename_unix_report = 1;
13660             vms_posix_exit = 1;
13661         }
13662         else
13663             decc_filename_unix_report = 0;
13664     }
13665
13666     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
13667     if (s >= 0) {
13668         decc_filename_unix_only = decc$feature_get_value(s, 1);
13669         if (decc_filename_unix_only > 0) {
13670             decc_filename_unix_only = 1;
13671         }
13672         else {
13673             decc_filename_unix_only = 0;
13674         }
13675     }
13676
13677     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
13678     if (s >= 0) {
13679         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
13680         if (decc_filename_unix_no_version < 0)
13681             decc_filename_unix_no_version = 0;
13682     }
13683
13684     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
13685     if (s >= 0) {
13686         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
13687         if (decc_readdir_dropdotnotype < 0)
13688             decc_readdir_dropdotnotype = 0;
13689     }
13690
13691     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
13692     if ($VMS_STATUS_SUCCESS(status)) {
13693         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
13694         if (s >= 0) {
13695             dflt = decc$feature_get_value(s, 4);
13696             if (dflt > 0) {
13697                 decc_disable_posix_root = decc$feature_get_value(s, 1);
13698                 if (decc_disable_posix_root <= 0) {
13699                     decc$feature_set_value(s, 1, 1);
13700                     decc_disable_posix_root = 1;
13701                 }
13702             }
13703             else {
13704                 /* Traditionally Perl assumes this is off */
13705                 decc_disable_posix_root = 1;
13706                 decc$feature_set_value(s, 1, 1);
13707             }
13708         }
13709     }
13710
13711 #if __CRTL_VER >= 80200000
13712     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
13713     if (s >= 0) {
13714         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
13715         if (decc_posix_compliant_pathnames < 0)
13716             decc_posix_compliant_pathnames = 0;
13717         if (decc_posix_compliant_pathnames > 4)
13718             decc_posix_compliant_pathnames = 0;
13719     }
13720
13721 #endif
13722 #else
13723     status = sys_trnlnm
13724         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
13725     if ($VMS_STATUS_SUCCESS(status)) {
13726         val_str[0] = _toupper(val_str[0]);
13727         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13728            decc_disable_to_vms_logname_translation = 1;
13729         }
13730     }
13731
13732 #ifndef __VAX
13733     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
13734     if ($VMS_STATUS_SUCCESS(status)) {
13735         val_str[0] = _toupper(val_str[0]);
13736         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13737            decc_efs_case_preserve = 1;
13738         }
13739     }
13740 #endif
13741
13742     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
13743     if ($VMS_STATUS_SUCCESS(status)) {
13744         val_str[0] = _toupper(val_str[0]);
13745         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13746            decc_filename_unix_report = 1;
13747         }
13748     }
13749     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
13750     if ($VMS_STATUS_SUCCESS(status)) {
13751         val_str[0] = _toupper(val_str[0]);
13752         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13753            decc_filename_unix_only = 1;
13754            decc_filename_unix_report = 1;
13755         }
13756     }
13757     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
13758     if ($VMS_STATUS_SUCCESS(status)) {
13759         val_str[0] = _toupper(val_str[0]);
13760         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13761            decc_filename_unix_no_version = 1;
13762         }
13763     }
13764     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
13765     if ($VMS_STATUS_SUCCESS(status)) {
13766         val_str[0] = _toupper(val_str[0]);
13767         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13768            decc_readdir_dropdotnotype = 1;
13769         }
13770     }
13771 #endif
13772
13773 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
13774
13775      /* Report true case tolerance */
13776     /*----------------------------*/
13777     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
13778     if (!$VMS_STATUS_SUCCESS(status))
13779         case_perm = PPROP$K_CASE_BLIND;
13780     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
13781     if (!$VMS_STATUS_SUCCESS(status))
13782         case_image = PPROP$K_CASE_BLIND;
13783     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
13784         (case_image == PPROP$K_CASE_SENSITIVE))
13785         vms_process_case_tolerant = 0;
13786
13787 #endif
13788
13789     /* USE POSIX/DCL Exit codes - Recommended, but needs to default to  */
13790     /* for strict backward compatibilty */
13791     status = sys_trnlnm
13792         ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
13793     if ($VMS_STATUS_SUCCESS(status)) {
13794        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13795          vms_posix_exit = 1;
13796        else
13797          vms_posix_exit = 0;
13798     }
13799
13800
13801     /* CRTL can be initialized past this point, but not before. */
13802 /*    DECC$CRTL_INIT(); */
13803
13804     return SS$_NORMAL;
13805 }
13806
13807 #ifdef __DECC
13808 #pragma nostandard
13809 #pragma extern_model save
13810 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
13811         const __align (LONGWORD) int spare[8] = {0};
13812
13813 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
13814 #if __DECC_VER >= 60560002
13815 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
13816 #else
13817 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
13818 #endif
13819 #endif /* __DECC */
13820
13821 const long vms_cc_features = (const long)set_features;
13822
13823 /*
13824 ** Force a reference to LIB$INITIALIZE to ensure it
13825 ** exists in the image.
13826 */
13827 int lib$initialize(void);
13828 #ifdef __DECC
13829 #pragma extern_model strict_refdef
13830 #endif
13831     int lib_init_ref = (int) lib$initialize;
13832
13833 #ifdef __DECC
13834 #pragma extern_model restore
13835 #pragma standard
13836 #endif
13837
13838 /*  End of vms.c */