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  *
  22  *                           The Lay of Leithian, 135-40
  23  */
  24
  25 #include <acedef.h>
  26 #include <acldef.h>
  27 #include <armdef.h>
  28 #include <atrdef.h>
  29 #include <chpdef.h>
  30 #include <clidef.h>
  31 #include <climsgdef.h>
  32 #include <dcdef.h>
  33 #include <descrip.h>
  34 #include <devdef.h>
  35 #include <dvidef.h>
  36 #include <fibdef.h>
  37 #include <float.h>
  38 #include <fscndef.h>
  39 #include <iodef.h>
  40 #include <jpidef.h>
  41 #include <kgbdef.h>
  42 #include <libclidef.h>
  43 #include <libdef.h>
  44 #include <lib$routines.h>
  45 #include <lnmdef.h>
  46 #include <msgdef.h>
  47 #include <ossdef.h>
  48 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  49 #include <ppropdef.h>
  50 #endif
  51 #include <prvdef.h>
  52 #include <psldef.h>
  53 #include <rms.h>
  54 #include <shrdef.h>
  55 #include <ssdef.h>
  56 #include <starlet.h>
  57 #include <strdef.h>
  58 #include <str$routines.h>
  59 #include <syidef.h>
  60 #include <uaidef.h>
  61 #include <uicdef.h>
  62 #include <stsdef.h>
  63 #include <rmsdef.h>
  64 #include <smgdef.h>
  65 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
  66 #include <efndef.h>
  67 #define NO_EFN EFN$C_ENF
  68 #else
  69 #define NO_EFN 0;
  70 #endif
  71
  72 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  73 int   decc$feature_get_index(const char *name);
  74 char* decc$feature_get_name(int index);
  75 int   decc$feature_get_value(int index, int mode);
  76 int   decc$feature_set_value(int index, int mode, int value);
  77 #else
  78 #include <unixlib.h>
  79 #endif
  80
  81 #pragma member_alignment save
  82 #pragma nomember_alignment longword
  83 struct item_list_3 {
  84         unsigned short len;
  85         unsigned short code;
  86         void * bufadr;
  87         unsigned short * retadr;
  88 };
  89 #pragma member_alignment restore
  90
  91 /* More specific prototype than in starlet_c.h makes programming errors
  92    more visible.
  93  */
  94 #ifdef sys$getdviw
  95 #undef sys$getdviw
  96 int sys$getdviw
  97        (unsigned long efn,
  98         unsigned short chan,
  99         const struct dsc$descriptor_s * devnam,
 100         const struct item_list_3 * itmlst,
 101         void * iosb,
 102         void * (astadr)(unsigned long),
 103         void * astprm,
 104         void * nullarg);
 105 #endif
 106
 107 #ifdef sys$get_security
 108 #undef sys$get_security
 109 int sys$get_security
 110        (const struct dsc$descriptor_s * clsnam,
 111         const struct dsc$descriptor_s * objnam,
 112         const unsigned int *objhan,
 113         unsigned int flags,
 114         const struct item_list_3 * itmlst,
 115         unsigned int * contxt,
 116         const unsigned int * acmode);
 117 #endif
 118
 119 #ifdef sys$set_security
 120 #undef sys$set_security
 121 int sys$set_security
 122        (const struct dsc$descriptor_s * clsnam,
 123         const struct dsc$descriptor_s * objnam,
 124         const unsigned int *objhan,
 125         unsigned int flags,
 126         const struct item_list_3 * itmlst,
 127         unsigned int * contxt,
 128         const unsigned int * acmode);
 129 #endif
 130
 131 #ifdef lib$find_image_symbol
 132 #undef lib$find_image_symbol
 133 int lib$find_image_symbol
 134        (const struct dsc$descriptor_s * imgname,
 135         const struct dsc$descriptor_s * symname,
 136         void * symval,
 137         const struct dsc$descriptor_s * defspec,
 138         unsigned long flag);
 139 #endif
 140
 141 #ifdef lib$rename_file
 142 #undef lib$rename_file
 143 int lib$rename_file
 144        (const struct dsc$descriptor_s * old_file_dsc,
 145         const struct dsc$descriptor_s * new_file_dsc,
 146         const struct dsc$descriptor_s * default_file_dsc,
 147         const struct dsc$descriptor_s * related_file_dsc,
 148         const unsigned long * flags,
 149         void * (success)(const struct dsc$descriptor_s * old_dsc,
 150                          const struct dsc$descriptor_s * new_dsc,
 151                          const void *),
 152         void * (error)(const struct dsc$descriptor_s * old_dsc,
 153                        const struct dsc$descriptor_s * new_dsc,
 154                        const int * rms_sts,
 155                        const int * rms_stv,
 156                        const int * error_src,
 157                        const void * usr_arg),
 158         int (confirm)(const struct dsc$descriptor_s * old_dsc,
 159                       const struct dsc$descriptor_s * new_dsc,
 160                       const void * old_fab,
 161                       const void * usr_arg),
 162         void * user_arg,
 163         struct dsc$descriptor_s * old_result_name_dsc,
 164         struct dsc$descriptor_s * new_result_name_dsc,
 165         unsigned long * file_scan_context);
 166 #endif
 167
 168 #if __CRTL_VER >= 70300000 && !defined(__VAX)
 169
 170 static int set_feature_default(const char *name, int value)
 171 {
 172     int status;
 173     int index;
 174
 175     index = decc$feature_get_index(name);
 176
 177     status = decc$feature_set_value(index, 1, value);
 178     if (index == -1 || (status == -1)) {
 179       return -1;
 180     }
 181
 182     status = decc$feature_get_value(index, 1);
 183     if (status != value) {
 184       return -1;
 185     }
 186
 187 return 0;
 188 }
 189 #endif
 190
 191 /* Older versions of ssdef.h don't have these */
 192 #ifndef SS$_INVFILFOROP
 193 #  define SS$_INVFILFOROP 3930
 194 #endif
 195 #ifndef SS$_NOSUCHOBJECT
 196 #  define SS$_NOSUCHOBJECT 2696
 197 #endif
 198
 199 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 200 #define PERLIO_NOT_STDIO 0
 201
 202 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 203  * code below needs to get to the underlying CRTL routines. */
 204 #define DONT_MASK_RTL_CALLS
 205 #include "EXTERN.h"
 206 #include "perl.h"
 207 #include "XSUB.h"
 208 /* Anticipating future expansion in lexical warnings . . . */
 209 #ifndef WARN_INTERNAL
 210 #  define WARN_INTERNAL WARN_MISC
 211 #endif
 212
 213 #ifdef VMS_LONGNAME_SUPPORT
 214 #include <libfildef.h>
 215 #endif
 216
 217 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 218 #  define RTL_USES_UTC 1
 219 #endif
 220
 221 /* Routine to create a decterm for use with the Perl debugger */
 222 /* No headers, this information was found in the Programming Concepts Manual */
 223
 224 static int (*decw_term_port)
 225    (const struct dsc$descriptor_s * display,
 226     const struct dsc$descriptor_s * setup_file,
 227     const struct dsc$descriptor_s * customization,
 228     struct dsc$descriptor_s * result_device_name,
 229     unsigned short * result_device_name_length,
 230     void * controller,
 231     void * char_buffer,
 232     void * char_change_buffer) = 0;
 233
 234 /* gcc's header files don't #define direct access macros
 235  * corresponding to VAXC's variant structs */
 236 #ifdef __GNUC__
 237 #  define uic$v_format uic$r_uic_form.uic$v_format
 238 #  define uic$v_group uic$r_uic_form.uic$v_group
 239 #  define uic$v_member uic$r_uic_form.uic$v_member
 240 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 241 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 242 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 243 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 244 #endif
 245
 246 #if defined(NEED_AN_H_ERRNO)
 247 dEXT int h_errno;
 248 #endif
 249
 250 #ifdef __DECC
 251 #pragma message disable pragma
 252 #pragma member_alignment save
 253 #pragma nomember_alignment longword
 254 #pragma message save
 255 #pragma message disable misalgndmem
 256 #endif
 257 struct itmlst_3 {
 258   unsigned short int buflen;
 259   unsigned short int itmcode;
 260   void *bufadr;
 261   unsigned short int *retlen;
 262 };
 263
 264 struct filescan_itmlst_2 {
 265     unsigned short length;
 266     unsigned short itmcode;
 267     char * component;
 268 };
 269
 270 struct vs_str_st {
 271     unsigned short length;
 272     char str[65536];
 273 };
 274
 275 #ifdef __DECC
 276 #pragma message restore
 277 #pragma member_alignment restore
 278 #endif
 279
 280 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 281 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 282 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 283 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 284 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 285 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 286 #define do_vms_realname(a,b,c)          mp_do_vms_realname(aTHX_ a,b,c)
 287 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 288 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 289 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 290 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 291 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 292
 293 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 294 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 295 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 296 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 297
 298 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 299 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 300
 301 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 302  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 303  * the Perl facility.
 304  */
 305 #define PERL_LNM_MAX_ITER 10
 306
 307   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 308 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 309 #define MAX_DCL_SYMBOL          (8192)
 310 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 311 #else
 312 #define MAX_DCL_SYMBOL          (1024)
 313 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 314 #endif
 315
 316 static char *__mystrtolower(char *str)
 317 {
 318   if (str) for (; *str; ++str) *str= tolower(*str);
 319   return str;
 320 }
 321
 322 static struct dsc$descriptor_s fildevdsc =
 323   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 324 static struct dsc$descriptor_s crtlenvdsc =
 325   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 326 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 327 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 328 static struct dsc$descriptor_s **env_tables = defenv;
 329 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 330
 331 /* True if we shouldn't treat barewords as logicals during directory */
 332 /* munching */
 333 static int no_translate_barewords;
 334
 335 #ifndef RTL_USES_UTC
 336 static int tz_updated = 1;
 337 #endif
 338
 339 /* DECC Features that may need to affect how Perl interprets
 340  * displays filename information
 341  */
 342 static int decc_disable_to_vms_logname_translation = 1;
 343 static int decc_disable_posix_root = 1;
 344 int decc_efs_case_preserve = 0;
 345 static int decc_efs_charset = 0;
 346 static int decc_filename_unix_no_version = 0;
 347 static int decc_filename_unix_only = 0;
 348 int decc_filename_unix_report = 0;
 349 int decc_posix_compliant_pathnames = 0;
 350 int decc_readdir_dropdotnotype = 0;
 351 static int vms_process_case_tolerant = 1;
 352 int vms_vtf7_filenames = 0;
 353 int gnv_unix_shell = 0;
 354 static int vms_unlink_all_versions = 0;
 355
 356 /* bug workarounds if needed */
 357 int decc_bug_readdir_efs1 = 0;
 358 int decc_bug_devnull = 1;
 359 int decc_bug_fgetname = 0;
 360 int decc_dir_barename = 0;
 361
 362 static int vms_debug_on_exception = 0;
 363
 364 /* Is this a UNIX file specification?
 365  *   No longer a simple check with EFS file specs
 366  *   For now, not a full check, but need to
 367  *   handle POSIX ^UP^ specifications
 368  *   Fixing to handle ^/ cases would require
 369  *   changes to many other conversion routines.
 370  */
 371
 372 static int is_unix_filespec(const char *path)
 373 {
 374 int ret_val;
 375 const char * pch1;
 376
 377     ret_val = 0;
 378     if (strncmp(path,"\"^UP^",5) != 0) {
 379         pch1 = strchr(path, '/');
 380         if (pch1 != NULL)
 381             ret_val = 1;
 382         else {
 383
 384             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 385             if (decc_filename_unix_report || decc_filename_unix_only) {
 386             if (strcmp(path,".") == 0)
 387                 ret_val = 1;
 388             }
 389         }
 390     }
 391     return ret_val;
 392 }
 393
 394 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 395  */
 396
 397 static void ucs2_to_vtf7
 398    (char *outspec,
 399     unsigned long ucs2_char,
 400     int * output_cnt)
 401 {
 402 unsigned char * ucs_ptr;
 403 int hex;
 404
 405     ucs_ptr = (unsigned char *)&ucs2_char;
 406
 407     outspec[0] = '^';
 408     outspec[1] = 'U';
 409     hex = (ucs_ptr[1] >> 4) & 0xf;
 410     if (hex < 0xA)
 411         outspec[2] = hex + '0';
 412     else
 413         outspec[2] = (hex - 9) + 'A';
 414     hex = ucs_ptr[1] & 0xF;
 415     if (hex < 0xA)
 416         outspec[3] = hex + '0';
 417     else {
 418         outspec[3] = (hex - 9) + 'A';
 419     }
 420     hex = (ucs_ptr[0] >> 4) & 0xf;
 421     if (hex < 0xA)
 422         outspec[4] = hex + '0';
 423     else
 424         outspec[4] = (hex - 9) + 'A';
 425     hex = ucs_ptr[1] & 0xF;
 426     if (hex < 0xA)
 427         outspec[5] = hex + '0';
 428     else {
 429         outspec[5] = (hex - 9) + 'A';
 430     }
 431     *output_cnt = 6;
 432 }
 433
 434
 435 /* This handles the conversion of a UNIX extended character set to a ^
 436  * escaped VMS character.
 437  * in a UNIX file specification.
 438  *
 439  * The output count variable contains the number of characters added
 440  * to the output string.
 441  *
 442  * The return value is the number of characters read from the input string
 443  */
 444 static int copy_expand_unix_filename_escape
 445   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 446 {
 447 int count;
 448 int scnt;
 449 int utf8_flag;
 450
 451     utf8_flag = 0;
 452     if (utf8_fl)
 453       utf8_flag = *utf8_fl;
 454
 455     count = 0;
 456     *output_cnt = 0;
 457     if (*inspec >= 0x80) {
 458         if (utf8_fl && vms_vtf7_filenames) {
 459         unsigned long ucs_char;
 460
 461             ucs_char = 0;
 462
 463             if ((*inspec & 0xE0) == 0xC0) {
 464                 /* 2 byte Unicode */
 465                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 466                 if (ucs_char >= 0x80) {
 467                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 468                     return 2;
 469                 }
 470             } else if ((*inspec & 0xF0) == 0xE0) {
 471                 /* 3 byte Unicode */
 472                 ucs_char = ((inspec[0] & 0xF) << 12) +
 473                    ((inspec[1] & 0x3f) << 6) +
 474                    (inspec[2] & 0x3f);
 475                 if (ucs_char >= 0x800) {
 476                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 477                     return 3;
 478                 }
 479
 480 #if 0 /* I do not see longer sequences supported by OpenVMS */
 481       /* Maybe some one can fix this later */
 482             } else if ((*inspec & 0xF8) == 0xF0) {
 483                 /* 4 byte Unicode */
 484                 /* UCS-4 to UCS-2 */
 485             } else if ((*inspec & 0xFC) == 0xF8) {
 486                 /* 5 byte Unicode */
 487                 /* UCS-4 to UCS-2 */
 488             } else if ((*inspec & 0xFE) == 0xFC) {
 489                 /* 6 byte Unicode */
 490                 /* UCS-4 to UCS-2 */
 491 #endif
 492             }
 493         }
 494
 495         /* High bit set, but not a Unicode character! */
 496
 497         /* Non printing DECMCS or ISO Latin-1 character? */
 498         if (*inspec <= 0x9F) {
 499         int hex;
 500             outspec[0] = '^';
 501             outspec++;
 502             hex = (*inspec >> 4) & 0xF;
 503             if (hex < 0xA)
 504                 outspec[1] = hex + '0';
 505             else {
 506                 outspec[1] = (hex - 9) + 'A';
 507             }
 508             hex = *inspec & 0xF;
 509             if (hex < 0xA)
 510                 outspec[2] = hex + '0';
 511             else {
 512                 outspec[2] = (hex - 9) + 'A';
 513             }
 514             *output_cnt = 3;
 515             return 1;
 516         } else if (*inspec == 0xA0) {
 517             outspec[0] = '^';
 518             outspec[1] = 'A';
 519             outspec[2] = '0';
 520             *output_cnt = 3;
 521             return 1;
 522         } else if (*inspec == 0xFF) {
 523             outspec[0] = '^';
 524             outspec[1] = 'F';
 525             outspec[2] = 'F';
 526             *output_cnt = 3;
 527             return 1;
 528         }
 529         *outspec = *inspec;
 530         *output_cnt = 1;
 531         return 1;
 532     }
 533
 534     /* Is this a macro that needs to be passed through?
 535      * Macros start with $( and an alpha character, followed
 536      * by a string of alpha numeric characters ending with a )
 537      * If this does not match, then encode it as ODS-5.
 538      */
 539     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 540     int tcnt;
 541
 542         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 543             tcnt = 3;
 544             outspec[0] = inspec[0];
 545             outspec[1] = inspec[1];
 546             outspec[2] = inspec[2];
 547
 548             while(isalnum(inspec[tcnt]) ||
 549                   (inspec[2] == '.') || (inspec[2] == '_')) {
 550                 outspec[tcnt] = inspec[tcnt];
 551                 tcnt++;
 552             }
 553             if (inspec[tcnt] == ')') {
 554                 outspec[tcnt] = inspec[tcnt];
 555                 tcnt++;
 556                 *output_cnt = tcnt;
 557                 return tcnt;
 558             }
 559         }
 560     }
 561
 562     switch (*inspec) {
 563     case 0x7f:
 564         outspec[0] = '^';
 565         outspec[1] = '7';
 566         outspec[2] = 'F';
 567         *output_cnt = 3;
 568         return 1;
 569         break;
 570     case '?':
 571         if (decc_efs_charset == 0)
 572           outspec[0] = '%';
 573         else
 574           outspec[0] = '?';
 575         *output_cnt = 1;
 576         return 1;
 577         break;
 578     case '.':
 579     case '~':
 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         /* Don't escape again if following character is
 598          * already something we escape.
 599          */
 600         if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
 601             *outspec = *inspec;
 602             *output_cnt = 1;
 603             return 1;
 604             break;
 605         }
 606         /* But otherwise fall through and escape it. */
 607     case '=':
 608         /* Assume that this is to be escaped */
 609         outspec[0] = '^';
 610         outspec[1] = *inspec;
 611         *output_cnt = 2;
 612         return 1;
 613         break;
 614     case ' ': /* space */
 615         /* Assume that this is to be escaped */
 616         outspec[0] = '^';
 617         outspec[1] = '_';
 618         *output_cnt = 2;
 619         return 1;
 620         break;
 621     default:
 622         *outspec = *inspec;
 623         *output_cnt = 1;
 624         return 1;
 625         break;
 626     }
 627 }
 628
 629
 630 /* This handles the expansion of a '^' prefix to the proper character
 631  * in a UNIX file specification.
 632  *
 633  * The output count variable contains the number of characters added
 634  * to the output string.
 635  *
 636  * The return value is the number of characters read from the input
 637  * string
 638  */
 639 static int copy_expand_vms_filename_escape
 640   (char *outspec, const char *inspec, int *output_cnt)
 641 {
 642 int count;
 643 int scnt;
 644
 645     count = 0;
 646     *output_cnt = 0;
 647     if (*inspec == '^') {
 648         inspec++;
 649         switch (*inspec) {
 650         /* Spaces and non-trailing dots should just be passed through,
 651          * but eat the escape character.
 652          */
 653         case '.':
 654             *outspec = *inspec;
 655             count += 2;
 656             (*output_cnt)++;
 657             break;
 658         case '_': /* space */
 659             *outspec = ' ';
 660             count += 2;
 661             (*output_cnt)++;
 662             break;
 663         case '^':
 664             /* Hmm.  Better leave the escape escaped. */
 665             outspec[0] = '^';
 666             outspec[1] = '^';
 667             count += 2;
 668             (*output_cnt) += 2;
 669             break;
 670         case 'U': /* Unicode - FIX-ME this is wrong. */
 671             inspec++;
 672             count++;
 673             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 674             if (scnt == 4) {
 675                 unsigned int c1, c2;
 676                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 677                 outspec[0] == c1 & 0xff;
 678                 outspec[1] == c2 & 0xff;
 679                 if (scnt > 1) {
 680                     (*output_cnt) += 2;
 681                     count += 4;
 682                 }
 683             }
 684             else {
 685                 /* Error - do best we can to continue */
 686                 *outspec = 'U';
 687                 outspec++;
 688                 (*output_cnt++);
 689                 *outspec = *inspec;
 690                 count++;
 691                 (*output_cnt++);
 692             }
 693             break;
 694         default:
 695             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 696             if (scnt == 2) {
 697                 /* Hex encoded */
 698                 unsigned int c1;
 699                 scnt = sscanf(inspec, "%2x", &c1);
 700                 outspec[0] = c1 & 0xff;
 701                 if (scnt > 0) {
 702                     (*output_cnt++);
 703                     count += 2;
 704                 }
 705             }
 706             else {
 707                 *outspec = *inspec;
 708                 count++;
 709                 (*output_cnt++);
 710             }
 711         }
 712     }
 713     else {
 714         *outspec = *inspec;
 715         count++;
 716         (*output_cnt)++;
 717     }
 718     return count;
 719 }
 720
 721 #ifdef sys$filescan
 722 #undef sys$filescan
 723 int sys$filescan
 724    (const struct dsc$descriptor_s * srcstr,
 725     struct filescan_itmlst_2 * valuelist,
 726     unsigned long * fldflags,
 727     struct dsc$descriptor_s *auxout,
 728     unsigned short * retlen);
 729 #endif
 730
 731 /* vms_split_path - Verify that the input file specification is a
 732  * VMS format file specification, and provide pointers to the components of
 733  * it.  With EFS format filenames, this is virtually the only way to
 734  * parse a VMS path specification into components.
 735  *
 736  * If the sum of the components do not add up to the length of the
 737  * string, then the passed file specification is probably a UNIX style
 738  * path.
 739  */
 740 static int vms_split_path
 741    (const char * path,
 742     char * * volume,
 743     int * vol_len,
 744     char * * root,
 745     int * root_len,
 746     char * * dir,
 747     int * dir_len,
 748     char * * name,
 749     int * name_len,
 750     char * * ext,
 751     int * ext_len,
 752     char * * version,
 753     int * ver_len)
 754 {
 755 struct dsc$descriptor path_desc;
 756 int status;
 757 unsigned long flags;
 758 int ret_stat;
 759 struct filescan_itmlst_2 item_list[9];
 760 const int filespec = 0;
 761 const int nodespec = 1;
 762 const int devspec = 2;
 763 const int rootspec = 3;
 764 const int dirspec = 4;
 765 const int namespec = 5;
 766 const int typespec = 6;
 767 const int verspec = 7;
 768
 769     /* Assume the worst for an easy exit */
 770     ret_stat = -1;
 771     *volume = NULL;
 772     *vol_len = 0;
 773     *root = NULL;
 774     *root_len = 0;
 775     *dir = NULL;
 776     *dir_len;
 777     *name = NULL;
 778     *name_len = 0;
 779     *ext = NULL;
 780     *ext_len = 0;
 781     *version = NULL;
 782     *ver_len = 0;
 783
 784     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 785     path_desc.dsc$w_length = strlen(path);
 786     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 787     path_desc.dsc$b_class = DSC$K_CLASS_S;
 788
 789     /* Get the total length, if it is shorter than the string passed
 790      * then this was probably not a VMS formatted file specification
 791      */
 792     item_list[filespec].itmcode = FSCN$_FILESPEC;
 793     item_list[filespec].length = 0;
 794     item_list[filespec].component = NULL;
 795
 796     /* If the node is present, then it gets considered as part of the
 797      * volume name to hopefully make things simple.
 798      */
 799     item_list[nodespec].itmcode = FSCN$_NODE;
 800     item_list[nodespec].length = 0;
 801     item_list[nodespec].component = NULL;
 802
 803     item_list[devspec].itmcode = FSCN$_DEVICE;
 804     item_list[devspec].length = 0;
 805     item_list[devspec].component = NULL;
 806
 807     /* root is a special case,  adding it to either the directory or
 808      * the device components will probalby complicate things for the
 809      * callers of this routine, so leave it separate.
 810      */
 811     item_list[rootspec].itmcode = FSCN$_ROOT;
 812     item_list[rootspec].length = 0;
 813     item_list[rootspec].component = NULL;
 814
 815     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 816     item_list[dirspec].length = 0;
 817     item_list[dirspec].component = NULL;
 818
 819     item_list[namespec].itmcode = FSCN$_NAME;
 820     item_list[namespec].length = 0;
 821     item_list[namespec].component = NULL;
 822
 823     item_list[typespec].itmcode = FSCN$_TYPE;
 824     item_list[typespec].length = 0;
 825     item_list[typespec].component = NULL;
 826
 827     item_list[verspec].itmcode = FSCN$_VERSION;
 828     item_list[verspec].length = 0;
 829     item_list[verspec].component = NULL;
 830
 831     item_list[8].itmcode = 0;
 832     item_list[8].length = 0;
 833     item_list[8].component = NULL;
 834
 835     status = sys$filescan
 836        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 837         &flags, NULL, NULL);
 838     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 839
 840     /* If we parsed it successfully these two lengths should be the same */
 841     if (path_desc.dsc$w_length != item_list[filespec].length)
 842         return ret_stat;
 843
 844     /* If we got here, then it is a VMS file specification */
 845     ret_stat = 0;
 846
 847     /* set the volume name */
 848     if (item_list[nodespec].length > 0) {
 849         *volume = item_list[nodespec].component;
 850         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 851     }
 852     else {
 853         *volume = item_list[devspec].component;
 854         *vol_len = item_list[devspec].length;
 855     }
 856
 857     *root = item_list[rootspec].component;
 858     *root_len = item_list[rootspec].length;
 859
 860     *dir = item_list[dirspec].component;
 861     *dir_len = item_list[dirspec].length;
 862
 863     /* Now fun with versions and EFS file specifications
 864      * The parser can not tell the difference when a "." is a version
 865      * delimiter or a part of the file specification.
 866      */
 867     if ((decc_efs_charset) &&
 868         (item_list[verspec].length > 0) &&
 869         (item_list[verspec].component[0] == '.')) {
 870         *name = item_list[namespec].component;
 871         *name_len = item_list[namespec].length + item_list[typespec].length;
 872         *ext = item_list[verspec].component;
 873         *ext_len = item_list[verspec].length;
 874         *version = NULL;
 875         *ver_len = 0;
 876     }
 877     else {
 878         *name = item_list[namespec].component;
 879         *name_len = item_list[namespec].length;
 880         *ext = item_list[typespec].component;
 881         *ext_len = item_list[typespec].length;
 882         *version = item_list[verspec].component;
 883         *ver_len = item_list[verspec].length;
 884     }
 885     return ret_stat;
 886 }
 887
 888
 889 /* my_maxidx
 890  * Routine to retrieve the maximum equivalence index for an input
 891  * logical name.  Some calls to this routine have no knowledge if
 892  * the variable is a logical or not.  So on error we return a max
 893  * index of zero.
 894  */
 895 /*{{{int my_maxidx(const char *lnm) */
 896 static int
 897 my_maxidx(const char *lnm)
 898 {
 899     int status;
 900     int midx;
 901     int attr = LNM$M_CASE_BLIND;
 902     struct dsc$descriptor lnmdsc;
 903     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 904                                 {0, 0, 0, 0}};
 905
 906     lnmdsc.dsc$w_length = strlen(lnm);
 907     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 908     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 909     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 910
 911     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 912     if ((status & 1) == 0)
 913        midx = 0;
 914
 915     return (midx);
 916 }
 917 /*}}}*/
 918
 919 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 920 int
 921 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 922   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 923 {
 924     const char *cp1;
 925     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 926     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 927     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 928     int midx;
 929     unsigned char acmode;
 930     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 931                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 932     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 933                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 934                                  {0, 0, 0, 0}};
 935     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 936 #if defined(PERL_IMPLICIT_CONTEXT)
 937     pTHX = NULL;
 938     if (PL_curinterp) {
 939       aTHX = PERL_GET_INTERP;
 940     } else {
 941       aTHX = NULL;
 942     }
 943 #endif
 944
 945     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 946       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 947     }
 948     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 949       *cp2 = _toupper(*cp1);
 950       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 951         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 952         return 0;
 953       }
 954     }
 955     lnmdsc.dsc$w_length = cp1 - lnm;
 956     lnmdsc.dsc$a_pointer = uplnm;
 957     uplnm[lnmdsc.dsc$w_length] = '\0';
 958     secure = flags & PERL__TRNENV_SECURE;
 959     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 960     if (!tabvec || !*tabvec) tabvec = env_tables;
 961
 962     for (curtab = 0; tabvec[curtab]; curtab++) {
 963       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 964         if (!ivenv && !secure) {
 965           char *eq, *end;
 966           int i;
 967           if (!environ) {
 968             ivenv = 1;
 969             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 970             continue;
 971           }
 972           retsts = SS$_NOLOGNAM;
 973           for (i = 0; environ[i]; i++) {
 974             if ((eq = strchr(environ[i],'=')) &&
 975                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 976                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 977               eq++;
 978               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 979               if (!eqvlen) continue;
 980               retsts = SS$_NORMAL;
 981               break;
 982             }
 983           }
 984           if (retsts != SS$_NOLOGNAM) break;
 985         }
 986       }
 987       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 988                !str$case_blind_compare(&tmpdsc,&clisym)) {
 989         if (!ivsym && !secure) {
 990           unsigned short int deflen = LNM$C_NAMLENGTH;
 991           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 992           /* dynamic dsc to accomodate possible long value */
 993           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 994           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 995           if (retsts & 1) {
 996             if (eqvlen > MAX_DCL_SYMBOL) {
 997               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 998               eqvlen = MAX_DCL_SYMBOL;
 999               /* Special hack--we might be called before the interpreter's */
1000               /* fully initialized, in which case either thr or PL_curcop */
1001               /* might be bogus. We have to check, since ckWARN needs them */
1002               /* both to be valid if running threaded */
1003                 if (ckWARN(WARN_MISC)) {
1004                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1005                 }
1006             }
1007             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1008           }
1009           _ckvmssts(lib$sfree1_dd(&eqvdsc));
1010           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1011           if (retsts == LIB$_NOSUCHSYM) continue;
1012           break;
1013         }
1014       }
1015       else if (!ivlnm) {
1016         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1017           midx = my_maxidx(lnm);
1018           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1019             lnmlst[1].bufadr = cp2;
1020             eqvlen = 0;
1021             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1022             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1023             if (retsts == SS$_NOLOGNAM) break;
1024             /* PPFs have a prefix */
1025             if (
1026 #if INTSIZE == 4
1027                  *((int *)uplnm) == *((int *)"SYS$")                    &&
1028 #endif
1029                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
1030                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
1031                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
1032                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
1033                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
1034               memmove(eqv,eqv+4,eqvlen-4);
1035               eqvlen -= 4;
1036             }
1037             cp2 += eqvlen;
1038             *cp2 = '\0';
1039           }
1040           if ((retsts == SS$_IVLOGNAM) ||
1041               (retsts == SS$_NOLOGNAM)) { continue; }
1042         }
1043         else {
1044           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1045           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1046           if (retsts == SS$_NOLOGNAM) continue;
1047           eqv[eqvlen] = '\0';
1048         }
1049         eqvlen = strlen(eqv);
1050         break;
1051       }
1052     }
1053     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1054     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1055              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
1056              retsts == SS$_NOLOGNAM) {
1057       set_errno(EINVAL);  set_vaxc_errno(retsts);
1058     }
1059     else _ckvmssts(retsts);
1060     return 0;
1061 }  /* end of vmstrnenv */
1062 /*}}}*/
1063
1064 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1065 /* Define as a function so we can access statics. */
1066 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1067 {
1068   return vmstrnenv(lnm,eqv,idx,fildev,
1069 #ifdef SECURE_INTERNAL_GETENV
1070                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
1071 #else
1072                    0
1073 #endif
1074                                                                               );
1075 }
1076 /*}}}*/
1077
1078 /* my_getenv
1079  * Note: Uses Perl temp to store result so char * can be returned to
1080  * caller; this pointer will be invalidated at next Perl statement
1081  * transition.
1082  * We define this as a function rather than a macro in terms of my_getenv_len()
1083  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1084  * allocate SVs).
1085  */
1086 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1087 char *
1088 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1089 {
1090     const char *cp1;
1091     static char *__my_getenv_eqv = NULL;
1092     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1093     unsigned long int idx = 0;
1094     int trnsuccess, success, secure, saverr, savvmserr;
1095     int midx, flags;
1096     SV *tmpsv;
1097
1098     midx = my_maxidx(lnm) + 1;
1099
1100     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1101       /* Set up a temporary buffer for the return value; Perl will
1102        * clean it up at the next statement transition */
1103       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1104       if (!tmpsv) return NULL;
1105       eqv = SvPVX(tmpsv);
1106     }
1107     else {
1108       /* Assume no interpreter ==> single thread */
1109       if (__my_getenv_eqv != NULL) {
1110         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1111       }
1112       else {
1113         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1114       }
1115       eqv = __my_getenv_eqv;
1116     }
1117
1118     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1119     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1120       int len;
1121       getcwd(eqv,LNM$C_NAMLENGTH);
1122
1123       len = strlen(eqv);
1124
1125       /* Get rid of "000000/ in rooted filespecs */
1126       if (len > 7) {
1127         char * zeros;
1128         zeros = strstr(eqv, "/000000/");
1129         if (zeros != NULL) {
1130           int mlen;
1131           mlen = len - (zeros - eqv) - 7;
1132           memmove(zeros, &zeros[7], mlen);
1133           len = len - 7;
1134           eqv[len] = '\0';
1135         }
1136       }
1137       return eqv;
1138     }
1139     else {
1140       /* Impose security constraints only if tainting */
1141       if (sys) {
1142         /* Impose security constraints only if tainting */
1143         secure = PL_curinterp ? PL_tainting : will_taint;
1144         saverr = errno;  savvmserr = vaxc$errno;
1145       }
1146       else {
1147         secure = 0;
1148       }
1149
1150       flags =
1151 #ifdef SECURE_INTERNAL_GETENV
1152               secure ? PERL__TRNENV_SECURE : 0
1153 #else
1154               0
1155 #endif
1156       ;
1157
1158       /* For the getenv interface we combine all the equivalence names
1159        * of a search list logical into one value to acquire a maximum
1160        * value length of 255*128 (assuming %ENV is using logicals).
1161        */
1162       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1163
1164       /* If the name contains a semicolon-delimited index, parse it
1165        * off and make sure we only retrieve the equivalence name for
1166        * that index.  */
1167       if ((cp2 = strchr(lnm,';')) != NULL) {
1168         strcpy(uplnm,lnm);
1169         uplnm[cp2-lnm] = '\0';
1170         idx = strtoul(cp2+1,NULL,0);
1171         lnm = uplnm;
1172         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1173       }
1174
1175       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1176
1177       /* Discard NOLOGNAM on internal calls since we're often looking
1178        * for an optional name, and this "error" often shows up as the
1179        * (bogus) exit status for a die() call later on.  */
1180       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1181       return success ? eqv : NULL;
1182     }
1183
1184 }  /* end of my_getenv() */
1185 /*}}}*/
1186
1187
1188 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1189 char *
1190 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1191 {
1192     const char *cp1;
1193     char *buf, *cp2;
1194     unsigned long idx = 0;
1195     int midx, flags;
1196     static char *__my_getenv_len_eqv = NULL;
1197     int secure, saverr, savvmserr;
1198     SV *tmpsv;
1199
1200     midx = my_maxidx(lnm) + 1;
1201
1202     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1203       /* Set up a temporary buffer for the return value; Perl will
1204        * clean it up at the next statement transition */
1205       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1206       if (!tmpsv) return NULL;
1207       buf = SvPVX(tmpsv);
1208     }
1209     else {
1210       /* Assume no interpreter ==> single thread */
1211       if (__my_getenv_len_eqv != NULL) {
1212         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1213       }
1214       else {
1215         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1216       }
1217       buf = __my_getenv_len_eqv;
1218     }
1219
1220     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1221     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1222     char * zeros;
1223
1224       getcwd(buf,LNM$C_NAMLENGTH);
1225       *len = strlen(buf);
1226
1227       /* Get rid of "000000/ in rooted filespecs */
1228       if (*len > 7) {
1229       zeros = strstr(buf, "/000000/");
1230       if (zeros != NULL) {
1231         int mlen;
1232         mlen = *len - (zeros - buf) - 7;
1233         memmove(zeros, &zeros[7], mlen);
1234         *len = *len - 7;
1235         buf[*len] = '\0';
1236         }
1237       }
1238       return buf;
1239     }
1240     else {
1241       if (sys) {
1242         /* Impose security constraints only if tainting */
1243         secure = PL_curinterp ? PL_tainting : will_taint;
1244         saverr = errno;  savvmserr = vaxc$errno;
1245       }
1246       else {
1247         secure = 0;
1248       }
1249
1250       flags =
1251 #ifdef SECURE_INTERNAL_GETENV
1252               secure ? PERL__TRNENV_SECURE : 0
1253 #else
1254               0
1255 #endif
1256       ;
1257
1258       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1259
1260       if ((cp2 = strchr(lnm,';')) != NULL) {
1261         strcpy(buf,lnm);
1262         buf[cp2-lnm] = '\0';
1263         idx = strtoul(cp2+1,NULL,0);
1264         lnm = buf;
1265         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1266       }
1267
1268       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1269
1270       /* Get rid of "000000/ in rooted filespecs */
1271       if (*len > 7) {
1272       char * zeros;
1273         zeros = strstr(buf, "/000000/");
1274         if (zeros != NULL) {
1275           int mlen;
1276           mlen = *len - (zeros - buf) - 7;
1277           memmove(zeros, &zeros[7], mlen);
1278           *len = *len - 7;
1279           buf[*len] = '\0';
1280         }
1281       }
1282
1283       /* Discard NOLOGNAM on internal calls since we're often looking
1284        * for an optional name, and this "error" often shows up as the
1285        * (bogus) exit status for a die() call later on.  */
1286       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1287       return *len ? buf : NULL;
1288     }
1289
1290 }  /* end of my_getenv_len() */
1291 /*}}}*/
1292
1293 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1294
1295 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1296
1297 /*{{{ void prime_env_iter() */
1298 void
1299 prime_env_iter(void)
1300 /* Fill the %ENV associative array with all logical names we can
1301  * find, in preparation for iterating over it.
1302  */
1303 {
1304   static int primed = 0;
1305   HV *seenhv = NULL, *envhv;
1306   SV *sv = NULL;
1307   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1308   unsigned short int chan;
1309 #ifndef CLI$M_TRUSTED
1310 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1311 #endif
1312   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1313   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1314   long int i;
1315   bool have_sym = FALSE, have_lnm = FALSE;
1316   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1317   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1318   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1319   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1320   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1321 #if defined(PERL_IMPLICIT_CONTEXT)
1322   pTHX;
1323 #endif
1324 #if defined(USE_ITHREADS)
1325   static perl_mutex primenv_mutex;
1326   MUTEX_INIT(&primenv_mutex);
1327 #endif
1328
1329 #if defined(PERL_IMPLICIT_CONTEXT)
1330     /* We jump through these hoops because we can be called at */
1331     /* platform-specific initialization time, which is before anything is */
1332     /* set up--we can't even do a plain dTHX since that relies on the */
1333     /* interpreter structure to be initialized */
1334     if (PL_curinterp) {
1335       aTHX = PERL_GET_INTERP;
1336     } else {
1337       aTHX = NULL;
1338     }
1339 #endif
1340
1341   if (primed || !PL_envgv) return;
1342   MUTEX_LOCK(&primenv_mutex);
1343   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1344   envhv = GvHVn(PL_envgv);
1345   /* Perform a dummy fetch as an lval to insure that the hash table is
1346    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1347   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1348
1349   for (i = 0; env_tables[i]; i++) {
1350      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1351          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1352      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1353   }
1354   if (have_sym || have_lnm) {
1355     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1356     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1357     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1358     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1359   }
1360
1361   for (i--; i >= 0; i--) {
1362     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1363       char *start;
1364       int j;
1365       for (j = 0; environ[j]; j++) {
1366         if (!(start = strchr(environ[j],'='))) {
1367           if (ckWARN(WARN_INTERNAL))
1368             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1369         }
1370         else {
1371           start++;
1372           sv = newSVpv(start,0);
1373           SvTAINTED_on(sv);
1374           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1375         }
1376       }
1377       continue;
1378     }
1379     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1380              !str$case_blind_compare(&tmpdsc,&clisym)) {
1381       strcpy(cmd,"Show Symbol/Global *");
1382       cmddsc.dsc$w_length = 20;
1383       if (env_tables[i]->dsc$w_length == 12 &&
1384           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1385           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1386       flags = defflags | CLI$M_NOLOGNAM;
1387     }
1388     else {
1389       strcpy(cmd,"Show Logical *");
1390       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1391         strcat(cmd," /Table=");
1392         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1393         cmddsc.dsc$w_length = strlen(cmd);
1394       }
1395       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1396       flags = defflags | CLI$M_NOCLISYM;
1397     }
1398
1399     /* Create a new subprocess to execute each command, to exclude the
1400      * remote possibility that someone could subvert a mbx or file used
1401      * to write multiple commands to a single subprocess.
1402      */
1403     do {
1404       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1405                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1406       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1407       defflags &= ~CLI$M_TRUSTED;
1408     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1409     _ckvmssts(retsts);
1410     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1411     if (seenhv) SvREFCNT_dec(seenhv);
1412     seenhv = newHV();
1413     while (1) {
1414       char *cp1, *cp2, *key;
1415       unsigned long int sts, iosb[2], retlen, keylen;
1416       register U32 hash;
1417
1418       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1419       if (sts & 1) sts = iosb[0] & 0xffff;
1420       if (sts == SS$_ENDOFFILE) {
1421         int wakect = 0;
1422         while (substs == 0) { sys$hiber(); wakect++;}
1423         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1424         _ckvmssts(substs);
1425         break;
1426       }
1427       _ckvmssts(sts);
1428       retlen = iosb[0] >> 16;
1429       if (!retlen) continue;  /* blank line */
1430       buf[retlen] = '\0';
1431       if (iosb[1] != subpid) {
1432         if (iosb[1]) {
1433           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1434         }
1435         continue;
1436       }
1437       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1438         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1439
1440       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1441       if (*cp1 == '(' || /* Logical name table name */
1442           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1443       if (*cp1 == '"') cp1++;
1444       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1445       key = cp1;  keylen = cp2 - cp1;
1446       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1447       while (*cp2 && *cp2 != '=') cp2++;
1448       while (*cp2 && *cp2 == '=') cp2++;
1449       while (*cp2 && *cp2 == ' ') cp2++;
1450       if (*cp2 == '"') {  /* String translation; may embed "" */
1451         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1452         cp2++;  cp1--; /* Skip "" surrounding translation */
1453       }
1454       else {  /* Numeric translation */
1455         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1456         cp1--;  /* stop on last non-space char */
1457       }
1458       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1459         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1460         continue;
1461       }
1462       PERL_HASH(hash,key,keylen);
1463
1464       if (cp1 == cp2 && *cp2 == '.') {
1465         /* A single dot usually means an unprintable character, such as a null
1466          * to indicate a zero-length value.  Get the actual value to make sure.
1467          */
1468         char lnm[LNM$C_NAMLENGTH+1];
1469         char eqv[MAX_DCL_SYMBOL+1];
1470         int trnlen;
1471         strncpy(lnm, key, keylen);
1472         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1473         sv = newSVpvn(eqv, strlen(eqv));
1474       }
1475       else {
1476         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1477       }
1478
1479       SvTAINTED_on(sv);
1480       hv_store(envhv,key,keylen,sv,hash);
1481       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1482     }
1483     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1484       /* get the PPFs for this process, not the subprocess */
1485       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1486       char eqv[LNM$C_NAMLENGTH+1];
1487       int trnlen, i;
1488       for (i = 0; ppfs[i]; i++) {
1489         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1490         sv = newSVpv(eqv,trnlen);
1491         SvTAINTED_on(sv);
1492         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1493       }
1494     }
1495   }
1496   primed = 1;
1497   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1498   if (buf) Safefree(buf);
1499   if (seenhv) SvREFCNT_dec(seenhv);
1500   MUTEX_UNLOCK(&primenv_mutex);
1501   return;
1502
1503 }  /* end of prime_env_iter */
1504 /*}}}*/
1505
1506
1507 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1508 /* Define or delete an element in the same "environment" as
1509  * vmstrnenv().  If an element is to be deleted, it's removed from
1510  * the first place it's found.  If it's to be set, it's set in the
1511  * place designated by the first element of the table vector.
1512  * Like setenv() returns 0 for success, non-zero on error.
1513  */
1514 int
1515 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1516 {
1517     const char *cp1;
1518     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1519     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1520     int nseg = 0, j;
1521     unsigned long int retsts, usermode = PSL$C_USER;
1522     struct itmlst_3 *ile, *ilist;
1523     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1524                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1525                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1526     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1527     $DESCRIPTOR(local,"_LOCAL");
1528
1529     if (!lnm) {
1530         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1531         return SS$_IVLOGNAM;
1532     }
1533
1534     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1535       *cp2 = _toupper(*cp1);
1536       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1537         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1538         return SS$_IVLOGNAM;
1539       }
1540     }
1541     lnmdsc.dsc$w_length = cp1 - lnm;
1542     if (!tabvec || !*tabvec) tabvec = env_tables;
1543
1544     if (!eqv) {  /* we're deleting n element */
1545       for (curtab = 0; tabvec[curtab]; curtab++) {
1546         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1547         int i;
1548           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1549             if ((cp1 = strchr(environ[i],'=')) &&
1550                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1551                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1552 #ifdef HAS_SETENV
1553               return setenv(lnm,"",1) ? vaxc$errno : 0;
1554             }
1555           }
1556           ivenv = 1; retsts = SS$_NOLOGNAM;
1557 #else
1558               if (ckWARN(WARN_INTERNAL))
1559                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1560               ivenv = 1; retsts = SS$_NOSUCHPGM;
1561               break;
1562             }
1563           }
1564 #endif
1565         }
1566         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1567                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1568           unsigned int symtype;
1569           if (tabvec[curtab]->dsc$w_length == 12 &&
1570               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1571               !str$case_blind_compare(&tmpdsc,&local))
1572             symtype = LIB$K_CLI_LOCAL_SYM;
1573           else symtype = LIB$K_CLI_GLOBAL_SYM;
1574           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1575           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1576           if (retsts == LIB$_NOSUCHSYM) continue;
1577           break;
1578         }
1579         else if (!ivlnm) {
1580           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1581           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1582           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1583           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1584           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1585         }
1586       }
1587     }
1588     else {  /* we're defining a value */
1589       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1590 #ifdef HAS_SETENV
1591         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1592 #else
1593         if (ckWARN(WARN_INTERNAL))
1594           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1595         retsts = SS$_NOSUCHPGM;
1596 #endif
1597       }
1598       else {
1599         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1600         eqvdsc.dsc$w_length  = strlen(eqv);
1601         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1602             !str$case_blind_compare(&tmpdsc,&clisym)) {
1603           unsigned int symtype;
1604           if (tabvec[0]->dsc$w_length == 12 &&
1605               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1606                !str$case_blind_compare(&tmpdsc,&local))
1607             symtype = LIB$K_CLI_LOCAL_SYM;
1608           else symtype = LIB$K_CLI_GLOBAL_SYM;
1609           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1610         }
1611         else {
1612           if (!*eqv) eqvdsc.dsc$w_length = 1;
1613           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1614
1615             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1616             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1617               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1618                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1619               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1620               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1621             }
1622
1623             Newx(ilist,nseg+1,struct itmlst_3);
1624             ile = ilist;
1625             if (!ile) {
1626               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1627               return SS$_INSFMEM;
1628             }
1629             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1630
1631             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1632               ile->itmcode = LNM$_STRING;
1633               ile->bufadr = c;
1634               if ((j+1) == nseg) {
1635                 ile->buflen = strlen(c);
1636                 /* in case we are truncating one that's too long */
1637                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1638               }
1639               else {
1640                 ile->buflen = LNM$C_NAMLENGTH;
1641               }
1642             }
1643
1644             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1645             Safefree (ilist);
1646           }
1647           else {
1648             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1649           }
1650         }
1651       }
1652     }
1653     if (!(retsts & 1)) {
1654       switch (retsts) {
1655         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1656         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1657           set_errno(EVMSERR); break;
1658         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1659         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1660           set_errno(EINVAL); break;
1661         case SS$_NOPRIV:
1662           set_errno(EACCES); break;
1663         default:
1664           _ckvmssts(retsts);
1665           set_errno(EVMSERR);
1666        }
1667        set_vaxc_errno(retsts);
1668        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1669     }
1670     else {
1671       /* We reset error values on success because Perl does an hv_fetch()
1672        * before each hv_store(), and if the thing we're setting didn't
1673        * previously exist, we've got a leftover error message.  (Of course,
1674        * this fails in the face of
1675        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1676        * in that the error reported in $! isn't spurious,
1677        * but it's right more often than not.)
1678        */
1679       set_errno(0); set_vaxc_errno(retsts);
1680       return 0;
1681     }
1682
1683 }  /* end of vmssetenv() */
1684 /*}}}*/
1685
1686 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1687 /* This has to be a function since there's a prototype for it in proto.h */
1688 void
1689 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1690 {
1691     if (lnm && *lnm) {
1692       int len = strlen(lnm);
1693       if  (len == 7) {
1694         char uplnm[8];
1695         int i;
1696         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1697         if (!strcmp(uplnm,"DEFAULT")) {
1698           if (eqv && *eqv) my_chdir(eqv);
1699           return;
1700         }
1701     }
1702 #ifndef RTL_USES_UTC
1703     if (len == 6 || len == 2) {
1704       char uplnm[7];
1705       int i;
1706       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1707       uplnm[len] = '\0';
1708       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1709       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1710     }
1711 #endif
1712   }
1713   (void) vmssetenv(lnm,eqv,NULL);
1714 }
1715 /*}}}*/
1716
1717 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1718 /*  vmssetuserlnm
1719  *  sets a user-mode logical in the process logical name table
1720  *  used for redirection of sys$error
1721  */
1722 void
1723 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1724 {
1725     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1726     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1727     unsigned long int iss, attr = LNM$M_CONFINE;
1728     unsigned char acmode = PSL$C_USER;
1729     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1730                                  {0, 0, 0, 0}};
1731     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1732     d_name.dsc$w_length = strlen(name);
1733
1734     lnmlst[0].buflen = strlen(eqv);
1735     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1736
1737     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1738     if (!(iss&1)) lib$signal(iss);
1739 }
1740 /*}}}*/
1741
1742
1743 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1744 /* my_crypt - VMS password hashing
1745  * my_crypt() provides an interface compatible with the Unix crypt()
1746  * C library function, and uses sys$hash_password() to perform VMS
1747  * password hashing.  The quadword hashed password value is returned
1748  * as a NUL-terminated 8 character string.  my_crypt() does not change
1749  * the case of its string arguments; in order to match the behavior
1750  * of LOGINOUT et al., alphabetic characters in both arguments must
1751  *  be upcased by the caller.
1752  *
1753  * - fix me to call ACM services when available
1754  */
1755 char *
1756 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1757 {
1758 #   ifndef UAI$C_PREFERRED_ALGORITHM
1759 #     define UAI$C_PREFERRED_ALGORITHM 127
1760 #   endif
1761     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1762     unsigned short int salt = 0;
1763     unsigned long int sts;
1764     struct const_dsc {
1765         unsigned short int dsc$w_length;
1766         unsigned char      dsc$b_type;
1767         unsigned char      dsc$b_class;
1768         const char *       dsc$a_pointer;
1769     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1770        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1771     struct itmlst_3 uailst[3] = {
1772         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1773         { sizeof salt, UAI$_SALT,    &salt, 0},
1774         { 0,           0,            NULL,  NULL}};
1775     static char hash[9];
1776
1777     usrdsc.dsc$w_length = strlen(usrname);
1778     usrdsc.dsc$a_pointer = usrname;
1779     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1780       switch (sts) {
1781         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1782           set_errno(EACCES);
1783           break;
1784         case RMS$_RNF:
1785           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1786           break;
1787         default:
1788           set_errno(EVMSERR);
1789       }
1790       set_vaxc_errno(sts);
1791       if (sts != RMS$_RNF) return NULL;
1792     }
1793
1794     txtdsc.dsc$w_length = strlen(textpasswd);
1795     txtdsc.dsc$a_pointer = textpasswd;
1796     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1797       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1798     }
1799
1800     return (char *) hash;
1801
1802 }  /* end of my_crypt() */
1803 /*}}}*/
1804
1805
1806 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1807 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1808 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1809
1810 /* fixup barenames that are directories for internal use.
1811  * There have been problems with the consistent handling of UNIX
1812  * style directory names when routines are presented with a name that
1813  * has no directory delimitors at all.  So this routine will eventually
1814  * fix the issue.
1815  */
1816 static char * fixup_bare_dirnames(const char * name)
1817 {
1818   if (decc_disable_to_vms_logname_translation) {
1819 /* fix me */
1820   }
1821   return NULL;
1822 }
1823
1824 /* 8.3, remove() is now broken on symbolic links */
1825 static int rms_erase(const char * vmsname);
1826
1827
1828 /* mp_do_kill_file
1829  * A little hack to get around a bug in some implemenation of remove()
1830  * that do not know how to delete a directory
1831  *
1832  * Delete any file to which user has control access, regardless of whether
1833  * delete access is explicitly allowed.
1834  * Limitations: User must have write access to parent directory.
1835  *              Does not block signals or ASTs; if interrupted in midstream
1836  *              may leave file with an altered ACL.
1837  * HANDLE WITH CARE!
1838  */
1839 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1840 static int
1841 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1842 {
1843     char *vmsname;
1844     char *rslt;
1845     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1846     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1847     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1848     struct myacedef {
1849       unsigned char myace$b_length;
1850       unsigned char myace$b_type;
1851       unsigned short int myace$w_flags;
1852       unsigned long int myace$l_access;
1853       unsigned long int myace$l_ident;
1854     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1855                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1856       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1857      struct itmlst_3
1858        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1859                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1860        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1861        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1862        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1863        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1864
1865     /* Expand the input spec using RMS, since the CRTL remove() and
1866      * system services won't do this by themselves, so we may miss
1867      * a file "hiding" behind a logical name or search list. */
1868     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1869     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1870
1871     rslt = do_rmsexpand(name,
1872                         vmsname,
1873                         0,
1874                         NULL,
1875                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
1876                         NULL,
1877                         NULL);
1878     if (rslt == NULL) {
1879         PerlMem_free(vmsname);
1880         return -1;
1881       }
1882
1883     /* Erase the file */
1884     rmsts = rms_erase(vmsname);
1885
1886     /* Did it succeed */
1887     if ($VMS_STATUS_SUCCESS(rmsts)) {
1888         PerlMem_free(vmsname);
1889         return 0;
1890       }
1891
1892     /* If not, can changing protections help? */
1893     if (rmsts != RMS$_PRV) {
1894       set_vaxc_errno(rmsts);
1895       PerlMem_free(vmsname);
1896       return -1;
1897     }
1898
1899     /* No, so we get our own UIC to use as a rights identifier,
1900      * and the insert an ACE at the head of the ACL which allows us
1901      * to delete the file.
1902      */
1903     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1904     fildsc.dsc$w_length = strlen(vmsname);
1905     fildsc.dsc$a_pointer = vmsname;
1906     cxt = 0;
1907     newace.myace$l_ident = oldace.myace$l_ident;
1908     rmsts = -1;
1909     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1910       switch (aclsts) {
1911         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1912           set_errno(ENOENT); break;
1913         case RMS$_DIR:
1914           set_errno(ENOTDIR); break;
1915         case RMS$_DEV:
1916           set_errno(ENODEV); break;
1917         case RMS$_SYN: case SS$_INVFILFOROP:
1918           set_errno(EINVAL); break;
1919         case RMS$_PRV:
1920           set_errno(EACCES); break;
1921         default:
1922           _ckvmssts(aclsts);
1923       }
1924       set_vaxc_errno(aclsts);
1925       PerlMem_free(vmsname);
1926       return -1;
1927     }
1928     /* Grab any existing ACEs with this identifier in case we fail */
1929     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1930     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1931                     || fndsts == SS$_NOMOREACE ) {
1932       /* Add the new ACE . . . */
1933       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1934         goto yourroom;
1935
1936       rmsts = rms_erase(vmsname);
1937       if ($VMS_STATUS_SUCCESS(rmsts)) {
1938         rmsts = 0;
1939         }
1940         else {
1941         rmsts = -1;
1942         /* We blew it - dir with files in it, no write priv for
1943          * parent directory, etc.  Put things back the way they were. */
1944         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1945           goto yourroom;
1946         if (fndsts & 1) {
1947           addlst[0].bufadr = &oldace;
1948           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1949             goto yourroom;
1950         }
1951       }
1952     }
1953
1954     yourroom:
1955     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1956     /* We just deleted it, so of course it's not there.  Some versions of
1957      * VMS seem to return success on the unlock operation anyhow (after all
1958      * the unlock is successful), but others don't.
1959      */
1960     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1961     if (aclsts & 1) aclsts = fndsts;
1962     if (!(aclsts & 1)) {
1963       set_errno(EVMSERR);
1964       set_vaxc_errno(aclsts);
1965     }
1966
1967     PerlMem_free(vmsname);
1968     return rmsts;
1969
1970 }  /* end of kill_file() */
1971 /*}}}*/
1972
1973
1974 /*{{{int do_rmdir(char *name)*/
1975 int
1976 Perl_do_rmdir(pTHX_ const char *name)
1977 {
1978     char * dirfile;
1979     int retval;
1980     Stat_t st;
1981
1982     dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
1983     if (dirfile == NULL)
1984         _ckvmssts(SS$_INSFMEM);
1985
1986     /* Force to a directory specification */
1987     if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
1988         PerlMem_free(dirfile);
1989         return -1;
1990     }
1991     if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
1992         errno = ENOTDIR;
1993         retval = -1;
1994     }
1995     else
1996         retval = mp_do_kill_file(aTHX_ dirfile, 1);
1997
1998     PerlMem_free(dirfile);
1999     return retval;
2000
2001 }  /* end of do_rmdir */
2002 /*}}}*/
2003
2004 /* kill_file
2005  * Delete any file to which user has control access, regardless of whether
2006  * delete access is explicitly allowed.
2007  * Limitations: User must have write access to parent directory.
2008  *              Does not block signals or ASTs; if interrupted in midstream
2009  *              may leave file with an altered ACL.
2010  * HANDLE WITH CARE!
2011  */
2012 /*{{{int kill_file(char *name)*/
2013 int
2014 Perl_kill_file(pTHX_ const char *name)
2015 {
2016     char rspec[NAM$C_MAXRSS+1];
2017     char *tspec;
2018     Stat_t st;
2019     int rmsts;
2020
2021    /* Remove() is allowed to delete directories, according to the X/Open
2022     * specifications.
2023     * This may need special handling to work with the ACL hacks.
2024      */
2025    if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
2026         rmsts = Perl_do_rmdir(aTHX_ name);
2027         return rmsts;
2028     }
2029
2030    rmsts = mp_do_kill_file(aTHX_ name, 0);
2031
2032     return rmsts;
2033
2034 }  /* end of kill_file() */
2035 /*}}}*/
2036
2037
2038 /*{{{int my_mkdir(char *,Mode_t)*/
2039 int
2040 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2041 {
2042   STRLEN dirlen = strlen(dir);
2043
2044   /* zero length string sometimes gives ACCVIO */
2045   if (dirlen == 0) return -1;
2046
2047   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2048    * null file name/type.  However, it's commonplace under Unix,
2049    * so we'll allow it for a gain in portability.
2050    */
2051   if (dir[dirlen-1] == '/') {
2052     char *newdir = savepvn(dir,dirlen-1);
2053     int ret = mkdir(newdir,mode);
2054     Safefree(newdir);
2055     return ret;
2056   }
2057   else return mkdir(dir,mode);
2058 }  /* end of my_mkdir */
2059 /*}}}*/
2060
2061 /*{{{int my_chdir(char *)*/
2062 int
2063 Perl_my_chdir(pTHX_ const char *dir)
2064 {
2065   STRLEN dirlen = strlen(dir);
2066
2067   /* zero length string sometimes gives ACCVIO */
2068   if (dirlen == 0) return -1;
2069   const char *dir1;
2070
2071   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2072    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2073    * so that existing scripts do not need to be changed.
2074    */
2075   dir1 = dir;
2076   while ((dirlen > 0) && (*dir1 == ' ')) {
2077     dir1++;
2078     dirlen--;
2079   }
2080
2081   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2082    * that implies
2083    * null file name/type.  However, it's commonplace under Unix,
2084    * so we'll allow it for a gain in portability.
2085    *
2086    * - Preview- '/' will be valid soon on VMS
2087    */
2088   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2089     char *newdir = savepvn(dir1,dirlen-1);
2090     int ret = chdir(newdir);
2091     Safefree(newdir);
2092     return ret;
2093   }
2094   else return chdir(dir1);
2095 }  /* end of my_chdir */
2096 /*}}}*/
2097
2098
2099 /*{{{int my_chmod(char *, mode_t)*/
2100 int
2101 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2102 {
2103   STRLEN speclen = strlen(file_spec);
2104
2105   /* zero length string sometimes gives ACCVIO */
2106   if (speclen == 0) return -1;
2107
2108   /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2109    * that implies null file name/type.  However, it's commonplace under Unix,
2110    * so we'll allow it for a gain in portability.
2111    *
2112    * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2113    * in VMS file.dir notation.
2114    */
2115   if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2116     char *vms_src, *vms_dir, *rslt;
2117     int ret = -1;
2118     errno = EIO;
2119
2120     /* First convert this to a VMS format specification */
2121     vms_src = PerlMem_malloc(VMS_MAXRSS);
2122     if (vms_src == NULL)
2123         _ckvmssts(SS$_INSFMEM);
2124
2125     rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2126     if (rslt == NULL) {
2127         /* If we fail, then not a file specification */
2128         PerlMem_free(vms_src);
2129         errno = EIO;
2130         return -1;
2131     }
2132
2133     /* Now make it a directory spec so chmod is happy */
2134     vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2135     if (vms_dir == NULL)
2136         _ckvmssts(SS$_INSFMEM);
2137     rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2138     PerlMem_free(vms_src);
2139
2140     /* Now do it */
2141     if (rslt != NULL) {
2142         ret = chmod(vms_dir, mode);
2143     } else {
2144         errno = EIO;
2145     }
2146     PerlMem_free(vms_dir);
2147     return ret;
2148   }
2149   else return chmod(file_spec, mode);
2150 }  /* end of my_chmod */
2151 /*}}}*/
2152
2153
2154 /*{{{FILE *my_tmpfile()*/
2155 FILE *
2156 my_tmpfile(void)
2157 {
2158   FILE *fp;
2159   char *cp;
2160
2161   if ((fp = tmpfile())) return fp;
2162
2163   cp = PerlMem_malloc(L_tmpnam+24);
2164   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2165
2166   if (decc_filename_unix_only == 0)
2167     strcpy(cp,"Sys$Scratch:");
2168   else
2169     strcpy(cp,"/tmp/");
2170   tmpnam(cp+strlen(cp));
2171   strcat(cp,".Perltmp");
2172   fp = fopen(cp,"w+","fop=dlt");
2173   PerlMem_free(cp);
2174   return fp;
2175 }
2176 /*}}}*/
2177
2178
2179 #ifndef HOMEGROWN_POSIX_SIGNALS
2180 /*
2181  * The C RTL's sigaction fails to check for invalid signal numbers so we
2182  * help it out a bit.  The docs are correct, but the actual routine doesn't
2183  * do what the docs say it will.
2184  */
2185 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2186 int
2187 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2188                    struct sigaction* oact)
2189 {
2190   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2191         SETERRNO(EINVAL, SS$_INVARG);
2192         return -1;
2193   }
2194   return sigaction(sig, act, oact);
2195 }
2196 /*}}}*/
2197 #endif
2198
2199 #ifdef KILL_BY_SIGPRC
2200 #include <errnodef.h>
2201
2202 /* We implement our own kill() using the undocumented system service
2203    sys$sigprc for one of two reasons:
2204
2205    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2206    target process to do a sys$exit, which usually can't be handled
2207    gracefully...certainly not by Perl and the %SIG{} mechanism.
2208
2209    2.) If the kill() in the CRTL can't be called from a signal
2210    handler without disappearing into the ether, i.e., the signal
2211    it purportedly sends is never trapped. Still true as of VMS 7.3.
2212
2213    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2214    in the target process rather than calling sys$exit.
2215
2216    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2217    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2218    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2219    with condition codes C$_SIG0+nsig*8, catching the exception on the
2220    target process and resignaling with appropriate arguments.
2221
2222    But we don't have that VMS 7.0+ exception handler, so if you
2223    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2224
2225    Also note that SIGTERM is listed in the docs as being "unimplemented",
2226    yet always seems to be signaled with a VMS condition code of 4 (and
2227    correctly handled for that code).  So we hardwire it in.
2228
2229    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2230    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2231    than signalling with an unrecognized (and unhandled by CRTL) code.
2232 */
2233
2234 #define _MY_SIG_MAX 28
2235
2236 static unsigned int
2237 Perl_sig_to_vmscondition_int(int sig)
2238 {
2239     static unsigned int sig_code[_MY_SIG_MAX+1] =
2240     {
2241         0,                  /*  0 ZERO     */
2242         SS$_HANGUP,         /*  1 SIGHUP   */
2243         SS$_CONTROLC,       /*  2 SIGINT   */
2244         SS$_CONTROLY,       /*  3 SIGQUIT  */
2245         SS$_RADRMOD,        /*  4 SIGILL   */
2246         SS$_BREAK,          /*  5 SIGTRAP  */
2247         SS$_OPCCUS,         /*  6 SIGABRT  */
2248         SS$_COMPAT,         /*  7 SIGEMT   */
2249 #ifdef __VAX
2250         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2251 #else
2252         SS$_HPARITH,        /*  8 SIGFPE AXP */
2253 #endif
2254         SS$_ABORT,          /*  9 SIGKILL  */
2255         SS$_ACCVIO,         /* 10 SIGBUS   */
2256         SS$_ACCVIO,         /* 11 SIGSEGV  */
2257         SS$_BADPARAM,       /* 12 SIGSYS   */
2258         SS$_NOMBX,          /* 13 SIGPIPE  */
2259         SS$_ASTFLT,         /* 14 SIGALRM  */
2260         4,                  /* 15 SIGTERM  */
2261         0,                  /* 16 SIGUSR1  */
2262         0,                  /* 17 SIGUSR2  */
2263         0,                  /* 18 */
2264         0,                  /* 19 */
2265         0,                  /* 20 SIGCHLD  */
2266         0,                  /* 21 SIGCONT  */
2267         0,                  /* 22 SIGSTOP  */
2268         0,                  /* 23 SIGTSTP  */
2269         0,                  /* 24 SIGTTIN  */
2270         0,                  /* 25 SIGTTOU  */
2271         0,                  /* 26 */
2272         0,                  /* 27 */
2273         0                   /* 28 SIGWINCH  */
2274     };
2275
2276 #if __VMS_VER >= 60200000
2277     static int initted = 0;
2278     if (!initted) {
2279         initted = 1;
2280         sig_code[16] = C$_SIGUSR1;
2281         sig_code[17] = C$_SIGUSR2;
2282 #if __CRTL_VER >= 70000000
2283         sig_code[20] = C$_SIGCHLD;
2284 #endif
2285 #if __CRTL_VER >= 70300000
2286         sig_code[28] = C$_SIGWINCH;
2287 #endif
2288     }
2289 #endif
2290
2291     if (sig < _SIG_MIN) return 0;
2292     if (sig > _MY_SIG_MAX) return 0;
2293     return sig_code[sig];
2294 }
2295
2296 unsigned int
2297 Perl_sig_to_vmscondition(int sig)
2298 {
2299 #ifdef SS$_DEBUG
2300     if (vms_debug_on_exception != 0)
2301         lib$signal(SS$_DEBUG);
2302 #endif
2303     return Perl_sig_to_vmscondition_int(sig);
2304 }
2305
2306
2307 int
2308 Perl_my_kill(int pid, int sig)
2309 {
2310     dTHX;
2311     int iss;
2312     unsigned int code;
2313     int sys$sigprc(unsigned int *pidadr,
2314                      struct dsc$descriptor_s *prcname,
2315                      unsigned int code);
2316
2317      /* sig 0 means validate the PID */
2318     /*------------------------------*/
2319     if (sig == 0) {
2320         const unsigned long int jpicode = JPI$_PID;
2321         pid_t ret_pid;
2322         int status;
2323         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2324         if ($VMS_STATUS_SUCCESS(status))
2325            return 0;
2326         switch (status) {
2327         case SS$_NOSUCHNODE:
2328         case SS$_UNREACHABLE:
2329         case SS$_NONEXPR:
2330            errno = ESRCH;
2331            break;
2332         case SS$_NOPRIV:
2333            errno = EPERM;
2334            break;
2335         default:
2336            errno = EVMSERR;
2337         }
2338         vaxc$errno=status;
2339         return -1;
2340     }
2341
2342     code = Perl_sig_to_vmscondition_int(sig);
2343
2344     if (!code) {
2345         SETERRNO(EINVAL, SS$_BADPARAM);
2346         return -1;
2347     }
2348
2349     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2350      * signals are to be sent to multiple processes.
2351      *  pid = 0 - all processes in group except ones that the system exempts
2352      *  pid = -1 - all processes except ones that the system exempts
2353      *  pid = -n - all processes in group (abs(n)) except ...
2354      * For now, just report as not supported.
2355      */
2356
2357     if (pid <= 0) {
2358         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2359         return -1;
2360     }
2361
2362     iss = sys$sigprc((unsigned int *)&pid,0,code);
2363     if (iss&1) return 0;
2364
2365     switch (iss) {
2366       case SS$_NOPRIV:
2367         set_errno(EPERM);  break;
2368       case SS$_NONEXPR:
2369       case SS$_NOSUCHNODE:
2370       case SS$_UNREACHABLE:
2371         set_errno(ESRCH);  break;
2372       case SS$_INSFMEM:
2373         set_errno(ENOMEM); break;
2374       default:
2375         _ckvmssts(iss);
2376         set_errno(EVMSERR);
2377     }
2378     set_vaxc_errno(iss);
2379
2380     return -1;
2381 }
2382 #endif
2383
2384 /* Routine to convert a VMS status code to a UNIX status code.
2385 ** More tricky than it appears because of conflicting conventions with
2386 ** existing code.
2387 **
2388 ** VMS status codes are a bit mask, with the least significant bit set for
2389 ** success.
2390 **
2391 ** Special UNIX status of EVMSERR indicates that no translation is currently
2392 ** available, and programs should check the VMS status code.
2393 **
2394 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2395 ** decoding.
2396 */
2397
2398 #ifndef C_FACILITY_NO
2399 #define C_FACILITY_NO 0x350000
2400 #endif
2401 #ifndef DCL_IVVERB
2402 #define DCL_IVVERB 0x38090
2403 #endif
2404
2405 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2406 {
2407 int facility;
2408 int fac_sp;
2409 int msg_no;
2410 int msg_status;
2411 int unix_status;
2412
2413   /* Assume the best or the worst */
2414   if (vms_status & STS$M_SUCCESS)
2415     unix_status = 0;
2416   else
2417     unix_status = EVMSERR;
2418
2419   msg_status = vms_status & ~STS$M_CONTROL;
2420
2421   facility = vms_status & STS$M_FAC_NO;
2422   fac_sp = vms_status & STS$M_FAC_SP;
2423   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2424
2425   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2426     switch(msg_no) {
2427     case SS$_NORMAL:
2428         unix_status = 0;
2429         break;
2430     case SS$_ACCVIO:
2431         unix_status = EFAULT;
2432         break;
2433     case SS$_DEVOFFLINE:
2434         unix_status = EBUSY;
2435         break;
2436     case SS$_CLEARED:
2437         unix_status = ENOTCONN;
2438         break;
2439     case SS$_IVCHAN:
2440     case SS$_IVLOGNAM:
2441     case SS$_BADPARAM:
2442     case SS$_IVLOGTAB:
2443     case SS$_NOLOGNAM:
2444     case SS$_NOLOGTAB:
2445     case SS$_INVFILFOROP:
2446     case SS$_INVARG:
2447     case SS$_NOSUCHID:
2448     case SS$_IVIDENT:
2449         unix_status = EINVAL;
2450         break;
2451     case SS$_UNSUPPORTED:
2452         unix_status = ENOTSUP;
2453         break;
2454     case SS$_FILACCERR:
2455     case SS$_NOGRPPRV:
2456     case SS$_NOSYSPRV:
2457         unix_status = EACCES;
2458         break;
2459     case SS$_DEVICEFULL:
2460         unix_status = ENOSPC;
2461         break;
2462     case SS$_NOSUCHDEV:
2463         unix_status = ENODEV;
2464         break;
2465     case SS$_NOSUCHFILE:
2466     case SS$_NOSUCHOBJECT:
2467         unix_status = ENOENT;
2468         break;
2469     case SS$_ABORT:                                 /* Fatal case */
2470     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2471     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2472         unix_status = EINTR;
2473         break;
2474     case SS$_BUFFEROVF:
2475         unix_status = E2BIG;
2476         break;
2477     case SS$_INSFMEM:
2478         unix_status = ENOMEM;
2479         break;
2480     case SS$_NOPRIV:
2481         unix_status = EPERM;
2482         break;
2483     case SS$_NOSUCHNODE:
2484     case SS$_UNREACHABLE:
2485         unix_status = ESRCH;
2486         break;
2487     case SS$_NONEXPR:
2488         unix_status = ECHILD;
2489         break;
2490     default:
2491         if ((facility == 0) && (msg_no < 8)) {
2492           /* These are not real VMS status codes so assume that they are
2493           ** already UNIX status codes
2494           */
2495           unix_status = msg_no;
2496           break;
2497         }
2498     }
2499   }
2500   else {
2501     /* Translate a POSIX exit code to a UNIX exit code */
2502     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2503         unix_status = (msg_no & 0x07F8) >> 3;
2504     }
2505     else {
2506
2507          /* Documented traditional behavior for handling VMS child exits */
2508         /*--------------------------------------------------------------*/
2509         if (child_flag != 0) {
2510
2511              /* Success / Informational return 0 */
2512             /*----------------------------------*/
2513             if (msg_no & STS$K_SUCCESS)
2514                 return 0;
2515
2516              /* Warning returns 1 */
2517             /*-------------------*/
2518             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2519                 return 1;
2520
2521              /* Everything else pass through the severity bits */
2522             /*------------------------------------------------*/
2523             return (msg_no & STS$M_SEVERITY);
2524         }
2525
2526          /* Normal VMS status to ERRNO mapping attempt */
2527         /*--------------------------------------------*/
2528         switch(msg_status) {
2529         /* case RMS$_EOF: */ /* End of File */
2530         case RMS$_FNF:  /* File Not Found */
2531         case RMS$_DNF:  /* Dir Not Found */
2532                 unix_status = ENOENT;
2533                 break;
2534         case RMS$_RNF:  /* Record Not Found */
2535                 unix_status = ESRCH;
2536                 break;
2537         case RMS$_DIR:
2538                 unix_status = ENOTDIR;
2539                 break;
2540         case RMS$_DEV:
2541                 unix_status = ENODEV;
2542                 break;
2543         case RMS$_IFI:
2544         case RMS$_FAC:
2545         case RMS$_ISI:
2546                 unix_status = EBADF;
2547                 break;
2548         case RMS$_FEX:
2549                 unix_status = EEXIST;
2550                 break;
2551         case RMS$_SYN:
2552         case RMS$_FNM:
2553         case LIB$_INVSTRDES:
2554         case LIB$_INVARG:
2555         case LIB$_NOSUCHSYM:
2556         case LIB$_INVSYMNAM:
2557         case DCL_IVVERB:
2558                 unix_status = EINVAL;
2559                 break;
2560         case CLI$_BUFOVF:
2561         case RMS$_RTB:
2562         case CLI$_TKNOVF:
2563         case CLI$_RSLOVF:
2564                 unix_status = E2BIG;
2565                 break;
2566         case RMS$_PRV:  /* No privilege */
2567         case RMS$_ACC:  /* ACP file access failed */
2568         case RMS$_WLK:  /* Device write locked */
2569                 unix_status = EACCES;
2570                 break;
2571         case RMS$_MKD:  /* Failed to mark for delete */
2572                 unix_status = EPERM;
2573                 break;
2574         /* case RMS$_NMF: */  /* No more files */
2575         }
2576     }
2577   }
2578
2579   return unix_status;
2580 }
2581
2582 /* Try to guess at what VMS error status should go with a UNIX errno
2583  * value.  This is hard to do as there could be many possible VMS
2584  * error statuses that caused the errno value to be set.
2585  */
2586
2587 int Perl_unix_status_to_vms(int unix_status)
2588 {
2589 int test_unix_status;
2590
2591      /* Trivial cases first */
2592     /*---------------------*/
2593     if (unix_status == EVMSERR)
2594         return vaxc$errno;
2595
2596      /* Is vaxc$errno sane? */
2597     /*---------------------*/
2598     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2599     if (test_unix_status == unix_status)
2600         return vaxc$errno;
2601
2602      /* If way out of range, must be VMS code already */
2603     /*-----------------------------------------------*/
2604     if (unix_status > EVMSERR)
2605         return unix_status;
2606
2607      /* If out of range, punt */
2608     /*-----------------------*/
2609     if (unix_status > __ERRNO_MAX)
2610         return SS$_ABORT;
2611
2612
2613      /* Ok, now we have to do it the hard way. */
2614     /*----------------------------------------*/
2615     switch(unix_status) {
2616     case 0:     return SS$_NORMAL;
2617     case EPERM: return SS$_NOPRIV;
2618     case ENOENT: return SS$_NOSUCHOBJECT;
2619     case ESRCH: return SS$_UNREACHABLE;
2620     case EINTR: return SS$_ABORT;
2621     /* case EIO: */
2622     /* case ENXIO:  */
2623     case E2BIG: return SS$_BUFFEROVF;
2624     /* case ENOEXEC */
2625     case EBADF: return RMS$_IFI;
2626     case ECHILD: return SS$_NONEXPR;
2627     /* case EAGAIN */
2628     case ENOMEM: return SS$_INSFMEM;
2629     case EACCES: return SS$_FILACCERR;
2630     case EFAULT: return SS$_ACCVIO;
2631     /* case ENOTBLK */
2632     case EBUSY: return SS$_DEVOFFLINE;
2633     case EEXIST: return RMS$_FEX;
2634     /* case EXDEV */
2635     case ENODEV: return SS$_NOSUCHDEV;
2636     case ENOTDIR: return RMS$_DIR;
2637     /* case EISDIR */
2638     case EINVAL: return SS$_INVARG;
2639     /* case ENFILE */
2640     /* case EMFILE */
2641     /* case ENOTTY */
2642     /* case ETXTBSY */
2643     /* case EFBIG */
2644     case ENOSPC: return SS$_DEVICEFULL;
2645     case ESPIPE: return LIB$_INVARG;
2646     /* case EROFS: */
2647     /* case EMLINK: */
2648     /* case EPIPE: */
2649     /* case EDOM */
2650     case ERANGE: return LIB$_INVARG;
2651     /* case EWOULDBLOCK */
2652     /* case EINPROGRESS */
2653     /* case EALREADY */
2654     /* case ENOTSOCK */
2655     /* case EDESTADDRREQ */
2656     /* case EMSGSIZE */
2657     /* case EPROTOTYPE */
2658     /* case ENOPROTOOPT */
2659     /* case EPROTONOSUPPORT */
2660     /* case ESOCKTNOSUPPORT */
2661     /* case EOPNOTSUPP */
2662     /* case EPFNOSUPPORT */
2663     /* case EAFNOSUPPORT */
2664     /* case EADDRINUSE */
2665     /* case EADDRNOTAVAIL */
2666     /* case ENETDOWN */
2667     /* case ENETUNREACH */
2668     /* case ENETRESET */
2669     /* case ECONNABORTED */
2670     /* case ECONNRESET */
2671     /* case ENOBUFS */
2672     /* case EISCONN */
2673     case ENOTCONN: return SS$_CLEARED;
2674     /* case ESHUTDOWN */
2675     /* case ETOOMANYREFS */
2676     /* case ETIMEDOUT */
2677     /* case ECONNREFUSED */
2678     /* case ELOOP */
2679     /* case ENAMETOOLONG */
2680     /* case EHOSTDOWN */
2681     /* case EHOSTUNREACH */
2682     /* case ENOTEMPTY */
2683     /* case EPROCLIM */
2684     /* case EUSERS  */
2685     /* case EDQUOT  */
2686     /* case ENOMSG  */
2687     /* case EIDRM */
2688     /* case EALIGN */
2689     /* case ESTALE */
2690     /* case EREMOTE */
2691     /* case ENOLCK */
2692     /* case ENOSYS */
2693     /* case EFTYPE */
2694     /* case ECANCELED */
2695     /* case EFAIL */
2696     /* case EINPROG */
2697     case ENOTSUP:
2698         return SS$_UNSUPPORTED;
2699     /* case EDEADLK */
2700     /* case ENWAIT */
2701     /* case EILSEQ */
2702     /* case EBADCAT */
2703     /* case EBADMSG */
2704     /* case EABANDONED */
2705     default:
2706         return SS$_ABORT; /* punt */
2707     }
2708
2709   return SS$_ABORT; /* Should not get here */
2710 }
2711
2712
2713 /* default piping mailbox size */
2714 #define PERL_BUFSIZ        512
2715
2716
2717 static void
2718 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2719 {
2720   unsigned long int mbxbufsiz;
2721   static unsigned long int syssize = 0;
2722   unsigned long int dviitm = DVI$_DEVNAM;
2723   char csize[LNM$C_NAMLENGTH+1];
2724   int sts;
2725
2726   if (!syssize) {
2727     unsigned long syiitm = SYI$_MAXBUF;
2728     /*
2729      * Get the SYSGEN parameter MAXBUF
2730      *
2731      * If the logical 'PERL_MBX_SIZE' is defined
2732      * use the value of the logical instead of PERL_BUFSIZ, but
2733      * keep the size between 128 and MAXBUF.
2734      *
2735      */
2736     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2737   }
2738
2739   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2740       mbxbufsiz = atoi(csize);
2741   } else {
2742       mbxbufsiz = PERL_BUFSIZ;
2743   }
2744   if (mbxbufsiz < 128) mbxbufsiz = 128;
2745   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2746
2747   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2748
2749   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2750   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2751
2752 }  /* end of create_mbx() */
2753
2754
2755 /*{{{  my_popen and my_pclose*/
2756
2757 typedef struct _iosb           IOSB;
2758 typedef struct _iosb*         pIOSB;
2759 typedef struct _pipe           Pipe;
2760 typedef struct _pipe*         pPipe;
2761 typedef struct pipe_details    Info;
2762 typedef struct pipe_details*  pInfo;
2763 typedef struct _srqp            RQE;
2764 typedef struct _srqp*          pRQE;
2765 typedef struct _tochildbuf      CBuf;
2766 typedef struct _tochildbuf*    pCBuf;
2767
2768 struct _iosb {
2769     unsigned short status;
2770     unsigned short count;
2771     unsigned long  dvispec;
2772 };
2773
2774 #pragma member_alignment save
2775 #pragma nomember_alignment quadword
2776 struct _srqp {          /* VMS self-relative queue entry */
2777     unsigned long qptr[2];
2778 };
2779 #pragma member_alignment restore
2780 static RQE  RQE_ZERO = {0,0};
2781
2782 struct _tochildbuf {
2783     RQE             q;
2784     int             eof;
2785     unsigned short  size;
2786     char            *buf;
2787 };
2788
2789 struct _pipe {
2790     RQE            free;
2791     RQE            wait;
2792     int            fd_out;
2793     unsigned short chan_in;
2794     unsigned short chan_out;
2795     char          *buf;
2796     unsigned int   bufsize;
2797     IOSB           iosb;
2798     IOSB           iosb2;
2799     int           *pipe_done;
2800     int            retry;
2801     int            type;
2802     int            shut_on_empty;
2803     int            need_wake;
2804     pPipe         *home;
2805     pInfo          info;
2806     pCBuf          curr;
2807     pCBuf          curr2;
2808 #if defined(PERL_IMPLICIT_CONTEXT)
2809     void            *thx;           /* Either a thread or an interpreter */
2810                                     /* pointer, depending on how we're built */
2811 #endif
2812 };
2813
2814
2815 struct pipe_details
2816 {
2817     pInfo           next;
2818     PerlIO *fp;  /* file pointer to pipe mailbox */
2819     int useFILE; /* using stdio, not perlio */
2820     int pid;   /* PID of subprocess */
2821     int mode;  /* == 'r' if pipe open for reading */
2822     int done;  /* subprocess has completed */
2823     int waiting; /* waiting for completion/closure */
2824     int             closing;        /* my_pclose is closing this pipe */
2825     unsigned long   completion;     /* termination status of subprocess */
2826     pPipe           in;             /* pipe in to sub */
2827     pPipe           out;            /* pipe out of sub */
2828     pPipe           err;            /* pipe of sub's sys$error */
2829     int             in_done;        /* true when in pipe finished */
2830     int             out_done;
2831     int             err_done;
2832     unsigned short  xchan;          /* channel to debug xterm */
2833     unsigned short  xchan_valid;    /* channel is assigned */
2834 };
2835
2836 struct exit_control_block
2837 {
2838     struct exit_control_block *flink;
2839     unsigned long int   (*exit_routine)();
2840     unsigned long int arg_count;
2841     unsigned long int *status_address;
2842     unsigned long int exit_status;
2843 };
2844
2845 typedef struct _closed_pipes    Xpipe;
2846 typedef struct _closed_pipes*  pXpipe;
2847
2848 struct _closed_pipes {
2849     int             pid;            /* PID of subprocess */
2850     unsigned long   completion;     /* termination status of subprocess */
2851 };
2852 #define NKEEPCLOSED 50
2853 static Xpipe closed_list[NKEEPCLOSED];
2854 static int   closed_index = 0;
2855 static int   closed_num = 0;
2856
2857 #define RETRY_DELAY     "0 ::0.20"
2858 #define MAX_RETRY              50
2859
2860 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2861 static unsigned long mypid;
2862 static unsigned long delaytime[2];
2863
2864 static pInfo open_pipes = NULL;
2865 static $DESCRIPTOR(nl_desc, "NL:");
2866
2867 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2868
2869
2870
2871 static unsigned long int
2872 pipe_exit_routine(pTHX)
2873 {
2874     pInfo info;
2875     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2876     int sts, did_stuff, need_eof, j;
2877
2878    /*
2879     * Flush any pending i/o, but since we are in process run-down, be
2880     * careful about referencing PerlIO structures that may already have
2881     * been deallocated.  We may not even have an interpreter anymore.
2882     */
2883     info = open_pipes;
2884     while (info) {
2885         if (info->fp) {
2886            if (!info->useFILE
2887 #if defined(USE_ITHREADS)
2888              && my_perl
2889 #endif
2890              && PL_perlio_fd_refcnt)
2891                PerlIO_flush(info->fp);
2892            else
2893                fflush((FILE *)info->fp);
2894         }
2895         info = info->next;
2896     }
2897
2898     /*
2899      next we try sending an EOF...ignore if doesn't work, make sure we
2900      don't hang
2901     */
2902     did_stuff = 0;
2903     info = open_pipes;
2904
2905     while (info) {
2906       int need_eof;
2907       _ckvmssts_noperl(sys$setast(0));
2908       if (info->in && !info->in->shut_on_empty) {
2909         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2910                           0, 0, 0, 0, 0, 0));
2911         info->waiting = 1;
2912         did_stuff = 1;
2913       }
2914       _ckvmssts_noperl(sys$setast(1));
2915       info = info->next;
2916     }
2917
2918     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2919
2920     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2921         int nwait = 0;
2922
2923         info = open_pipes;
2924         while (info) {
2925           _ckvmssts_noperl(sys$setast(0));
2926           if (info->waiting && info->done)
2927                 info->waiting = 0;
2928           nwait += info->waiting;
2929           _ckvmssts_noperl(sys$setast(1));
2930           info = info->next;
2931         }
2932         if (!nwait) break;
2933         sleep(1);
2934     }
2935
2936     did_stuff = 0;
2937     info = open_pipes;
2938     while (info) {
2939       _ckvmssts_noperl(sys$setast(0));
2940       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2941         sts = sys$forcex(&info->pid,0,&abort);
2942         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2943         did_stuff = 1;
2944       }
2945       _ckvmssts_noperl(sys$setast(1));
2946       info = info->next;
2947     }
2948
2949     /* again, wait for effect */
2950
2951     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2952         int nwait = 0;
2953
2954         info = open_pipes;
2955         while (info) {
2956           _ckvmssts_noperl(sys$setast(0));
2957           if (info->waiting && info->done)
2958                 info->waiting = 0;
2959           nwait += info->waiting;
2960           _ckvmssts_noperl(sys$setast(1));
2961           info = info->next;
2962         }
2963         if (!nwait) break;
2964         sleep(1);
2965     }
2966
2967     info = open_pipes;
2968     while (info) {
2969       _ckvmssts_noperl(sys$setast(0));
2970       if (!info->done) {  /* We tried to be nice . . . */
2971         sts = sys$delprc(&info->pid,0);
2972         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2973         info->done = 1;  /* sys$delprc is as done as we're going to get. */
2974       }
2975       _ckvmssts_noperl(sys$setast(1));
2976       info = info->next;
2977     }
2978
2979     while(open_pipes) {
2980       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2981       else if (!(sts & 1)) retsts = sts;
2982     }
2983     return retsts;
2984 }
2985
2986 static struct exit_control_block pipe_exitblock =
2987        {(struct exit_control_block *) 0,
2988         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2989
2990 static void pipe_mbxtofd_ast(pPipe p);
2991 static void pipe_tochild1_ast(pPipe p);
2992 static void pipe_tochild2_ast(pPipe p);
2993
2994 static void
2995 popen_completion_ast(pInfo info)
2996 {
2997   pInfo i = open_pipes;
2998   int iss;
2999   int sts;
3000   pXpipe x;
3001
3002   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3003   closed_list[closed_index].pid = info->pid;
3004   closed_list[closed_index].completion = info->completion;
3005   closed_index++;
3006   if (closed_index == NKEEPCLOSED)
3007     closed_index = 0;
3008   closed_num++;
3009
3010   while (i) {
3011     if (i == info) break;
3012     i = i->next;
3013   }
3014   if (!i) return;       /* unlinked, probably freed too */
3015
3016   info->done = TRUE;
3017
3018 /*
3019     Writing to subprocess ...
3020             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3021
3022             chan_out may be waiting for "done" flag, or hung waiting
3023             for i/o completion to child...cancel the i/o.  This will
3024             put it into "snarf mode" (done but no EOF yet) that discards
3025             input.
3026
3027     Output from subprocess (stdout, stderr) needs to be flushed and
3028     shut down.   We try sending an EOF, but if the mbx is full the pipe
3029     routine should still catch the "shut_on_empty" flag, telling it to
3030     use immediate-style reads so that "mbx empty" -> EOF.
3031
3032
3033 */
3034   if (info->in && !info->in_done) {               /* only for mode=w */
3035         if (info->in->shut_on_empty && info->in->need_wake) {
3036             info->in->need_wake = FALSE;
3037             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3038         } else {
3039             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3040         }
3041   }
3042
3043   if (info->out && !info->out_done) {             /* were we also piping output? */
3044       info->out->shut_on_empty = TRUE;
3045       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3046       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3047       _ckvmssts_noperl(iss);
3048   }
3049
3050   if (info->err && !info->err_done) {        /* we were piping stderr */
3051         info->err->shut_on_empty = TRUE;
3052         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3053         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3054         _ckvmssts_noperl(iss);
3055   }
3056   _ckvmssts_noperl(sys$setef(pipe_ef));
3057
3058 }
3059
3060 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3061 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3062
3063 /*
3064     we actually differ from vmstrnenv since we use this to
3065     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3066     are pointing to the same thing
3067 */
3068
3069 static unsigned short
3070 popen_translate(pTHX_ char *logical, char *result)
3071 {
3072     int iss;
3073     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3074     $DESCRIPTOR(d_log,"");
3075     struct _il3 {
3076         unsigned short length;
3077         unsigned short code;
3078         char *         buffer_addr;
3079         unsigned short *retlenaddr;
3080     } itmlst[2];
3081     unsigned short l, ifi;
3082
3083     d_log.dsc$a_pointer = logical;
3084     d_log.dsc$w_length  = strlen(logical);
3085
3086     itmlst[0].code = LNM$_STRING;
3087     itmlst[0].length = 255;
3088     itmlst[0].buffer_addr = result;
3089     itmlst[0].retlenaddr = &l;
3090
3091     itmlst[1].code = 0;
3092     itmlst[1].length = 0;
3093     itmlst[1].buffer_addr = 0;
3094     itmlst[1].retlenaddr = 0;
3095
3096     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3097     if (iss == SS$_NOLOGNAM) {
3098         iss = SS$_NORMAL;
3099         l = 0;
3100     }
3101     if (!(iss&1)) lib$signal(iss);
3102     result[l] = '\0';
3103 /*
3104     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3105     strip it off and return the ifi, if any
3106 */
3107     ifi  = 0;
3108     if (result[0] == 0x1b && result[1] == 0x00) {
3109         memmove(&ifi,result+2,2);
3110         strcpy(result,result+4);
3111     }
3112     return ifi;     /* this is the RMS internal file id */
3113 }
3114
3115 static void pipe_infromchild_ast(pPipe p);
3116
3117 /*
3118     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3119     inside an AST routine without worrying about reentrancy and which Perl
3120     memory allocator is being used.
3121
3122     We read data and queue up the buffers, then spit them out one at a
3123     time to the output mailbox when the output mailbox is ready for one.
3124
3125 */
3126 #define INITIAL_TOCHILDQUEUE  2
3127
3128 static pPipe
3129 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3130 {
3131     pPipe p;
3132     pCBuf b;
3133     char mbx1[64], mbx2[64];
3134     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3135                                       DSC$K_CLASS_S, mbx1},
3136                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3137                                       DSC$K_CLASS_S, mbx2};
3138     unsigned int dviitm = DVI$_DEVBUFSIZ;
3139     int j, n;
3140
3141     n = sizeof(Pipe);
3142     _ckvmssts(lib$get_vm(&n, &p));
3143
3144     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3145     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3146     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3147
3148     p->buf           = 0;
3149     p->shut_on_empty = FALSE;
3150     p->need_wake     = FALSE;
3151     p->type          = 0;
3152     p->retry         = 0;
3153     p->iosb.status   = SS$_NORMAL;
3154     p->iosb2.status  = SS$_NORMAL;
3155     p->free          = RQE_ZERO;
3156     p->wait          = RQE_ZERO;
3157     p->curr          = 0;
3158     p->curr2         = 0;
3159     p->info          = 0;
3160 #ifdef PERL_IMPLICIT_CONTEXT
3161     p->thx           = aTHX;
3162 #endif
3163
3164     n = sizeof(CBuf) + p->bufsize;
3165
3166     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3167         _ckvmssts(lib$get_vm(&n, &b));
3168         b->buf = (char *) b + sizeof(CBuf);
3169         _ckvmssts(lib$insqhi(b, &p->free));
3170     }
3171
3172     pipe_tochild2_ast(p);
3173     pipe_tochild1_ast(p);
3174     strcpy(wmbx, mbx1);
3175     strcpy(rmbx, mbx2);
3176     return p;
3177 }
3178
3179 /*  reads the MBX Perl is writing, and queues */
3180
3181 static void
3182 pipe_tochild1_ast(pPipe p)
3183 {
3184     pCBuf b = p->curr;
3185     int iss = p->iosb.status;
3186     int eof = (iss == SS$_ENDOFFILE);
3187     int sts;
3188 #ifdef PERL_IMPLICIT_CONTEXT
3189     pTHX = p->thx;
3190 #endif
3191
3192     if (p->retry) {
3193         if (eof) {
3194             p->shut_on_empty = TRUE;
3195             b->eof     = TRUE;
3196             _ckvmssts(sys$dassgn(p->chan_in));
3197         } else  {
3198             _ckvmssts(iss);
3199         }
3200
3201         b->eof  = eof;
3202         b->size = p->iosb.count;
3203         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3204         if (p->need_wake) {
3205             p->need_wake = FALSE;
3206             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3207         }
3208     } else {
3209         p->retry = 1;   /* initial call */
3210     }
3211
3212     if (eof) {                  /* flush the free queue, return when done */
3213         int n = sizeof(CBuf) + p->bufsize;
3214         while (1) {
3215             iss = lib$remqti(&p->free, &b);
3216             if (iss == LIB$_QUEWASEMP) return;
3217             _ckvmssts(iss);
3218             _ckvmssts(lib$free_vm(&n, &b));
3219         }
3220     }
3221
3222     iss = lib$remqti(&p->free, &b);
3223     if (iss == LIB$_QUEWASEMP) {
3224         int n = sizeof(CBuf) + p->bufsize;
3225         _ckvmssts(lib$get_vm(&n, &b));
3226         b->buf = (char *) b + sizeof(CBuf);
3227     } else {
3228        _ckvmssts(iss);
3229     }
3230
3231     p->curr = b;
3232     iss = sys$qio(0,p->chan_in,
3233              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3234              &p->iosb,
3235              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3236     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3237     _ckvmssts(iss);
3238 }
3239
3240
3241 /* writes queued buffers to output, waits for each to complete before
3242    doing the next */
3243
3244 static void
3245 pipe_tochild2_ast(pPipe p)
3246 {
3247     pCBuf b = p->curr2;
3248     int iss = p->iosb2.status;
3249     int n = sizeof(CBuf) + p->bufsize;
3250     int done = (p->info && p->info->done) ||
3251               iss == SS$_CANCEL || iss == SS$_ABORT;
3252 #if defined(PERL_IMPLICIT_CONTEXT)
3253     pTHX = p->thx;
3254 #endif
3255
3256     do {
3257         if (p->type) {         /* type=1 has old buffer, dispose */
3258             if (p->shut_on_empty) {
3259                 _ckvmssts(lib$free_vm(&n, &b));
3260             } else {
3261                 _ckvmssts(lib$insqhi(b, &p->free));
3262             }
3263             p->type = 0;
3264         }
3265
3266         iss = lib$remqti(&p->wait, &b);
3267         if (iss == LIB$_QUEWASEMP) {
3268             if (p->shut_on_empty) {
3269                 if (done) {
3270                     _ckvmssts(sys$dassgn(p->chan_out));
3271                     *p->pipe_done = TRUE;
3272                     _ckvmssts(sys$setef(pipe_ef));
3273                 } else {
3274                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3275                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3276                 }
3277                 return;
3278             }
3279             p->need_wake = TRUE;
3280             return;
3281         }
3282         _ckvmssts(iss);
3283         p->type = 1;
3284     } while (done);
3285
3286
3287     p->curr2 = b;
3288     if (b->eof) {
3289         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3290             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3291     } else {
3292         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3293             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3294     }
3295
3296     return;
3297
3298 }
3299
3300
3301 static pPipe
3302 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3303 {
3304     pPipe p;
3305     char mbx1[64], mbx2[64];
3306     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3307                                       DSC$K_CLASS_S, mbx1},
3308                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3309                                       DSC$K_CLASS_S, mbx2};
3310     unsigned int dviitm = DVI$_DEVBUFSIZ;
3311
3312     int n = sizeof(Pipe);
3313     _ckvmssts(lib$get_vm(&n, &p));
3314     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3315     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3316
3317     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3318     n = p->bufsize * sizeof(char);
3319     _ckvmssts(lib$get_vm(&n, &p->buf));
3320     p->shut_on_empty = FALSE;
3321     p->info   = 0;
3322     p->type   = 0;
3323     p->iosb.status = SS$_NORMAL;
3324 #if defined(PERL_IMPLICIT_CONTEXT)
3325     p->thx = aTHX;
3326 #endif
3327     pipe_infromchild_ast(p);
3328
3329     strcpy(wmbx, mbx1);
3330     strcpy(rmbx, mbx2);
3331     return p;
3332 }
3333
3334 static void
3335 pipe_infromchild_ast(pPipe p)
3336 {
3337     int iss = p->iosb.status;
3338     int eof = (iss == SS$_ENDOFFILE);
3339     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3340     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3341 #if defined(PERL_IMPLICIT_CONTEXT)
3342     pTHX = p->thx;
3343 #endif
3344
3345     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3346         _ckvmssts(sys$dassgn(p->chan_out));
3347         p->chan_out = 0;
3348     }
3349
3350     /* read completed:
3351             input shutdown if EOF from self (done or shut_on_empty)
3352             output shutdown if closing flag set (my_pclose)
3353             send data/eof from child or eof from self
3354             otherwise, re-read (snarf of data from child)
3355     */
3356
3357     if (p->type == 1) {
3358         p->type = 0;
3359         if (myeof && p->chan_in) {                  /* input shutdown */
3360             _ckvmssts(sys$dassgn(p->chan_in));
3361             p->chan_in = 0;
3362         }
3363
3364         if (p->chan_out) {
3365             if (myeof || kideof) {      /* pass EOF to parent */
3366                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3367                               pipe_infromchild_ast, p,
3368                               0, 0, 0, 0, 0, 0));
3369                 return;
3370             } else if (eof) {       /* eat EOF --- fall through to read*/
3371
3372             } else {                /* transmit data */
3373                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3374                               pipe_infromchild_ast,p,
3375                               p->buf, p->iosb.count, 0, 0, 0, 0));
3376                 return;
3377             }
3378         }
3379     }
3380
3381     /*  everything shut? flag as done */
3382
3383     if (!p->chan_in && !p->chan_out) {
3384         *p->pipe_done = TRUE;
3385         _ckvmssts(sys$setef(pipe_ef));
3386         return;
3387     }
3388
3389     /* write completed (or read, if snarfing from child)
3390             if still have input active,
3391                queue read...immediate mode if shut_on_empty so we get EOF if empty
3392             otherwise,
3393                check if Perl reading, generate EOFs as needed
3394     */
3395
3396     if (p->type == 0) {
3397         p->type = 1;
3398         if (p->chan_in) {
3399             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3400                           pipe_infromchild_ast,p,
3401                           p->buf, p->bufsize, 0, 0, 0, 0);
3402             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3403             _ckvmssts(iss);
3404         } else {           /* send EOFs for extra reads */
3405             p->iosb.status = SS$_ENDOFFILE;
3406             p->iosb.dvispec = 0;
3407             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3408                       0, 0, 0,
3409                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3410         }
3411     }
3412 }
3413
3414 static pPipe
3415 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3416 {
3417     pPipe p;
3418     char mbx[64];
3419     unsigned long dviitm = DVI$_DEVBUFSIZ;
3420     struct stat s;
3421     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3422                                       DSC$K_CLASS_S, mbx};
3423     int n = sizeof(Pipe);
3424
3425     /* things like terminals and mbx's don't need this filter */
3426     if (fd && fstat(fd,&s) == 0) {
3427         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3428         char device[65];
3429         unsigned short dev_len;
3430         struct dsc$descriptor_s d_dev;
3431         char * cptr;
3432         struct item_list_3 items[3];
3433         int status;
3434         unsigned short dvi_iosb[4];
3435
3436         cptr = getname(fd, out, 1);
3437         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3438         d_dev.dsc$a_pointer = out;
3439         d_dev.dsc$w_length = strlen(out);
3440         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3441         d_dev.dsc$b_class = DSC$K_CLASS_S;
3442
3443         items[0].len = 4;
3444         items[0].code = DVI$_DEVCHAR;
3445         items[0].bufadr = &devchar;
3446         items[0].retadr = NULL;
3447         items[1].len = 64;
3448         items[1].code = DVI$_FULLDEVNAM;
3449         items[1].bufadr = device;
3450         items[1].retadr = &dev_len;
3451         items[2].len = 0;
3452         items[2].code = 0;
3453
3454         status = sys$getdviw
3455                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3456         _ckvmssts(status);
3457         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3458             device[dev_len] = 0;
3459
3460             if (!(devchar & DEV$M_DIR)) {
3461                 strcpy(out, device);
3462                 return 0;
3463             }
3464         }
3465     }
3466
3467     _ckvmssts(lib$get_vm(&n, &p));
3468     p->fd_out = dup(fd);
3469     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3470     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3471     n = (p->bufsize+1) * sizeof(char);
3472     _ckvmssts(lib$get_vm(&n, &p->buf));
3473     p->shut_on_empty = FALSE;
3474     p->retry = 0;
3475     p->info  = 0;
3476     strcpy(out, mbx);
3477
3478     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3479                   pipe_mbxtofd_ast, p,
3480                   p->buf, p->bufsize, 0, 0, 0, 0));
3481
3482     return p;
3483 }
3484
3485 static void
3486 pipe_mbxtofd_ast(pPipe p)
3487 {
3488     int iss = p->iosb.status;
3489     int done = p->info->done;
3490     int iss2;
3491     int eof = (iss == SS$_ENDOFFILE);
3492     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3493     int err = !(iss&1) && !eof;
3494 #if defined(PERL_IMPLICIT_CONTEXT)
3495     pTHX = p->thx;
3496 #endif
3497
3498     if (done && myeof) {               /* end piping */
3499         close(p->fd_out);
3500         sys$dassgn(p->chan_in);
3501         *p->pipe_done = TRUE;
3502         _ckvmssts(sys$setef(pipe_ef));
3503         return;
3504     }
3505
3506     if (!err && !eof) {             /* good data to send to file */
3507         p->buf[p->iosb.count] = '\n';
3508         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3509         if (iss2 < 0) {
3510             p->retry++;
3511             if (p->retry < MAX_RETRY) {
3512                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3513                 return;
3514             }
3515         }
3516         p->retry = 0;
3517     } else if (err) {
3518         _ckvmssts(iss);
3519     }
3520
3521
3522     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3523           pipe_mbxtofd_ast, p,
3524           p->buf, p->bufsize, 0, 0, 0, 0);
3525     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3526     _ckvmssts(iss);
3527 }
3528
3529
3530 typedef struct _pipeloc     PLOC;
3531 typedef struct _pipeloc*   pPLOC;
3532
3533 struct _pipeloc {
3534     pPLOC   next;
3535     char    dir[NAM$C_MAXRSS+1];
3536 };
3537 static pPLOC  head_PLOC = 0;
3538
3539 void
3540 free_pipelocs(pTHX_ void *head)
3541 {
3542     pPLOC p, pnext;
3543     pPLOC *pHead = (pPLOC *)head;
3544
3545     p = *pHead;
3546     while (p) {
3547         pnext = p->next;
3548         PerlMem_free(p);
3549         p = pnext;
3550     }
3551     *pHead = 0;
3552 }
3553
3554 static void
3555 store_pipelocs(pTHX)
3556 {
3557     int    i;
3558     pPLOC  p;
3559     AV    *av = 0;
3560     SV    *dirsv;
3561     GV    *gv;
3562     char  *dir, *x;
3563     char  *unixdir;
3564     char  temp[NAM$C_MAXRSS+1];
3565     STRLEN n_a;
3566
3567     if (head_PLOC)
3568         free_pipelocs(aTHX_ &head_PLOC);
3569
3570 /*  the . directory from @INC comes last */
3571
3572     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3573     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3574     p->next = head_PLOC;
3575     head_PLOC = p;
3576     strcpy(p->dir,"./");
3577
3578 /*  get the directory from $^X */
3579
3580     unixdir = PerlMem_malloc(VMS_MAXRSS);
3581     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3582
3583 #ifdef PERL_IMPLICIT_CONTEXT
3584     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3585 #else
3586     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3587 #endif
3588         strcpy(temp, PL_origargv[0]);
3589         x = strrchr(temp,']');
3590         if (x == NULL) {
3591         x = strrchr(temp,'>');
3592           if (x == NULL) {
3593             /* It could be a UNIX path */
3594             x = strrchr(temp,'/');
3595           }
3596         }
3597         if (x)
3598           x[1] = '\0';
3599         else {
3600           /* Got a bare name, so use default directory */
3601           temp[0] = '.';
3602           temp[1] = '\0';
3603         }
3604
3605         if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3606             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3607             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3608             p->next = head_PLOC;
3609             head_PLOC = p;
3610             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3611             p->dir[NAM$C_MAXRSS] = '\0';
3612         }
3613     }
3614
3615 /*  reverse order of @INC entries, skip "." since entered above */
3616
3617 #ifdef PERL_IMPLICIT_CONTEXT
3618     if (aTHX)
3619 #endif
3620     if (PL_incgv) av = GvAVn(PL_incgv);
3621
3622     for (i = 0; av && i <= AvFILL(av); i++) {
3623         dirsv = *av_fetch(av,i,TRUE);
3624
3625         if (SvROK(dirsv)) continue;
3626         dir = SvPVx(dirsv,n_a);
3627         if (strcmp(dir,".") == 0) continue;
3628         if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3629             continue;
3630
3631         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3632         p->next = head_PLOC;
3633         head_PLOC = p;
3634         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3635         p->dir[NAM$C_MAXRSS] = '\0';
3636     }
3637
3638 /* most likely spot (ARCHLIB) put first in the list */
3639
3640 #ifdef ARCHLIB_EXP
3641     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3642         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3643         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3644         p->next = head_PLOC;
3645         head_PLOC = p;
3646         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3647         p->dir[NAM$C_MAXRSS] = '\0';
3648     }
3649 #endif
3650     PerlMem_free(unixdir);
3651 }
3652
3653 static I32
3654 Perl_cando_by_name_int
3655    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3656 #if !defined(PERL_IMPLICIT_CONTEXT)
3657 #define cando_by_name_int               Perl_cando_by_name_int
3658 #else
3659 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3660 #endif
3661
3662 static char *
3663 find_vmspipe(pTHX)
3664 {
3665     static int   vmspipe_file_status = 0;
3666     static char  vmspipe_file[NAM$C_MAXRSS+1];
3667
3668     /* already found? Check and use ... need read+execute permission */
3669
3670     if (vmspipe_file_status == 1) {
3671         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3672          && cando_by_name_int
3673            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3674             return vmspipe_file;
3675         }
3676         vmspipe_file_status = 0;
3677     }
3678
3679     /* scan through stored @INC, $^X */
3680
3681     if (vmspipe_file_status == 0) {
3682         char file[NAM$C_MAXRSS+1];
3683         pPLOC  p = head_PLOC;
3684
3685         while (p) {
3686             char * exp_res;
3687             int dirlen;
3688             strcpy(file, p->dir);
3689             dirlen = strlen(file);
3690             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3691             file[NAM$C_MAXRSS] = '\0';
3692             p = p->next;
3693
3694             exp_res = do_rmsexpand
3695                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3696             if (!exp_res) continue;
3697
3698             if (cando_by_name_int
3699                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3700              && cando_by_name_int
3701                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3702                 vmspipe_file_status = 1;
3703                 return vmspipe_file;
3704             }
3705         }
3706         vmspipe_file_status = -1;   /* failed, use tempfiles */
3707     }
3708
3709     return 0;
3710 }
3711
3712 static FILE *
3713 vmspipe_tempfile(pTHX)
3714 {
3715     char file[NAM$C_MAXRSS+1];
3716     FILE *fp;
3717     static int index = 0;
3718     Stat_t s0, s1;
3719     int cmp_result;
3720
3721     /* create a tempfile */
3722
3723     /* we can't go from   W, shr=get to  R, shr=get without
3724        an intermediate vulnerable state, so don't bother trying...
3725
3726        and lib$spawn doesn't shr=put, so have to close the write
3727
3728        So... match up the creation date/time and the FID to
3729        make sure we're dealing with the same file
3730
3731     */
3732
3733     index++;
3734     if (!decc_filename_unix_only) {
3735       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3736       fp = fopen(file,"w");
3737       if (!fp) {
3738         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3739         fp = fopen(file,"w");
3740         if (!fp) {
3741             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3742             fp = fopen(file,"w");
3743         }
3744       }
3745      }
3746      else {
3747       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3748       fp = fopen(file,"w");
3749       if (!fp) {
3750         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3751         fp = fopen(file,"w");
3752         if (!fp) {
3753           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3754           fp = fopen(file,"w");
3755         }
3756       }
3757     }
3758     if (!fp) return 0;  /* we're hosed */
3759
3760     fprintf(fp,"$! 'f$verify(0)'\n");
3761     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3762     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3763     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3764     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3765     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3766     fprintf(fp,"$ perl_del    = \"delete\"\n");
3767     fprintf(fp,"$ pif         = \"if\"\n");
3768     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3769     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3770     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3771     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3772     fprintf(fp,"$!  --- build command line to get max possible length\n");
3773     fprintf(fp,"$c=perl_popen_cmd0\n");
3774     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3775     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3776     fprintf(fp,"$x=perl_popen_cmd3\n");
3777     fprintf(fp,"$c=c+x\n");
3778     fprintf(fp,"$ perl_on\n");
3779     fprintf(fp,"$ 'c'\n");
3780     fprintf(fp,"$ perl_status = $STATUS\n");
3781     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3782     fprintf(fp,"$ perl_exit 'perl_status'\n");
3783     fsync(fileno(fp));
3784
3785     fgetname(fp, file, 1);
3786     fstat(fileno(fp), (struct stat *)&s0);
3787     fclose(fp);
3788
3789     if (decc_filename_unix_only)
3790         do_tounixspec(file, file, 0, NULL);
3791     fp = fopen(file,"r","shr=get");
3792     if (!fp) return 0;
3793     fstat(fileno(fp), (struct stat *)&s1);
3794
3795     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3796     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3797         fclose(fp);
3798         return 0;
3799     }
3800
3801     return fp;
3802 }
3803
3804
3805 static int vms_is_syscommand_xterm(void)
3806 {
3807     const static struct dsc$descriptor_s syscommand_dsc =
3808       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3809
3810     const static struct dsc$descriptor_s decwdisplay_dsc =
3811       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3812
3813     struct item_list_3 items[2];
3814     unsigned short dvi_iosb[4];
3815     unsigned long devchar;
3816     unsigned long devclass;
3817     int status;
3818
3819     /* Very simple check to guess if sys$command is a decterm? */
3820     /* First see if the DECW$DISPLAY: device exists */
3821     items[0].len = 4;
3822     items[0].code = DVI$_DEVCHAR;
3823     items[0].bufadr = &devchar;
3824     items[0].retadr = NULL;
3825     items[1].len = 0;
3826     items[1].code = 0;
3827
3828     status = sys$getdviw
3829         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3830
3831     if ($VMS_STATUS_SUCCESS(status)) {
3832         status = dvi_iosb[0];
3833     }
3834
3835     if (!$VMS_STATUS_SUCCESS(status)) {
3836         SETERRNO(EVMSERR, status);
3837         return -1;
3838     }
3839
3840     /* If it does, then for now assume that we are on a workstation */
3841     /* Now verify that SYS$COMMAND is a terminal */
3842     /* for creating the debugger DECTerm */
3843
3844     items[0].len = 4;
3845     items[0].code = DVI$_DEVCLASS;
3846     items[0].bufadr = &devclass;
3847     items[0].retadr = NULL;
3848     items[1].len = 0;
3849     items[1].code = 0;
3850
3851     status = sys$getdviw
3852         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3853
3854     if ($VMS_STATUS_SUCCESS(status)) {
3855         status = dvi_iosb[0];
3856     }
3857
3858     if (!$VMS_STATUS_SUCCESS(status)) {
3859         SETERRNO(EVMSERR, status);
3860         return -1;
3861     }
3862     else {
3863         if (devclass == DC$_TERM) {
3864             return 0;
3865         }
3866     }
3867     return -1;
3868 }
3869
3870 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3871 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3872 {
3873     int status;
3874     int ret_stat;
3875     char * ret_char;
3876     char device_name[65];
3877     unsigned short device_name_len;
3878     struct dsc$descriptor_s customization_dsc;
3879     struct dsc$descriptor_s device_name_dsc;
3880     const char * cptr;
3881     char * tptr;
3882     char customization[200];
3883     char title[40];
3884     pInfo info = NULL;
3885     char mbx1[64];
3886     unsigned short p_chan;
3887     int n;
3888     unsigned short iosb[4];
3889     struct item_list_3 items[2];
3890     const char * cust_str =
3891         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3892     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3893                                           DSC$K_CLASS_S, mbx1};
3894
3895      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3896     /*---------------------------------------*/
3897     VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3898
3899
3900     /* Make sure that this is from the Perl debugger */
3901     ret_char = strstr(cmd," xterm ");
3902     if (ret_char == NULL)
3903         return NULL;
3904     cptr = ret_char + 7;
3905     ret_char = strstr(cmd,"tty");
3906     if (ret_char == NULL)
3907         return NULL;
3908     ret_char = strstr(cmd,"sleep");
3909     if (ret_char == NULL)
3910         return NULL;
3911
3912     if (decw_term_port == 0) {
3913         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3914         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3915         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3916
3917        status = lib$find_image_symbol
3918                                (&filename1_dsc,
3919                                 &decw_term_port_dsc,
3920                                 (void *)&decw_term_port,
3921                                 NULL,
3922                                 0);
3923
3924         /* Try again with the other image name */
3925         if (!$VMS_STATUS_SUCCESS(status)) {
3926
3927            status = lib$find_image_symbol
3928                                (&filename2_dsc,
3929                                 &decw_term_port_dsc,
3930                                 (void *)&decw_term_port,
3931                                 NULL,
3932                                 0);
3933
3934         }
3935
3936     }
3937
3938
3939     /* No decw$term_port, give it up */
3940     if (!$VMS_STATUS_SUCCESS(status))
3941         return NULL;
3942
3943     /* Are we on a workstation? */
3944     /* to do: capture the rows / columns and pass their properties */
3945     ret_stat = vms_is_syscommand_xterm();
3946     if (ret_stat < 0)
3947         return NULL;
3948
3949     /* Make the title: */
3950     ret_char = strstr(cptr,"-title");
3951     if (ret_char != NULL) {
3952         while ((*cptr != 0) && (*cptr != '\"')) {
3953             cptr++;
3954         }
3955         if (*cptr == '\"')
3956             cptr++;
3957         n = 0;
3958         while ((*cptr != 0) && (*cptr != '\"')) {
3959             title[n] = *cptr;
3960             n++;
3961             if (n == 39) {
3962                 title[39] == 0;
3963                 break;
3964             }
3965             cptr++;
3966         }
3967         title[n] = 0;
3968     }
3969     else {
3970             /* Default title */
3971             strcpy(title,"Perl Debug DECTerm");
3972     }
3973     sprintf(customization, cust_str, title);
3974
3975     customization_dsc.dsc$a_pointer = customization;
3976     customization_dsc.dsc$w_length = strlen(customization);
3977     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3978     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3979
3980     device_name_dsc.dsc$a_pointer = device_name;
3981     device_name_dsc.dsc$w_length = sizeof device_name -1;
3982     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3983     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3984
3985     device_name_len = 0;
3986
3987     /* Try to create the window */
3988      status = (*decw_term_port)
3989        (NULL,
3990         NULL,
3991         &customization_dsc,
3992         &device_name_dsc,
3993         &device_name_len,
3994         NULL,
3995         NULL,
3996         NULL);
3997     if (!$VMS_STATUS_SUCCESS(status)) {
3998         SETERRNO(EVMSERR, status);
3999         return NULL;
4000     }
4001
4002     device_name[device_name_len] = '\0';
4003
4004     /* Need to set this up to look like a pipe for cleanup */
4005     n = sizeof(Info);
4006     status = lib$get_vm(&n, &info);
4007     if (!$VMS_STATUS_SUCCESS(status)) {
4008         SETERRNO(ENOMEM, status);
4009         return NULL;
4010     }
4011
4012     info->mode = *mode;
4013     info->done = FALSE;
4014     info->completion = 0;
4015     info->closing    = FALSE;
4016     info->in         = 0;
4017     info->out        = 0;
4018     info->err        = 0;
4019     info->fp         = NULL;
4020     info->useFILE    = 0;
4021     info->waiting    = 0;
4022     info->in_done    = TRUE;
4023     info->out_done   = TRUE;
4024     info->err_done   = TRUE;
4025
4026     /* Assign a channel on this so that it will persist, and not login */
4027     /* We stash this channel in the info structure for reference. */
4028     /* The created xterm self destructs when the last channel is removed */
4029     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4030     /* So leave this assigned. */
4031     device_name_dsc.dsc$w_length = device_name_len;
4032     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4033     if (!$VMS_STATUS_SUCCESS(status)) {
4034         SETERRNO(EVMSERR, status);
4035         return NULL;
4036     }
4037     info->xchan_valid = 1;
4038
4039     /* Now create a mailbox to be read by the application */
4040
4041     create_mbx(aTHX_ &p_chan, &d_mbx1);
4042
4043     /* write the name of the created terminal to the mailbox */
4044     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4045             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4046
4047     if (!$VMS_STATUS_SUCCESS(status)) {
4048         SETERRNO(EVMSERR, status);
4049         return NULL;
4050     }
4051
4052     info->fp  = PerlIO_open(mbx1, mode);
4053
4054     /* Done with this channel */
4055     sys$dassgn(p_chan);
4056
4057     /* If any errors, then clean up */
4058     if (!info->fp) {
4059         n = sizeof(Info);
4060         _ckvmssts(lib$free_vm(&n, &info));
4061         return NULL;
4062         }
4063
4064     /* All done */
4065     return info->fp;
4066 }
4067
4068 static PerlIO *
4069 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4070 {
4071     static int handler_set_up = FALSE;
4072     unsigned long int sts, flags = CLI$M_NOWAIT;
4073     /* The use of a GLOBAL table (as was done previously) rendered
4074      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4075      * environment.  Hence we've switched to LOCAL symbol table.
4076      */
4077     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4078     int j, wait = 0, n;
4079     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4080     char *in, *out, *err, mbx[512];
4081     FILE *tpipe = 0;
4082     char tfilebuf[NAM$C_MAXRSS+1];
4083     pInfo info = NULL;
4084     char cmd_sym_name[20];
4085     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4086                                       DSC$K_CLASS_S, symbol};
4087     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4088                                       DSC$K_CLASS_S, 0};
4089     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4090                                       DSC$K_CLASS_S, cmd_sym_name};
4091     struct dsc$descriptor_s *vmscmd;
4092     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4093     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4094     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4095
4096     /* Check here for Xterm create request.  This means looking for
4097      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4098      *  is possible to create an xterm.
4099      */
4100     if (*in_mode == 'r') {
4101         PerlIO * xterm_fd;
4102
4103         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4104         if (xterm_fd != NULL)
4105             return xterm_fd;
4106     }
4107
4108     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4109
4110     /* once-per-program initialization...
4111        note that the SETAST calls and the dual test of pipe_ef
4112        makes sure that only the FIRST thread through here does
4113        the initialization...all other threads wait until it's
4114        done.
4115
4116        Yeah, uglier than a pthread call, it's got all the stuff inline
4117        rather than in a separate routine.
4118     */
4119
4120     if (!pipe_ef) {
4121         _ckvmssts(sys$setast(0));
4122         if (!pipe_ef) {
4123             unsigned long int pidcode = JPI$_PID;
4124             $DESCRIPTOR(d_delay, RETRY_DELAY);
4125             _ckvmssts(lib$get_ef(&pipe_ef));
4126             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4127             _ckvmssts(sys$bintim(&d_delay, delaytime));
4128         }
4129         if (!handler_set_up) {
4130           _ckvmssts(sys$dclexh(&pipe_exitblock));
4131           handler_set_up = TRUE;
4132         }
4133         _ckvmssts(sys$setast(1));
4134     }
4135
4136     /* see if we can find a VMSPIPE.COM */
4137
4138     tfilebuf[0] = '@';
4139     vmspipe = find_vmspipe(aTHX);
4140     if (vmspipe) {
4141         strcpy(tfilebuf+1,vmspipe);
4142     } else {        /* uh, oh...we're in tempfile hell */
4143         tpipe = vmspipe_tempfile(aTHX);
4144         if (!tpipe) {       /* a fish popular in Boston */
4145             if (ckWARN(WARN_PIPE)) {
4146                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4147             }
4148         return NULL;
4149         }
4150         fgetname(tpipe,tfilebuf+1,1);
4151     }
4152     vmspipedsc.dsc$a_pointer = tfilebuf;
4153     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4154
4155     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4156     if (!(sts & 1)) {
4157       switch (sts) {
4158         case RMS$_FNF:  case RMS$_DNF:
4159           set_errno(ENOENT); break;
4160         case RMS$_DIR:
4161           set_errno(ENOTDIR); break;
4162         case RMS$_DEV:
4163           set_errno(ENODEV); break;
4164         case RMS$_PRV:
4165           set_errno(EACCES); break;
4166         case RMS$_SYN:
4167           set_errno(EINVAL); break;
4168         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4169           set_errno(E2BIG); break;
4170         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4171           _ckvmssts(sts); /* fall through */
4172         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4173           set_errno(EVMSERR);
4174       }
4175       set_vaxc_errno(sts);
4176       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4177         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4178       }
4179       *psts = sts;
4180       return NULL;
4181     }
4182     n = sizeof(Info);
4183     _ckvmssts(lib$get_vm(&n, &info));
4184
4185     strcpy(mode,in_mode);
4186     info->mode = *mode;
4187     info->done = FALSE;
4188     info->completion = 0;
4189     info->closing    = FALSE;
4190     info->in         = 0;
4191     info->out        = 0;
4192     info->err        = 0;
4193     info->fp         = NULL;
4194     info->useFILE    = 0;
4195     info->waiting    = 0;
4196     info->in_done    = TRUE;
4197     info->out_done   = TRUE;
4198     info->err_done   = TRUE;
4199     info->xchan      = 0;
4200     info->xchan_valid = 0;
4201
4202     in = PerlMem_malloc(VMS_MAXRSS);
4203     if (in == NULL) _ckvmssts(SS$_INSFMEM);
4204     out = PerlMem_malloc(VMS_MAXRSS);
4205     if (out == NULL) _ckvmssts(SS$_INSFMEM);
4206     err = PerlMem_malloc(VMS_MAXRSS);
4207     if (err == NULL) _ckvmssts(SS$_INSFMEM);
4208
4209     in[0] = out[0] = err[0] = '\0';
4210
4211     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4212         info->useFILE = 1;
4213         strcpy(p,p+1);
4214     }
4215     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4216         wait = 1;
4217         strcpy(p,p+1);
4218     }
4219
4220     if (*mode == 'r') {             /* piping from subroutine */
4221
4222         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4223         if (info->out) {
4224             info->out->pipe_done = &info->out_done;
4225             info->out_done = FALSE;
4226             info->out->info = info;
4227         }
4228         if (!info->useFILE) {
4229             info->fp  = PerlIO_open(mbx, mode);
4230         } else {
4231             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4232             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4233         }
4234
4235         if (!info->fp && info->out) {
4236             sys$cancel(info->out->chan_out);
4237
4238             while (!info->out_done) {
4239                 int done;
4240                 _ckvmssts(sys$setast(0));
4241                 done = info->out_done;
4242                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4243                 _ckvmssts(sys$setast(1));
4244                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4245             }
4246
4247             if (info->out->buf) {
4248                 n = info->out->bufsize * sizeof(char);
4249                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4250             }
4251             n = sizeof(Pipe);
4252             _ckvmssts(lib$free_vm(&n, &info->out));
4253             n = sizeof(Info);
4254             _ckvmssts(lib$free_vm(&n, &info));
4255             *psts = RMS$_FNF;
4256             return NULL;
4257         }
4258
4259         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4260         if (info->err) {
4261             info->err->pipe_done = &info->err_done;
4262             info->err_done = FALSE;
4263             info->err->info = info;
4264         }
4265
4266     } else if (*mode == 'w') {      /* piping to subroutine */
4267
4268         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4269         if (info->out) {
4270             info->out->pipe_done = &info->out_done;
4271             info->out_done = FALSE;
4272             info->out->info = info;
4273         }
4274
4275         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4276         if (info->err) {
4277             info->err->pipe_done = &info->err_done;
4278             info->err_done = FALSE;
4279             info->err->info = info;
4280         }
4281
4282         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4283         if (!info->useFILE) {
4284             info->fp  = PerlIO_open(mbx, mode);
4285         } else {
4286             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4287             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4288         }
4289
4290         if (info->in) {
4291             info->in->pipe_done = &info->in_done;
4292             info->in_done = FALSE;
4293             info->in->info = info;
4294         }
4295
4296         /* error cleanup */
4297         if (!info->fp && info->in) {
4298             info->done = TRUE;
4299             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4300                               0, 0, 0, 0, 0, 0, 0, 0));
4301
4302             while (!info->in_done) {
4303                 int done;
4304                 _ckvmssts(sys$setast(0));
4305                 done = info->in_done;
4306                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4307                 _ckvmssts(sys$setast(1));
4308                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4309             }
4310
4311             if (info->in->buf) {
4312                 n = info->in->bufsize * sizeof(char);
4313                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4314             }
4315             n = sizeof(Pipe);
4316             _ckvmssts(lib$free_vm(&n, &info->in));
4317             n = sizeof(Info);
4318             _ckvmssts(lib$free_vm(&n, &info));
4319             *psts = RMS$_FNF;
4320             return NULL;
4321         }
4322
4323
4324     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4325         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4326         if (info->out) {
4327             info->out->pipe_done = &info->out_done;
4328             info->out_done = FALSE;
4329             info->out->info = info;
4330         }
4331
4332         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4333         if (info->err) {
4334             info->err->pipe_done = &info->err_done;
4335             info->err_done = FALSE;
4336             info->err->info = info;
4337         }
4338     }
4339
4340     symbol[MAX_DCL_SYMBOL] = '\0';
4341
4342     strncpy(symbol, in, MAX_DCL_SYMBOL);
4343     d_symbol.dsc$w_length = strlen(symbol);
4344     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4345
4346     strncpy(symbol, err, MAX_DCL_SYMBOL);
4347     d_symbol.dsc$w_length = strlen(symbol);
4348     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4349
4350     strncpy(symbol, out, MAX_DCL_SYMBOL);
4351     d_symbol.dsc$w_length = strlen(symbol);
4352     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4353
4354     /* Done with the names for the pipes */
4355     PerlMem_free(err);
4356     PerlMem_free(out);
4357     PerlMem_free(in);
4358
4359     p = vmscmd->dsc$a_pointer;
4360     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4361     if (*p == '$') p++;                         /* remove leading $ */
4362     while (*p == ' ' || *p == '\t') p++;
4363
4364     for (j = 0; j < 4; j++) {
4365         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4366         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4367
4368     strncpy(symbol, p, MAX_DCL_SYMBOL);
4369     d_symbol.dsc$w_length = strlen(symbol);
4370     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4371
4372         if (strlen(p) > MAX_DCL_SYMBOL) {
4373             p += MAX_DCL_SYMBOL;
4374         } else {
4375             p += strlen(p);
4376         }
4377     }
4378     _ckvmssts(sys$setast(0));
4379     info->next=open_pipes;  /* prepend to list */
4380     open_pipes=info;
4381     _ckvmssts(sys$setast(1));
4382     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4383      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4384      * have SYS$COMMAND if we need it.
4385      */
4386     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4387                       0, &info->pid, &info->completion,
4388                       0, popen_completion_ast,info,0,0,0));
4389
4390     /* if we were using a tempfile, close it now */
4391
4392     if (tpipe) fclose(tpipe);
4393
4394     /* once the subprocess is spawned, it has copied the symbols and
4395        we can get rid of ours */
4396
4397     for (j = 0; j < 4; j++) {
4398         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4399         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4400     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4401     }
4402     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4403     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4404     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4405     vms_execfree(vmscmd);
4406
4407 #ifdef PERL_IMPLICIT_CONTEXT
4408     if (aTHX)
4409 #endif
4410     PL_forkprocess = info->pid;
4411
4412     if (wait) {
4413          int done = 0;
4414          while (!done) {
4415              _ckvmssts(sys$setast(0));
4416              done = info->done;
4417              if (!done) _ckvmssts(sys$clref(pipe_ef));
4418              _ckvmssts(sys$setast(1));
4419              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4420          }
4421         *psts = info->completion;
4422 /* Caller thinks it is open and tries to close it. */
4423 /* This causes some problems, as it changes the error status */
4424 /*        my_pclose(info->fp); */
4425     } else {
4426         *psts = info->pid;
4427     }
4428     return info->fp;
4429 }  /* end of safe_popen */
4430
4431
4432 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4433 PerlIO *
4434 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4435 {
4436     int sts;
4437     TAINT_ENV();
4438     TAINT_PROPER("popen");
4439     PERL_FLUSHALL_FOR_CHILD;
4440     return safe_popen(aTHX_ cmd,mode,&sts);
4441 }
4442
4443 /*}}}*/
4444
4445 /*{{{  I32 my_pclose(PerlIO *fp)*/
4446 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4447 {
4448     pInfo info, last = NULL;
4449     unsigned long int retsts;
4450     int done, iss, n;
4451     int status;
4452
4453     for (info = open_pipes; info != NULL; last = info, info = info->next)
4454         if (info->fp == fp) break;
4455
4456     if (info == NULL) {  /* no such pipe open */
4457       set_errno(ECHILD); /* quoth POSIX */
4458       set_vaxc_errno(SS$_NONEXPR);
4459       return -1;
4460     }
4461
4462     /* If we were writing to a subprocess, insure that someone reading from
4463      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4464      * produce an EOF record in the mailbox.
4465      *
4466      *  well, at least sometimes it *does*, so we have to watch out for
4467      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4468      */
4469      if (info->fp) {
4470         if (!info->useFILE
4471 #if defined(USE_ITHREADS)
4472           && my_perl
4473 #endif
4474           && PL_perlio_fd_refcnt)
4475             PerlIO_flush(info->fp);
4476         else
4477             fflush((FILE *)info->fp);
4478     }
4479
4480     _ckvmssts(sys$setast(0));
4481      info->closing = TRUE;
4482      done = info->done && info->in_done && info->out_done && info->err_done;
4483      /* hanging on write to Perl's input? cancel it */
4484      if (info->mode == 'r' && info->out && !info->out_done) {
4485         if (info->out->chan_out) {
4486             _ckvmssts(sys$cancel(info->out->chan_out));
4487             if (!info->out->chan_in) {   /* EOF generation, need AST */
4488                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4489             }
4490         }
4491      }
4492      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4493          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4494                            0, 0, 0, 0, 0, 0));
4495     _ckvmssts(sys$setast(1));
4496     if (info->fp) {
4497      if (!info->useFILE
4498 #if defined(USE_ITHREADS)
4499          && my_perl
4500 #endif
4501          && PL_perlio_fd_refcnt)
4502         PerlIO_close(info->fp);
4503      else
4504         fclose((FILE *)info->fp);
4505     }
4506      /*
4507         we have to wait until subprocess completes, but ALSO wait until all
4508         the i/o completes...otherwise we'll be freeing the "info" structure
4509         that the i/o ASTs could still be using...
4510      */
4511
4512      while (!done) {
4513          _ckvmssts(sys$setast(0));
4514          done = info->done && info->in_done && info->out_done && info->err_done;
4515          if (!done) _ckvmssts(sys$clref(pipe_ef));
4516          _ckvmssts(sys$setast(1));
4517          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4518      }
4519      retsts = info->completion;
4520
4521     /* remove from list of open pipes */
4522     _ckvmssts(sys$setast(0));
4523     if (last) last->next = info->next;
4524     else open_pipes = info->next;
4525     _ckvmssts(sys$setast(1));
4526
4527     /* free buffers and structures */
4528
4529     if (info->in) {
4530         if (info->in->buf) {
4531             n = info->in->bufsize * sizeof(char);
4532             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4533         }
4534         n = sizeof(Pipe);
4535         _ckvmssts(lib$free_vm(&n, &info->in));
4536     }
4537     if (info->out) {
4538         if (info->out->buf) {
4539             n = info->out->bufsize * sizeof(char);
4540             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4541         }
4542         n = sizeof(Pipe);
4543         _ckvmssts(lib$free_vm(&n, &info->out));
4544     }
4545     if (info->err) {
4546         if (info->err->buf) {
4547             n = info->err->bufsize * sizeof(char);
4548             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4549         }
4550         n = sizeof(Pipe);
4551         _ckvmssts(lib$free_vm(&n, &info->err));
4552     }
4553     n = sizeof(Info);
4554     _ckvmssts(lib$free_vm(&n, &info));
4555
4556     return retsts;
4557
4558 }  /* end of my_pclose() */
4559
4560 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4561   /* Roll our own prototype because we want this regardless of whether
4562    * _VMS_WAIT is defined.
4563    */
4564   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4565 #endif
4566 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4567    created with popen(); otherwise partially emulate waitpid() unless
4568    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4569    Also check processes not considered by the CRTL waitpid().
4570  */
4571 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4572 Pid_t
4573 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4574 {
4575     pInfo info;
4576     int done;
4577     int sts;
4578     int j;
4579
4580     if (statusp) *statusp = 0;
4581
4582     for (info = open_pipes; info != NULL; info = info->next)
4583         if (info->pid == pid) break;
4584
4585     if (info != NULL) {  /* we know about this child */
4586       while (!info->done) {
4587           _ckvmssts(sys$setast(0));
4588           done = info->done;
4589           if (!done) _ckvmssts(sys$clref(pipe_ef));
4590           _ckvmssts(sys$setast(1));
4591           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4592       }
4593
4594       if (statusp) *statusp = info->completion;
4595       return pid;
4596     }
4597
4598     /* child that already terminated? */
4599
4600     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4601         if (closed_list[j].pid == pid) {
4602             if (statusp) *statusp = closed_list[j].completion;
4603             return pid;
4604         }
4605     }
4606
4607     /* fall through if this child is not one of our own pipe children */
4608
4609 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4610
4611       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4612        * in 7.2 did we get a version that fills in the VMS completion
4613        * status as Perl has always tried to do.
4614        */
4615
4616       sts = __vms_waitpid( pid, statusp, flags );
4617
4618       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4619          return sts;
4620
4621       /* If the real waitpid tells us the child does not exist, we
4622        * fall through here to implement waiting for a child that
4623        * was created by some means other than exec() (say, spawned
4624        * from DCL) or to wait for a process that is not a subprocess
4625        * of the current process.
4626        */
4627
4628 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4629
4630     {
4631       $DESCRIPTOR(intdsc,"0 00:00:01");
4632       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4633       unsigned long int pidcode = JPI$_PID, mypid;
4634       unsigned long int interval[2];
4635       unsigned int jpi_iosb[2];
4636       struct itmlst_3 jpilist[2] = {
4637           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4638           {                      0,         0,                 0, 0}
4639       };
4640
4641       if (pid <= 0) {
4642         /* Sorry folks, we don't presently implement rooting around for
4643            the first child we can find, and we definitely don't want to
4644            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4645          */
4646         set_errno(ENOTSUP);
4647         return -1;
4648       }
4649
4650       /* Get the owner of the child so I can warn if it's not mine. If the
4651        * process doesn't exist or I don't have the privs to look at it,
4652        * I can go home early.
4653        */
4654       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4655       if (sts & 1) sts = jpi_iosb[0];
4656       if (!(sts & 1)) {
4657         switch (sts) {
4658             case SS$_NONEXPR:
4659                 set_errno(ECHILD);
4660                 break;
4661             case SS$_NOPRIV:
4662                 set_errno(EACCES);
4663                 break;
4664             default:
4665                 _ckvmssts(sts);
4666         }
4667         set_vaxc_errno(sts);
4668         return -1;
4669       }
4670
4671       if (ckWARN(WARN_EXEC)) {
4672         /* remind folks they are asking for non-standard waitpid behavior */
4673         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4674         if (ownerpid != mypid)
4675           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4676                       "waitpid: process %x is not a child of process %x",
4677                       pid,mypid);
4678       }
4679
4680       /* simply check on it once a second until it's not there anymore. */
4681
4682       _ckvmssts(sys$bintim(&intdsc,interval));
4683       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4684             _ckvmssts(sys$schdwk(0,0,interval,0));
4685             _ckvmssts(sys$hiber());
4686       }
4687       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4688
4689       _ckvmssts(sts);
4690       return pid;
4691     }
4692 }  /* end of waitpid() */
4693 /*}}}*/
4694 /*}}}*/
4695 /*}}}*/
4696
4697 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4698 char *
4699 my_gconvert(double val, int ndig, int trail, char *buf)
4700 {
4701   static char __gcvtbuf[DBL_DIG+1];
4702   char *loc;
4703
4704   loc = buf ? buf : __gcvtbuf;
4705
4706 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4707   if (val < 1) {
4708     sprintf(loc,"%.*g",ndig,val);
4709     return loc;
4710   }
4711 #endif
4712
4713   if (val) {
4714     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4715     return gcvt(val,ndig,loc);
4716   }
4717   else {
4718     loc[0] = '0'; loc[1] = '\0';
4719     return loc;
4720   }
4721
4722 }
4723 /*}}}*/
4724
4725 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4726 static int rms_free_search_context(struct FAB * fab)
4727 {
4728 struct NAM * nam;
4729
4730     nam = fab->fab$l_nam;
4731     nam->nam$b_nop |= NAM$M_SYNCHK;
4732     nam->nam$l_rlf = NULL;
4733     fab->fab$b_dns = 0;
4734     return sys$parse(fab, NULL, NULL);
4735 }
4736
4737 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4738 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4739 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4740 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4741 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4742 #define rms_nam_esll(nam) nam.nam$b_esl
4743 #define rms_nam_esl(nam) nam.nam$b_esl
4744 #define rms_nam_name(nam) nam.nam$l_name
4745 #define rms_nam_namel(nam) nam.nam$l_name
4746 #define rms_nam_type(nam) nam.nam$l_type
4747 #define rms_nam_typel(nam) nam.nam$l_type
4748 #define rms_nam_ver(nam) nam.nam$l_ver
4749 #define rms_nam_verl(nam) nam.nam$l_ver
4750 #define rms_nam_rsll(nam) nam.nam$b_rsl
4751 #define rms_nam_rsl(nam) nam.nam$b_rsl
4752 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4753 #define rms_set_fna(fab, nam, name, size) \
4754         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4755 #define rms_get_fna(fab, nam) fab.fab$l_fna
4756 #define rms_set_dna(fab, nam, name, size) \
4757         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4758 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4759 #define rms_set_esa(nam, name, size) \
4760         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4761 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4762         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4763 #define rms_set_rsa(nam, name, size) \
4764         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4765 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4766         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4767 #define rms_nam_name_type_l_size(nam) \
4768         (nam.nam$b_name + nam.nam$b_type)
4769 #else
4770 static int rms_free_search_context(struct FAB * fab)
4771 {
4772 struct NAML * nam;
4773
4774     nam = fab->fab$l_naml;
4775     nam->naml$b_nop |= NAM$M_SYNCHK;
4776     nam->naml$l_rlf = NULL;
4777     nam->naml$l_long_defname_size = 0;
4778
4779     fab->fab$b_dns = 0;
4780     return sys$parse(fab, NULL, NULL);
4781 }
4782
4783 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4784 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4785 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4786 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4787 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4788 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4789 #define rms_nam_esl(nam) nam.naml$b_esl
4790 #define rms_nam_name(nam) nam.naml$l_name
4791 #define rms_nam_namel(nam) nam.naml$l_long_name
4792 #define rms_nam_type(nam) nam.naml$l_type
4793 #define rms_nam_typel(nam) nam.naml$l_long_type
4794 #define rms_nam_ver(nam) nam.naml$l_ver
4795 #define rms_nam_verl(nam) nam.naml$l_long_ver
4796 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4797 #define rms_nam_rsl(nam) nam.naml$b_rsl
4798 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4799 #define rms_set_fna(fab, nam, name, size) \
4800         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4801         nam.naml$l_long_filename_size = size; \
4802         nam.naml$l_long_filename = name;}
4803 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4804 #define rms_set_dna(fab, nam, name, size) \
4805         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4806         nam.naml$l_long_defname_size = size; \
4807         nam.naml$l_long_defname = name; }
4808 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4809 #define rms_set_esa(nam, name, size) \
4810         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4811         nam.naml$l_long_expand_alloc = size; \
4812         nam.naml$l_long_expand = name; }
4813 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4814         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4815         nam.naml$l_long_expand = l_name; \
4816         nam.naml$l_long_expand_alloc = l_size; }
4817 #define rms_set_rsa(nam, name, size) \
4818         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4819         nam.naml$l_long_result = name; \
4820         nam.naml$l_long_result_alloc = size; }
4821 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4822         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4823         nam.naml$l_long_result = l_name; \
4824         nam.naml$l_long_result_alloc = l_size; }
4825 #define rms_nam_name_type_l_size(nam) \
4826         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4827 #endif
4828
4829
4830 /* rms_erase
4831  * The CRTL for 8.3 and later can create symbolic links in any mode,
4832  * however in 8.3 the unlink/remove/delete routines will only properly handle
4833  * them if one of the PCP modes is active.
4834  */
4835 static int rms_erase(const char * vmsname)
4836 {
4837   int status;
4838   struct FAB myfab = cc$rms_fab;
4839   rms_setup_nam(mynam);
4840
4841   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4842   rms_bind_fab_nam(myfab, mynam);
4843
4844   /* Are we removing all versions? */
4845   if (vms_unlink_all_versions == 1) {
4846     const char * defspec = ";*";
4847     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4848   }
4849
4850 #ifdef NAML$M_OPEN_SPECIAL
4851   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4852 #endif
4853
4854   status = sys$erase(&myfab, 0, 0);
4855
4856   return status;
4857 }
4858
4859
4860 static int
4861 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4862                     const struct dsc$descriptor_s * vms_dst_dsc,
4863                     unsigned long flags)
4864 {
4865     /*  VMS and UNIX handle file permissions differently and the
4866      * the same ACL trick may be needed for renaming files,
4867      * especially if they are directories.
4868      */
4869
4870    /* todo: get kill_file and rename to share common code */
4871    /* I can not find online documentation for $change_acl
4872     * it appears to be replaced by $set_security some time ago */
4873
4874 const unsigned int access_mode = 0;
4875 $DESCRIPTOR(obj_file_dsc,"FILE");
4876 char *vmsname;
4877 char *rslt;
4878 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
4879 int aclsts, fndsts, rnsts = -1;
4880 unsigned int ctx = 0;
4881 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4882 struct dsc$descriptor_s * clean_dsc;
4883
4884 struct myacedef {
4885     unsigned char myace$b_length;
4886     unsigned char myace$b_type;
4887     unsigned short int myace$w_flags;
4888     unsigned long int myace$l_access;
4889     unsigned long int myace$l_ident;
4890 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4891              ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4892              0},
4893              oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4894
4895 struct item_list_3
4896         findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4897                       {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4898                       {0,0,0,0}},
4899         addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4900         dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4901                      {0,0,0,0}};
4902
4903
4904     /* Expand the input spec using RMS, since we do not want to put
4905      * ACLs on the target of a symbolic link */
4906     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
4907     if (vmsname == NULL)
4908         return SS$_INSFMEM;
4909
4910     rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer,
4911                         vmsname,
4912                         0,
4913                         NULL,
4914                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
4915                         NULL,
4916                         NULL);
4917     if (rslt == NULL) {
4918         PerlMem_free(vmsname);
4919         return SS$_INSFMEM;
4920     }
4921
4922     /* So we get our own UIC to use as a rights identifier,
4923      * and the insert an ACE at the head of the ACL which allows us
4924      * to delete the file.
4925      */
4926     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4927
4928     fildsc.dsc$w_length = strlen(vmsname);
4929     fildsc.dsc$a_pointer = vmsname;
4930     ctx = 0;
4931     newace.myace$l_ident = oldace.myace$l_ident;
4932     rnsts = SS$_ABORT;
4933
4934     /* Grab any existing ACEs with this identifier in case we fail */
4935     clean_dsc = &fildsc;
4936     aclsts = fndsts = sys$get_security(&obj_file_dsc,
4937                                &fildsc,
4938                                NULL,
4939                                OSS$M_WLOCK,
4940                                findlst,
4941                                &ctx,
4942                                &access_mode);
4943
4944     if ($VMS_STATUS_SUCCESS(fndsts)  || (fndsts == SS$_ACLEMPTY)) {
4945         /* Add the new ACE . . . */
4946
4947         /* if the sys$get_security succeeded, then ctx is valid, and the
4948          * object/file descriptors will be ignored.  But otherwise they
4949          * are needed
4950          */
4951         aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4952                                   OSS$M_RELCTX, addlst, &ctx, &access_mode);
4953         if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4954             set_errno(EVMSERR);
4955             set_vaxc_errno(aclsts);
4956             PerlMem_free(vmsname);
4957             return aclsts;
4958         }
4959
4960         rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4961                                 NULL, NULL,
4962                                 &flags,
4963                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4964
4965         if ($VMS_STATUS_SUCCESS(rnsts)) {
4966             clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4967         }
4968
4969         /* Put things back the way they were. */
4970         ctx = 0;
4971         aclsts = sys$get_security(&obj_file_dsc,
4972                                   clean_dsc,
4973                                   NULL,
4974                                   OSS$M_WLOCK,
4975                                   findlst,
4976                                   &ctx,
4977                                   &access_mode);
4978
4979         if ($VMS_STATUS_SUCCESS(aclsts)) {
4980         int sec_flags;
4981
4982             sec_flags = 0;
4983             if (!$VMS_STATUS_SUCCESS(fndsts))
4984                 sec_flags = OSS$M_RELCTX;
4985
4986             /* Get rid of the new ACE */
4987             aclsts = sys$set_security(NULL, NULL, NULL,
4988                                   sec_flags, dellst, &ctx, &access_mode);
4989
4990             /* If there was an old ACE, put it back */
4991             if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
4992                 addlst[0].bufadr = &oldace;
4993                 aclsts = sys$set_security(NULL, NULL, NULL,
4994                                       OSS$M_RELCTX, addlst, &ctx, &access_mode);
4995                 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4996                     set_errno(EVMSERR);
4997                     set_vaxc_errno(aclsts);
4998                     rnsts = aclsts;
4999                 }
5000             } else {
5001             int aclsts2;
5002
5003                 /* Try to clear the lock on the ACL list */
5004                 aclsts2 = sys$set_security(NULL, NULL, NULL,
5005                                       OSS$M_RELCTX, NULL, &ctx, &access_mode);
5006
5007                 /* Rename errors are most important */
5008                 if (!$VMS_STATUS_SUCCESS(rnsts))
5009                     aclsts = rnsts;
5010                 set_errno(EVMSERR);
5011                 set_vaxc_errno(aclsts);
5012                 rnsts = aclsts;
5013             }
5014         }
5015         else {
5016             if (aclsts != SS$_ACLEMPTY)
5017                 rnsts = aclsts;
5018         }
5019     }
5020     else
5021         rnsts = fndsts;
5022
5023     PerlMem_free(vmsname);
5024     return rnsts;
5025 }
5026
5027
5028 /*{{{int rename(const char *, const char * */
5029 /* Not exactly what X/Open says to do, but doing it absolutely right
5030  * and efficiently would require a lot more work.  This should be close
5031  * enough to pass all but the most strict X/Open compliance test.
5032  */
5033 int
5034 Perl_rename(pTHX_ const char *src, const char * dst)
5035 {
5036 int retval;
5037 int pre_delete = 0;
5038 int src_sts;
5039 int dst_sts;
5040 Stat_t src_st;
5041 Stat_t dst_st;
5042
5043     /* Validate the source file */
5044     src_sts = flex_lstat(src, &src_st);
5045     if (src_sts != 0) {
5046
5047         /* No source file or other problem */
5048         return src_sts;
5049     }
5050
5051     dst_sts = flex_lstat(dst, &dst_st);
5052     if (dst_sts == 0) {
5053
5054         if (dst_st.st_dev != src_st.st_dev) {
5055             /* Must be on the same device */
5056             errno = EXDEV;
5057             return -1;
5058         }
5059
5060         /* VMS_INO_T_COMPARE is true if the inodes are different
5061          * to match the output of memcmp
5062          */
5063
5064         if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5065             /* That was easy, the files are the same! */
5066             return 0;
5067         }
5068
5069         if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5070             /* If source is a directory, so must be dest */
5071                 errno = EISDIR;
5072                 return -1;
5073         }
5074
5075     }
5076
5077
5078     if ((dst_sts == 0) &&
5079         (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5080
5081         /* We have issues here if vms_unlink_all_versions is set
5082          * If the destination exists, and is not a directory, then
5083          * we must delete in advance.
5084          *
5085          * If the src is a directory, then we must always pre-delete
5086          * the destination.
5087          *
5088          * If we successfully delete the dst in advance, and the rename fails
5089          * X/Open requires that errno be EIO.
5090          *
5091          */
5092
5093         if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5094             int d_sts;
5095             d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5096             if (d_sts != 0)
5097                 return d_sts;
5098
5099             /* We killed the destination, so only errno now is EIO */
5100             pre_delete = 1;
5101         }
5102     }
5103
5104     /* Originally the idea was to call the CRTL rename() and only
5105      * try the lib$rename_file if it failed.
5106      * It turns out that there are too many variants in what the
5107      * the CRTL rename might do, so only use lib$rename_file
5108      */
5109     retval = -1;
5110
5111     {
5112         /* Is the source and dest both in VMS format */
5113         /* if the source is a directory, then need to fileify */
5114         /*  and dest must be a directory or non-existant. */
5115
5116         char * vms_src;
5117         char * vms_dst;
5118         int sts;
5119         char * ret_str;
5120         unsigned long flags;
5121         struct dsc$descriptor_s old_file_dsc;
5122         struct dsc$descriptor_s new_file_dsc;
5123
5124         /* We need to modify the src and dst depending
5125          * on if one or more of them are directories.
5126          */
5127
5128         vms_src = PerlMem_malloc(VMS_MAXRSS);
5129         if (vms_src == NULL)
5130             _ckvmssts(SS$_INSFMEM);
5131
5132         /* Source is always a VMS format file */
5133         ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5134         if (ret_str == NULL) {
5135             PerlMem_free(vms_src);
5136             errno = EIO;
5137             return -1;
5138         }
5139
5140         vms_dst = PerlMem_malloc(VMS_MAXRSS);
5141         if (vms_dst == NULL)
5142             _ckvmssts(SS$_INSFMEM);
5143
5144         if (S_ISDIR(src_st.st_mode)) {
5145         char * ret_str;
5146         char * vms_dir_file;
5147
5148             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5149             if (vms_dir_file == NULL)
5150                 _ckvmssts(SS$_INSFMEM);
5151
5152             /* The source must be a file specification */
5153             ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
5154             if (ret_str == NULL) {
5155                 PerlMem_free(vms_src);
5156                 PerlMem_free(vms_dst);
5157                 PerlMem_free(vms_dir_file);
5158                 errno = EIO;
5159                 return -1;
5160             }
5161             PerlMem_free(vms_src);
5162             vms_src = vms_dir_file;
5163
5164             /* If the dest is a directory, we must remove it
5165             if (dst_sts == 0) {
5166                 int d_sts;
5167                 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5168                 if (d_sts != 0) {
5169                     PerlMem_free(vms_src);
5170                     PerlMem_free(vms_dst);
5171                     errno = EIO;
5172                     return sts;
5173                 }
5174
5175                 pre_delete = 1;
5176             }
5177
5178            /* The dest must be a VMS file specification */
5179            ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5180            if (ret_str == NULL) {
5181                 PerlMem_free(vms_src);
5182                 PerlMem_free(vms_dst);
5183                 errno = EIO;
5184                 return -1;
5185            }
5186
5187             /* The source must be a file specification */
5188             vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5189             if (vms_dir_file == NULL)
5190                 _ckvmssts(SS$_INSFMEM);
5191
5192             ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5193             if (ret_str == NULL) {
5194                 PerlMem_free(vms_src);
5195                 PerlMem_free(vms_dst);
5196                 PerlMem_free(vms_dir_file);
5197                 errno = EIO;
5198                 return -1;
5199             }
5200             PerlMem_free(vms_dst);
5201             vms_dst = vms_dir_file;
5202
5203         } else {
5204             /* File to file or file to new dir */
5205
5206             if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5207                 /* VMS pathify a dir target */
5208                 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5209                 if (ret_str == NULL) {
5210                     PerlMem_free(vms_src);
5211                     PerlMem_free(vms_dst);
5212                     errno = EIO;
5213                     return -1;
5214                 }
5215             } else {
5216
5217                 /* fileify a target VMS file specification */
5218                 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5219                 if (ret_str == NULL) {
5220                     PerlMem_free(vms_src);
5221                     PerlMem_free(vms_dst);
5222                     errno = EIO;
5223                     return -1;
5224                 }
5225             }
5226         }
5227
5228         old_file_dsc.dsc$a_pointer = vms_src;
5229         old_file_dsc.dsc$w_length = strlen(vms_src);
5230         old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5231         old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5232
5233         new_file_dsc.dsc$a_pointer = vms_dst;
5234         new_file_dsc.dsc$w_length = strlen(vms_dst);
5235         new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5236         new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5237
5238         flags = 0;
5239 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5240         flags |= 2; /* LIB$M_FIL_LONG_NAMES */
5241 #endif
5242
5243         sts = lib$rename_file(&old_file_dsc,
5244                               &new_file_dsc,
5245                               NULL, NULL,
5246                               &flags,
5247                               NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5248         if (!$VMS_STATUS_SUCCESS(sts)) {
5249
5250            /* We could have failed because VMS style permissions do not
5251             * permit renames that UNIX will allow.  Just like the hack
5252             * in for kill_file.
5253             */
5254            sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5255         }
5256
5257         PerlMem_free(vms_src);
5258         PerlMem_free(vms_dst);
5259         if (!$VMS_STATUS_SUCCESS(sts)) {
5260             errno = EIO;
5261             return -1;
5262         }
5263         retval = 0;
5264     }
5265
5266     if (vms_unlink_all_versions) {
5267         /* Now get rid of any previous versions of the source file that
5268          * might still exist
5269          */
5270         int save_errno;
5271         save_errno = errno;
5272         src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5273         errno = save_errno;
5274     }
5275
5276     /* We deleted the destination, so must force the error to be EIO */
5277     if ((retval != 0) && (pre_delete != 0))
5278         errno = EIO;
5279
5280     return retval;
5281 }
5282 /*}}}*/
5283
5284
5285 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5286 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5287  * to expand file specification.  Allows for a single default file
5288  * specification and a simple mask of options.  If outbuf is non-NULL,
5289  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5290  * the resultant file specification is placed.  If outbuf is NULL, the
5291  * resultant file specification is placed into a static buffer.
5292  * The third argument, if non-NULL, is taken to be a default file
5293  * specification string.  The fourth argument is unused at present.
5294  * rmesexpand() returns the address of the resultant string if
5295  * successful, and NULL on error.
5296  *
5297  * New functionality for previously unused opts value:
5298  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5299  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
5300  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5301  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5302  */
5303 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5304
5305 static char *
5306 mp_do_rmsexpand
5307    (pTHX_ const char *filespec,
5308     char *outbuf,
5309     int ts,
5310     const char *defspec,
5311     unsigned opts,
5312     int * fs_utf8,
5313     int * dfs_utf8)
5314 {
5315   static char __rmsexpand_retbuf[VMS_MAXRSS];
5316   char * vmsfspec, *tmpfspec;
5317   char * esa, *cp, *out = NULL;
5318   char * tbuf;
5319   char * esal = NULL;
5320   char * outbufl;
5321   struct FAB myfab = cc$rms_fab;
5322   rms_setup_nam(mynam);
5323   STRLEN speclen;
5324   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5325   int sts;
5326
5327   /* temp hack until UTF8 is actually implemented */
5328   if (fs_utf8 != NULL)
5329     *fs_utf8 = 0;
5330
5331   if (!filespec || !*filespec) {
5332     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5333     return NULL;
5334   }
5335   if (!outbuf) {
5336     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
5337     else    outbuf = __rmsexpand_retbuf;
5338   }
5339
5340   vmsfspec = NULL;
5341   tmpfspec = NULL;
5342   outbufl = NULL;
5343
5344   isunix = 0;
5345   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5346     isunix = is_unix_filespec(filespec);
5347     if (isunix) {
5348       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5349       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
5350       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
5351         PerlMem_free(vmsfspec);
5352         if (out)
5353            Safefree(out);
5354         return NULL;
5355       }
5356       filespec = vmsfspec;
5357
5358       /* Unless we are forcing to VMS format, a UNIX input means
5359        * UNIX output, and that requires long names to be used
5360        */
5361 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5362       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5363         opts |= PERL_RMSEXPAND_M_LONG;
5364       else
5365 #endif
5366         isunix = 0;
5367       }
5368     }
5369
5370   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
5371   rms_bind_fab_nam(myfab, mynam);
5372
5373   if (defspec && *defspec) {
5374     int t_isunix;
5375     t_isunix = is_unix_filespec(defspec);
5376     if (t_isunix) {
5377       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5378       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5379       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
5380         PerlMem_free(tmpfspec);
5381         if (vmsfspec != NULL)
5382             PerlMem_free(vmsfspec);
5383         if (out)
5384            Safefree(out);
5385         return NULL;
5386       }
5387       defspec = tmpfspec;
5388     }
5389     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5390   }
5391
5392   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5393   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5394 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5395   esal = PerlMem_malloc(VMS_MAXRSS);
5396   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5397 #endif
5398   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5399
5400   /* If a NAML block is used RMS always writes to the long and short
5401    * addresses unless you suppress the short name.
5402    */
5403 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5404   outbufl = PerlMem_malloc(VMS_MAXRSS);
5405   if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
5406 #endif
5407    rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5408
5409 #ifdef NAM$M_NO_SHORT_UPCASE
5410   if (decc_efs_case_preserve)
5411     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5412 #endif
5413
5414    /* We may not want to follow symbolic links */
5415 #ifdef NAML$M_OPEN_SPECIAL
5416   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5417     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5418 #endif
5419
5420   /* First attempt to parse as an existing file */
5421   retsts = sys$parse(&myfab,0,0);
5422   if (!(retsts & STS$K_SUCCESS)) {
5423
5424     /* Could not find the file, try as syntax only if error is not fatal */
5425     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5426     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
5427       retsts = sys$parse(&myfab,0,0);
5428       if (retsts & STS$K_SUCCESS) goto expanded;
5429     }
5430
5431      /* Still could not parse the file specification */
5432     /*----------------------------------------------*/
5433     sts = rms_free_search_context(&myfab); /* Free search context */
5434     if (out) Safefree(out);
5435     if (tmpfspec != NULL)
5436         PerlMem_free(tmpfspec);
5437     if (vmsfspec != NULL)
5438         PerlMem_free(vmsfspec);
5439     if (outbufl != NULL)
5440         PerlMem_free(outbufl);
5441     PerlMem_free(esa);
5442     if (esal != NULL)
5443         PerlMem_free(esal);
5444     set_vaxc_errno(retsts);
5445     if      (retsts == RMS$_PRV) set_errno(EACCES);
5446     else if (retsts == RMS$_DEV) set_errno(ENODEV);
5447     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5448     else                         set_errno(EVMSERR);
5449     return NULL;
5450   }
5451   retsts = sys$search(&myfab,0,0);
5452   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5453     sts = rms_free_search_context(&myfab); /* Free search context */
5454     if (out) Safefree(out);
5455     if (tmpfspec != NULL)
5456         PerlMem_free(tmpfspec);
5457     if (vmsfspec != NULL)
5458         PerlMem_free(vmsfspec);
5459     if (outbufl != NULL)
5460         PerlMem_free(outbufl);
5461     PerlMem_free(esa);
5462     if (esal != NULL)
5463         PerlMem_free(esal);
5464     set_vaxc_errno(retsts);
5465     if      (retsts == RMS$_PRV) set_errno(EACCES);
5466     else                         set_errno(EVMSERR);
5467     return NULL;
5468   }
5469
5470   /* If the input filespec contained any lowercase characters,
5471    * downcase the result for compatibility with Unix-minded code. */
5472   expanded:
5473   if (!decc_efs_case_preserve) {
5474     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5475       if (islower(*tbuf)) { haslower = 1; break; }
5476   }
5477
5478    /* Is a long or a short name expected */
5479   /*------------------------------------*/
5480   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5481     if (rms_nam_rsll(mynam)) {
5482         tbuf = outbufl;
5483         speclen = rms_nam_rsll(mynam);
5484     }
5485     else {
5486         tbuf = esal; /* Not esa */
5487         speclen = rms_nam_esll(mynam);
5488     }
5489   }
5490   else {
5491     if (rms_nam_rsl(mynam)) {
5492         tbuf = outbuf;
5493         speclen = rms_nam_rsl(mynam);
5494     }
5495     else {
5496         tbuf = esa; /* Not esal */
5497         speclen = rms_nam_esl(mynam);
5498     }
5499   }
5500   tbuf[speclen] = '\0';
5501
5502   /* Trim off null fields added by $PARSE
5503    * If type > 1 char, must have been specified in original or default spec
5504    * (not true for version; $SEARCH may have added version of existing file).
5505    */
5506   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5507   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5508     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5509              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5510   }
5511   else {
5512     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5513              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5514   }
5515   if (trimver || trimtype) {
5516     if (defspec && *defspec) {
5517       char *defesal = NULL;
5518       char *defesa = NULL;
5519       defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5520       if (defesa != NULL) {
5521 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5522         defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5523         if (defesal == NULL) _ckvmssts(SS$_INSFMEM);
5524 #endif
5525         struct FAB deffab = cc$rms_fab;
5526         rms_setup_nam(defnam);
5527
5528         rms_bind_fab_nam(deffab, defnam);
5529
5530         /* Cast ok */
5531         rms_set_fna
5532             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5533
5534         /* RMS needs the esa/esal as a work area if wildcards are involved */
5535         rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5536
5537         rms_clear_nam_nop(defnam);
5538         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5539 #ifdef NAM$M_NO_SHORT_UPCASE
5540         if (decc_efs_case_preserve)
5541           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5542 #endif
5543 #ifdef NAML$M_OPEN_SPECIAL
5544         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5545           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5546 #endif
5547         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5548           if (trimver) {
5549              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5550           }
5551           if (trimtype) {
5552             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5553           }
5554         }
5555         if (defesal != NULL)
5556             PerlMem_free(defesal);
5557         PerlMem_free(defesa);
5558       }
5559     }
5560     if (trimver) {
5561       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5562         if (*(rms_nam_verl(mynam)) != '\"')
5563           speclen = rms_nam_verl(mynam) - tbuf;
5564       }
5565       else {
5566         if (*(rms_nam_ver(mynam)) != '\"')
5567           speclen = rms_nam_ver(mynam) - tbuf;
5568       }
5569     }
5570     if (trimtype) {
5571       /* If we didn't already trim version, copy down */
5572       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5573         if (speclen > rms_nam_verl(mynam) - tbuf)
5574           memmove
5575            (rms_nam_typel(mynam),
5576             rms_nam_verl(mynam),
5577             speclen - (rms_nam_verl(mynam) - tbuf));
5578           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5579       }
5580       else {
5581         if (speclen > rms_nam_ver(mynam) - tbuf)
5582           memmove
5583            (rms_nam_type(mynam),
5584             rms_nam_ver(mynam),
5585             speclen - (rms_nam_ver(mynam) - tbuf));
5586           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5587       }
5588     }
5589   }
5590
5591    /* Done with these copies of the input files */
5592   /*-------------------------------------------*/
5593   if (vmsfspec != NULL)
5594         PerlMem_free(vmsfspec);
5595   if (tmpfspec != NULL)
5596         PerlMem_free(tmpfspec);
5597
5598   /* If we just had a directory spec on input, $PARSE "helpfully"
5599    * adds an empty name and type for us */
5600 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5601   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5602     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5603         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5604         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5605       speclen = rms_nam_namel(mynam) - tbuf;
5606   }
5607   else
5608 #endif
5609   {
5610     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5611         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5612         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5613       speclen = rms_nam_name(mynam) - tbuf;
5614   }
5615
5616   /* Posix format specifications must have matching quotes */
5617   if (speclen < (VMS_MAXRSS - 1)) {
5618     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5619       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5620         tbuf[speclen] = '\"';
5621         speclen++;
5622       }
5623     }
5624   }
5625   tbuf[speclen] = '\0';
5626   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5627
5628   /* Have we been working with an expanded, but not resultant, spec? */
5629   /* Also, convert back to Unix syntax if necessary. */
5630   {
5631   int rsl;
5632
5633 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5634     if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5635       rsl = rms_nam_rsll(mynam);
5636     } else
5637 #endif
5638     {
5639       rsl = rms_nam_rsl(mynam);
5640     }
5641     if (!rsl) {
5642       if (isunix) {
5643         if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
5644           if (out) Safefree(out);
5645           if (esal != NULL)
5646             PerlMem_free(esal);
5647           PerlMem_free(esa);
5648           if (outbufl != NULL)
5649             PerlMem_free(outbufl);
5650           return NULL;
5651         }
5652       }
5653       else strcpy(outbuf, tbuf);
5654     }
5655     else if (isunix) {
5656       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5657       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5658       if (do_tounixspec(tbuf,tmpfspec,0,fs_utf8) == NULL) {
5659         if (out) Safefree(out);
5660         PerlMem_free(esa);
5661         if (esal != NULL)
5662             PerlMem_free(esal);
5663         PerlMem_free(tmpfspec);
5664         if (outbufl != NULL)
5665             PerlMem_free(outbufl);
5666         return NULL;
5667       }
5668       strcpy(outbuf,tmpfspec);
5669       PerlMem_free(tmpfspec);
5670     }
5671   }
5672   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5673   sts = rms_free_search_context(&myfab); /* Free search context */
5674   PerlMem_free(esa);
5675   if (esal != NULL)
5676      PerlMem_free(esal);
5677   if (outbufl != NULL)
5678      PerlMem_free(outbufl);
5679   return outbuf;
5680 }
5681 /*}}}*/
5682 /* External entry points */
5683 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5684 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5685 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5686 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5687 char *Perl_rmsexpand_utf8
5688   (pTHX_ const char *spec, char *buf, const char *def,
5689    unsigned opt, int * fs_utf8, int * dfs_utf8)
5690 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5691 char *Perl_rmsexpand_utf8_ts
5692   (pTHX_ const char *spec, char *buf, const char *def,
5693    unsigned opt, int * fs_utf8, int * dfs_utf8)
5694 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5695
5696
5697 /*
5698 ** The following routines are provided to make life easier when
5699 ** converting among VMS-style and Unix-style directory specifications.
5700 ** All will take input specifications in either VMS or Unix syntax. On
5701 ** failure, all return NULL.  If successful, the routines listed below
5702 ** return a pointer to a buffer containing the appropriately
5703 ** reformatted spec (and, therefore, subsequent calls to that routine
5704 ** will clobber the result), while the routines of the same names with
5705 ** a _ts suffix appended will return a pointer to a mallocd string
5706 ** containing the appropriately reformatted spec.
5707 ** In all cases, only explicit syntax is altered; no check is made that
5708 ** the resulting string is valid or that the directory in question
5709 ** actually exists.
5710 **
5711 **   fileify_dirspec() - convert a directory spec into the name of the
5712 **     directory file (i.e. what you can stat() to see if it's a dir).
5713 **     The style (VMS or Unix) of the result is the same as the style
5714 **     of the parameter passed in.
5715 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5716 **     what you prepend to a filename to indicate what directory it's in).
5717 **     The style (VMS or Unix) of the result is the same as the style
5718 **     of the parameter passed in.
5719 **   tounixpath() - convert a directory spec into a Unix-style path.
5720 **   tovmspath() - convert a directory spec into a VMS-style path.
5721 **   tounixspec() - convert any file spec into a Unix-style file spec.
5722 **   tovmsspec() - convert any file spec into a VMS-style spec.
5723 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5724 **
5725 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5726 ** Permission is given to distribute this code as part of the Perl
5727 ** standard distribution under the terms of the GNU General Public
5728 ** License or the Perl Artistic License.  Copies of each may be
5729 ** found in the Perl standard distribution.
5730  */
5731
5732 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5733 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5734 {
5735     static char __fileify_retbuf[VMS_MAXRSS];
5736     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5737     char *retspec, *cp1, *cp2, *lastdir;
5738     char *trndir, *vmsdir;
5739     unsigned short int trnlnm_iter_count;
5740     int sts;
5741     if (utf8_fl != NULL)
5742         *utf8_fl = 0;
5743
5744     if (!dir || !*dir) {
5745       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5746     }
5747     dirlen = strlen(dir);
5748     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5749     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5750       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5751         dir = "/sys$disk";
5752         dirlen = 9;
5753       }
5754       else
5755         dirlen = 1;
5756     }
5757     if (dirlen > (VMS_MAXRSS - 1)) {
5758       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5759       return NULL;
5760     }
5761     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5762     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5763     if (!strpbrk(dir+1,"/]>:")  &&
5764         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5765       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5766       trnlnm_iter_count = 0;
5767       while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5768         trnlnm_iter_count++;
5769         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5770       }
5771       dirlen = strlen(trndir);
5772     }
5773     else {
5774       strncpy(trndir,dir,dirlen);
5775       trndir[dirlen] = '\0';
5776     }
5777
5778     /* At this point we are done with *dir and use *trndir which is a
5779      * copy that can be modified.  *dir must not be modified.
5780      */
5781
5782     /* If we were handed a rooted logical name or spec, treat it like a
5783      * simple directory, so that
5784      *    $ Define myroot dev:[dir.]
5785      *    ... do_fileify_dirspec("myroot",buf,1) ...
5786      * does something useful.
5787      */
5788     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5789       trndir[--dirlen] = '\0';
5790       trndir[dirlen-1] = ']';
5791     }
5792     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5793       trndir[--dirlen] = '\0';
5794       trndir[dirlen-1] = '>';
5795     }
5796
5797     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5798       /* If we've got an explicit filename, we can just shuffle the string. */
5799       if (*(cp1+1)) hasfilename = 1;
5800       /* Similarly, we can just back up a level if we've got multiple levels
5801          of explicit directories in a VMS spec which ends with directories. */
5802       else {
5803         for (cp2 = cp1; cp2 > trndir; cp2--) {
5804           if (*cp2 == '.') {
5805             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5806 /* fix-me, can not scan EFS file specs backward like this */
5807               *cp2 = *cp1; *cp1 = '\0';
5808               hasfilename = 1;
5809               break;
5810             }
5811           }
5812           if (*cp2 == '[' || *cp2 == '<') break;
5813         }
5814       }
5815     }
5816
5817     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5818     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5819     cp1 = strpbrk(trndir,"]:>");
5820     if (hasfilename || !cp1) { /* Unix-style path or filename */
5821       if (trndir[0] == '.') {
5822         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5823           PerlMem_free(trndir);
5824           PerlMem_free(vmsdir);
5825           return do_fileify_dirspec("[]",buf,ts,NULL);
5826         }
5827         else if (trndir[1] == '.' &&
5828                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5829           PerlMem_free(trndir);
5830           PerlMem_free(vmsdir);
5831           return do_fileify_dirspec("[-]",buf,ts,NULL);
5832         }
5833       }
5834       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5835         dirlen -= 1;                 /* to last element */
5836         lastdir = strrchr(trndir,'/');
5837       }
5838       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5839         /* If we have "/." or "/..", VMSify it and let the VMS code
5840          * below expand it, rather than repeating the code to handle
5841          * relative components of a filespec here */
5842         do {
5843           if (*(cp1+2) == '.') cp1++;
5844           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5845             char * ret_chr;
5846             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5847                 PerlMem_free(trndir);
5848                 PerlMem_free(vmsdir);
5849                 return NULL;
5850             }
5851             if (strchr(vmsdir,'/') != NULL) {
5852               /* If do_tovmsspec() returned it, it must have VMS syntax
5853                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5854                * the time to check this here only so we avoid a recursion
5855                * loop; otherwise, gigo.
5856                */
5857               PerlMem_free(trndir);
5858               PerlMem_free(vmsdir);
5859               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5860               return NULL;
5861             }
5862             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5863                 PerlMem_free(trndir);
5864                 PerlMem_free(vmsdir);
5865                 return NULL;
5866             }
5867             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5868             PerlMem_free(trndir);
5869             PerlMem_free(vmsdir);
5870             return ret_chr;
5871           }
5872           cp1++;
5873         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5874         lastdir = strrchr(trndir,'/');
5875       }
5876       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5877         char * ret_chr;
5878         /* Ditto for specs that end in an MFD -- let the VMS code
5879          * figure out whether it's a real device or a rooted logical. */
5880
5881         /* This should not happen any more.  Allowing the fake /000000
5882          * in a UNIX pathname causes all sorts of problems when trying
5883          * to run in UNIX emulation.  So the VMS to UNIX conversions
5884          * now remove the fake /000000 directories.
5885          */
5886
5887         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5888         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5889             PerlMem_free(trndir);
5890             PerlMem_free(vmsdir);
5891             return NULL;
5892         }
5893         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5894             PerlMem_free(trndir);
5895             PerlMem_free(vmsdir);
5896             return NULL;
5897         }
5898         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5899         PerlMem_free(trndir);
5900         PerlMem_free(vmsdir);
5901         return ret_chr;
5902       }
5903       else {
5904
5905         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5906              !(lastdir = cp1 = strrchr(trndir,']')) &&
5907              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5908         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5909           int ver; char *cp3;
5910
5911           /* For EFS or ODS-5 look for the last dot */
5912           if (decc_efs_charset) {
5913               cp2 = strrchr(cp1,'.');
5914           }
5915           if (vms_process_case_tolerant) {
5916               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5917                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5918                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5919                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5920                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5921                             (ver || *cp3)))))) {
5922                   PerlMem_free(trndir);
5923                   PerlMem_free(vmsdir);
5924                   set_errno(ENOTDIR);
5925                   set_vaxc_errno(RMS$_DIR);
5926                   return NULL;
5927               }
5928           }
5929           else {
5930               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5931                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5932                   !*(cp2+3) || *(cp2+3) != 'R' ||
5933                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5934                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5935                             (ver || *cp3)))))) {
5936                  PerlMem_free(trndir);
5937                  PerlMem_free(vmsdir);
5938                  set_errno(ENOTDIR);
5939                  set_vaxc_errno(RMS$_DIR);
5940                  return NULL;
5941               }
5942           }
5943           dirlen = cp2 - trndir;
5944         }
5945       }
5946
5947       retlen = dirlen + 6;
5948       if (buf) retspec = buf;
5949       else if (ts) Newx(retspec,retlen+1,char);
5950       else retspec = __fileify_retbuf;
5951       memcpy(retspec,trndir,dirlen);
5952       retspec[dirlen] = '\0';
5953
5954       /* We've picked up everything up to the directory file name.
5955          Now just add the type and version, and we're set. */
5956       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5957         strcat(retspec,".dir;1");
5958       else
5959         strcat(retspec,".DIR;1");
5960       PerlMem_free(trndir);
5961       PerlMem_free(vmsdir);
5962       return retspec;
5963     }
5964     else {  /* VMS-style directory spec */
5965
5966       char *esa, *esal, term, *cp;
5967       char *my_esa;
5968       int my_esa_len;
5969       unsigned long int sts, cmplen, haslower = 0;
5970       unsigned int nam_fnb;
5971       char * nam_type;
5972       struct FAB dirfab = cc$rms_fab;
5973       rms_setup_nam(savnam);
5974       rms_setup_nam(dirnam);
5975
5976       esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5977       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5978       esal = NULL;
5979 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5980       esal = PerlMem_malloc(VMS_MAXRSS);
5981       if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5982 #endif
5983       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5984       rms_bind_fab_nam(dirfab, dirnam);
5985       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5986       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
5987 #ifdef NAM$M_NO_SHORT_UPCASE
5988       if (decc_efs_case_preserve)
5989         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5990 #endif
5991
5992       for (cp = trndir; *cp; cp++)
5993         if (islower(*cp)) { haslower = 1; break; }
5994       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5995         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5996           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5997           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5998         }
5999         if (!sts) {
6000           PerlMem_free(esa);
6001           if (esal != NULL)
6002               PerlMem_free(esal);
6003           PerlMem_free(trndir);
6004           PerlMem_free(vmsdir);
6005           set_errno(EVMSERR);
6006           set_vaxc_errno(dirfab.fab$l_sts);
6007           return NULL;
6008         }
6009       }
6010       else {
6011         savnam = dirnam;
6012         /* Does the file really exist? */
6013         if (sys$search(&dirfab)& STS$K_SUCCESS) {
6014           /* Yes; fake the fnb bits so we'll check type below */
6015         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6016         }
6017         else { /* No; just work with potential name */
6018           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6019           else {
6020             int fab_sts;
6021             fab_sts = dirfab.fab$l_sts;
6022             sts = rms_free_search_context(&dirfab);
6023             PerlMem_free(esa);
6024             if (esal != NULL)
6025                 PerlMem_free(esal);
6026             PerlMem_free(trndir);
6027             PerlMem_free(vmsdir);
6028             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
6029             return NULL;
6030           }
6031         }
6032       }
6033
6034       /* Make sure we are using the right buffer */
6035       if (esal != NULL) {
6036         my_esa = esal;
6037         my_esa_len = rms_nam_esll(dirnam);
6038       } else {
6039         my_esa = esa;
6040         my_esa_len = rms_nam_esl(dirnam);
6041       }
6042       my_esa[my_esa_len] = '\0';
6043       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6044         cp1 = strchr(my_esa,']');
6045         if (!cp1) cp1 = strchr(my_esa,'>');
6046         if (cp1) {  /* Should always be true */
6047           my_esa_len -= cp1 - my_esa - 1;
6048           memmove(my_esa, cp1 + 1, my_esa_len);
6049         }
6050       }
6051       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6052         /* Yep; check version while we're at it, if it's there. */
6053         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6054         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6055           /* Something other than .DIR[;1].  Bzzt. */
6056           sts = rms_free_search_context(&dirfab);
6057           PerlMem_free(esa);
6058           if (esal != NULL)
6059              PerlMem_free(esal);
6060           PerlMem_free(trndir);
6061           PerlMem_free(vmsdir);
6062           set_errno(ENOTDIR);
6063           set_vaxc_errno(RMS$_DIR);
6064           return NULL;
6065         }
6066       }
6067
6068       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6069         /* They provided at least the name; we added the type, if necessary, */
6070         if (buf) retspec = buf;                            /* in sys$parse() */
6071         else if (ts) Newx(retspec, my_esa_len + 1, char);
6072         else retspec = __fileify_retbuf;
6073         strcpy(retspec,my_esa);
6074         sts = rms_free_search_context(&dirfab);
6075         PerlMem_free(trndir);
6076         PerlMem_free(esa);
6077         if (esal != NULL)
6078             PerlMem_free(esal);
6079         PerlMem_free(vmsdir);
6080         return retspec;
6081       }
6082       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6083         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6084         *cp1 = '\0';
6085         my_esa_len -= 9;
6086       }
6087       if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6088       if (cp1 == NULL) { /* should never happen */
6089         sts = rms_free_search_context(&dirfab);
6090         PerlMem_free(trndir);
6091         PerlMem_free(esa);
6092         if (esal != NULL)
6093             PerlMem_free(esal);
6094         PerlMem_free(vmsdir);
6095         return NULL;
6096       }
6097       term = *cp1;
6098       *cp1 = '\0';
6099       retlen = strlen(my_esa);
6100       cp1 = strrchr(my_esa,'.');
6101       /* ODS-5 directory specifications can have extra "." in them. */
6102       /* Fix-me, can not scan EFS file specifications backwards */
6103       while (cp1 != NULL) {
6104         if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6105           break;
6106         else {
6107            cp1--;
6108            while ((cp1 > my_esa) && (*cp1 != '.'))
6109              cp1--;
6110         }
6111         if (cp1 == my_esa)
6112           cp1 = NULL;
6113       }
6114
6115       if ((cp1) != NULL) {
6116         /* There's more than one directory in the path.  Just roll back. */
6117         *cp1 = term;
6118         if (buf) retspec = buf;
6119         else if (ts) Newx(retspec,retlen+7,char);
6120         else retspec = __fileify_retbuf;
6121         strcpy(retspec,my_esa);
6122       }
6123       else {
6124         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6125           /* Go back and expand rooted logical name */
6126           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6127 #ifdef NAM$M_NO_SHORT_UPCASE
6128           if (decc_efs_case_preserve)
6129             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6130 #endif
6131           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6132             sts = rms_free_search_context(&dirfab);
6133             PerlMem_free(esa);
6134             if (esal != NULL)
6135                 PerlMem_free(esal);
6136             PerlMem_free(trndir);
6137             PerlMem_free(vmsdir);
6138             set_errno(EVMSERR);
6139             set_vaxc_errno(dirfab.fab$l_sts);
6140             return NULL;
6141           }
6142
6143           /* This changes the length of the string of course */
6144           if (esal != NULL) {
6145               my_esa_len = rms_nam_esll(dirnam);
6146           } else {
6147               my_esa_len = rms_nam_esl(dirnam);
6148           }
6149
6150           retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6151           if (buf) retspec = buf;
6152           else if (ts) Newx(retspec,retlen+16,char);
6153           else retspec = __fileify_retbuf;
6154           cp1 = strstr(my_esa,"][");
6155           if (!cp1) cp1 = strstr(my_esa,"]<");
6156           dirlen = cp1 - my_esa;
6157           memcpy(retspec,my_esa,dirlen);
6158           if (!strncmp(cp1+2,"000000]",7)) {
6159             retspec[dirlen-1] = '\0';
6160             /* fix-me Not full ODS-5, just extra dots in directories for now */
6161             cp1 = retspec + dirlen - 1;
6162             while (cp1 > retspec)
6163             {
6164               if (*cp1 == '[')
6165                 break;
6166               if (*cp1 == '.') {
6167                 if (*(cp1-1) != '^')
6168                   break;
6169               }
6170               cp1--;
6171             }
6172             if (*cp1 == '.') *cp1 = ']';
6173             else {
6174               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6175               memmove(cp1+1,"000000]",7);
6176             }
6177           }
6178           else {
6179             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
6180             retspec[retlen] = '\0';
6181             /* Convert last '.' to ']' */
6182             cp1 = retspec+retlen-1;
6183             while (*cp != '[') {
6184               cp1--;
6185               if (*cp1 == '.') {
6186                 /* Do not trip on extra dots in ODS-5 directories */
6187                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6188                 break;
6189               }
6190             }
6191             if (*cp1 == '.') *cp1 = ']';
6192             else {
6193               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6194               memmove(cp1+1,"000000]",7);
6195             }
6196           }
6197         }
6198         else {  /* This is a top-level dir.  Add the MFD to the path. */
6199           if (buf) retspec = buf;
6200           else if (ts) Newx(retspec,retlen+16,char);
6201           else retspec = __fileify_retbuf;
6202           cp1 = my_esa;
6203           cp2 = retspec;
6204           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6205           strcpy(cp2,":[000000]");
6206           cp1 += 2;
6207           strcpy(cp2+9,cp1);
6208         }
6209       }
6210       sts = rms_free_search_context(&dirfab);
6211       /* We've set up the string up through the filename.  Add the
6212          type and version, and we're done. */
6213       strcat(retspec,".DIR;1");
6214
6215       /* $PARSE may have upcased filespec, so convert output to lower
6216        * case if input contained any lowercase characters. */
6217       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
6218       PerlMem_free(trndir);
6219       PerlMem_free(esa);
6220       if (esal != NULL)
6221         PerlMem_free(esal);
6222       PerlMem_free(vmsdir);
6223       return retspec;
6224     }
6225 }  /* end of do_fileify_dirspec() */
6226 /*}}}*/
6227 /* External entry points */
6228 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6229 { return do_fileify_dirspec(dir,buf,0,NULL); }
6230 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6231 { return do_fileify_dirspec(dir,buf,1,NULL); }
6232 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6233 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6234 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6235 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6236
6237 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6238 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6239 {
6240     static char __pathify_retbuf[VMS_MAXRSS];
6241     unsigned long int retlen;
6242     char *retpath, *cp1, *cp2, *trndir;
6243     unsigned short int trnlnm_iter_count;
6244     STRLEN trnlen;
6245     int sts;
6246     if (utf8_fl != NULL)
6247         *utf8_fl = 0;
6248
6249     if (!dir || !*dir) {
6250       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6251     }
6252
6253     trndir = PerlMem_malloc(VMS_MAXRSS);
6254     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
6255     if (*dir) strcpy(trndir,dir);
6256     else getcwd(trndir,VMS_MAXRSS - 1);
6257
6258     trnlnm_iter_count = 0;
6259     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6260            && my_trnlnm(trndir,trndir,0)) {
6261       trnlnm_iter_count++;
6262       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6263       trnlen = strlen(trndir);
6264
6265       /* Trap simple rooted lnms, and return lnm:[000000] */
6266       if (!strcmp(trndir+trnlen-2,".]")) {
6267         if (buf) retpath = buf;
6268         else if (ts) Newx(retpath,strlen(dir)+10,char);
6269         else retpath = __pathify_retbuf;
6270         strcpy(retpath,dir);
6271         strcat(retpath,":[000000]");
6272         PerlMem_free(trndir);
6273         return retpath;
6274       }
6275     }
6276
6277     /* At this point we do not work with *dir, but the copy in
6278      * *trndir that is modifiable.
6279      */
6280
6281     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
6282       if (*trndir == '.' && (*(trndir+1) == '\0' ||
6283                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
6284         retlen = 2 + (*(trndir+1) != '\0');
6285       else {
6286         if ( !(cp1 = strrchr(trndir,'/')) &&
6287              !(cp1 = strrchr(trndir,']')) &&
6288              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
6289         if ((cp2 = strchr(cp1,'.')) != NULL &&
6290             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
6291              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
6292               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
6293               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
6294           int ver; char *cp3;
6295
6296           /* For EFS or ODS-5 look for the last dot */
6297           if (decc_efs_charset) {
6298             cp2 = strrchr(cp1,'.');
6299           }
6300           if (vms_process_case_tolerant) {
6301               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6302                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6303                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6304                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6305                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6306                             (ver || *cp3)))))) {
6307                 PerlMem_free(trndir);
6308                 set_errno(ENOTDIR);
6309                 set_vaxc_errno(RMS$_DIR);
6310                 return NULL;
6311               }
6312           }
6313           else {
6314               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6315                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6316                   !*(cp2+3) || *(cp2+3) != 'R' ||
6317                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6318                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6319                             (ver || *cp3)))))) {
6320                 PerlMem_free(trndir);
6321                 set_errno(ENOTDIR);
6322                 set_vaxc_errno(RMS$_DIR);
6323                 return NULL;
6324               }
6325           }
6326           retlen = cp2 - trndir + 1;
6327         }
6328         else {  /* No file type present.  Treat the filename as a directory. */
6329           retlen = strlen(trndir) + 1;
6330         }
6331       }
6332       if (buf) retpath = buf;
6333       else if (ts) Newx(retpath,retlen+1,char);
6334       else retpath = __pathify_retbuf;
6335       strncpy(retpath, trndir, retlen-1);
6336       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
6337         retpath[retlen-1] = '/';      /* with '/', add it. */
6338         retpath[retlen] = '\0';
6339       }
6340       else retpath[retlen-1] = '\0';
6341     }
6342     else {  /* VMS-style directory spec */
6343       char *esa, *esal, *cp;
6344       char *my_esa;
6345       int my_esa_len;
6346       unsigned long int sts, cmplen, haslower;
6347       struct FAB dirfab = cc$rms_fab;
6348       int dirlen;
6349       rms_setup_nam(savnam);
6350       rms_setup_nam(dirnam);
6351
6352       /* If we've got an explicit filename, we can just shuffle the string. */
6353       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
6354              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
6355         if ((cp2 = strchr(cp1,'.')) != NULL) {
6356           int ver; char *cp3;
6357           if (vms_process_case_tolerant) {
6358               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
6359                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
6360                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6361                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6362                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6363                             (ver || *cp3)))))) {
6364                PerlMem_free(trndir);
6365                set_errno(ENOTDIR);
6366                set_vaxc_errno(RMS$_DIR);
6367                return NULL;
6368              }
6369           }
6370           else {
6371               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
6372                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
6373                   !*(cp2+3) || *(cp2+3) != 'R' ||
6374                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
6375                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6376                             (ver || *cp3)))))) {
6377                PerlMem_free(trndir);
6378                set_errno(ENOTDIR);
6379                set_vaxc_errno(RMS$_DIR);
6380                return NULL;
6381              }
6382           }
6383         }
6384         else {  /* No file type, so just draw name into directory part */
6385           for (cp2 = cp1; *cp2; cp2++) ;
6386         }
6387         *cp2 = *cp1;
6388         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
6389         *cp1 = '.';
6390         /* We've now got a VMS 'path'; fall through */
6391       }
6392
6393       dirlen = strlen(trndir);
6394       if (trndir[dirlen-1] == ']' ||
6395           trndir[dirlen-1] == '>' ||
6396           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
6397         if (buf) retpath = buf;
6398         else if (ts) Newx(retpath,strlen(trndir)+1,char);
6399         else retpath = __pathify_retbuf;
6400         strcpy(retpath,trndir);
6401         PerlMem_free(trndir);
6402         return retpath;
6403       }
6404       rms_set_fna(dirfab, dirnam, trndir, dirlen);
6405       esa = PerlMem_malloc(VMS_MAXRSS);
6406       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
6407       esal = NULL;
6408 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6409       esal = PerlMem_malloc(VMS_MAXRSS);
6410       if (esal == NULL) _ckvmssts(SS$_INSFMEM);
6411 #endif
6412       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6413       rms_bind_fab_nam(dirfab, dirnam);
6414       rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
6415 #ifdef NAM$M_NO_SHORT_UPCASE
6416       if (decc_efs_case_preserve)
6417           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6418 #endif
6419
6420       for (cp = trndir; *cp; cp++)
6421         if (islower(*cp)) { haslower = 1; break; }
6422
6423       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
6424         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6425           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6426           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6427         }
6428         if (!sts) {
6429           PerlMem_free(trndir);
6430           PerlMem_free(esa);
6431           if (esal != NULL)
6432             PerlMem_free(esal);
6433           set_errno(EVMSERR);
6434           set_vaxc_errno(dirfab.fab$l_sts);
6435           return NULL;
6436         }
6437       }
6438       else {
6439         savnam = dirnam;
6440         /* Does the file really exist? */
6441         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
6442           if (dirfab.fab$l_sts != RMS$_FNF) {
6443             int sts1;
6444             sts1 = rms_free_search_context(&dirfab);
6445             PerlMem_free(trndir);
6446             PerlMem_free(esa);
6447             if (esal != NULL)
6448                 PerlMem_free(esal);
6449             set_errno(EVMSERR);
6450             set_vaxc_errno(dirfab.fab$l_sts);
6451             return NULL;
6452           }
6453           dirnam = savnam; /* No; just work with potential name */
6454         }
6455       }
6456       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
6457         /* Yep; check version while we're at it, if it's there. */
6458         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6459         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
6460           int sts2;
6461           /* Something other than .DIR[;1].  Bzzt. */
6462           sts2 = rms_free_search_context(&dirfab);
6463           PerlMem_free(trndir);
6464           PerlMem_free(esa);
6465           if (esal != NULL)
6466              PerlMem_free(esal);
6467           set_errno(ENOTDIR);
6468           set_vaxc_errno(RMS$_DIR);
6469           return NULL;
6470         }
6471       }
6472       /* Make sure we are using the right buffer */
6473       if (esal != NULL) {
6474         /* We only need one, clean up the other */
6475         my_esa = esal;
6476         my_esa_len = rms_nam_esll(dirnam);
6477       } else {
6478         my_esa = esa;
6479         my_esa_len = rms_nam_esl(dirnam);
6480       }
6481
6482       /* Null terminate the buffer */
6483       my_esa[my_esa_len] = '\0';
6484
6485       /* OK, the type was fine.  Now pull any file name into the
6486          directory path. */
6487       if ((cp1 = strrchr(my_esa,']'))) *(rms_nam_typel(dirnam)) = ']';
6488       else {
6489         cp1 = strrchr(my_esa,'>');
6490         *(rms_nam_typel(dirnam)) = '>';
6491       }
6492       *cp1 = '.';
6493       *(rms_nam_typel(dirnam) + 1) = '\0';
6494       retlen = (rms_nam_typel(dirnam)) - my_esa + 2;
6495       if (buf) retpath = buf;
6496       else if (ts) Newx(retpath,retlen,char);
6497       else retpath = __pathify_retbuf;
6498       strcpy(retpath,my_esa);
6499       PerlMem_free(esa);
6500       if (esal != NULL)
6501           PerlMem_free(esal);
6502       sts = rms_free_search_context(&dirfab);
6503       /* $PARSE may have upcased filespec, so convert output to lower
6504        * case if input contained any lowercase characters. */
6505       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
6506     }
6507
6508     PerlMem_free(trndir);
6509     return retpath;
6510 }  /* end of do_pathify_dirspec() */
6511 /*}}}*/
6512 /* External entry points */
6513 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6514 { return do_pathify_dirspec(dir,buf,0,NULL); }
6515 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6516 { return do_pathify_dirspec(dir,buf,1,NULL); }
6517 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6518 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6519 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6520 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6521
6522 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
6523 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
6524 {
6525   static char __tounixspec_retbuf[VMS_MAXRSS];
6526   char *dirend, *rslt, *cp1, *cp3, *tmp;
6527   const char *cp2;
6528   int devlen, dirlen, retlen = VMS_MAXRSS;
6529   int expand = 1; /* guarantee room for leading and trailing slashes */
6530   unsigned short int trnlnm_iter_count;
6531   int cmp_rslt;
6532   if (utf8_fl != NULL)
6533     *utf8_fl = 0;
6534
6535   if (spec == NULL) return NULL;
6536   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
6537   if (buf) rslt = buf;
6538   else if (ts) {
6539     Newx(rslt, VMS_MAXRSS, char);
6540   }
6541   else rslt = __tounixspec_retbuf;
6542
6543   /* New VMS specific format needs translation
6544    * glob passes filenames with trailing '\n' and expects this preserved.
6545    */
6546   if (decc_posix_compliant_pathnames) {
6547     if (strncmp(spec, "\"^UP^", 5) == 0) {
6548       char * uspec;
6549       char *tunix;
6550       int tunix_len;
6551       int nl_flag;
6552
6553       tunix = PerlMem_malloc(VMS_MAXRSS);
6554       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
6555       strcpy(tunix, spec);
6556       tunix_len = strlen(tunix);
6557       nl_flag = 0;
6558       if (tunix[tunix_len - 1] == '\n') {
6559         tunix[tunix_len - 1] = '\"';
6560         tunix[tunix_len] = '\0';
6561         tunix_len--;
6562         nl_flag = 1;
6563       }
6564       uspec = decc$translate_vms(tunix);
6565       PerlMem_free(tunix);
6566       if ((int)uspec > 0) {
6567         strcpy(rslt,uspec);
6568         if (nl_flag) {
6569           strcat(rslt,"\n");
6570         }
6571         else {
6572           /* If we can not translate it, makemaker wants as-is */
6573           strcpy(rslt, spec);
6574         }
6575         return rslt;
6576       }
6577     }
6578   }
6579
6580   cmp_rslt = 0; /* Presume VMS */
6581   cp1 = strchr(spec, '/');
6582   if (cp1 == NULL)
6583     cmp_rslt = 0;
6584
6585     /* Look for EFS ^/ */
6586     if (decc_efs_charset) {
6587       while (cp1 != NULL) {
6588         cp2 = cp1 - 1;
6589         if (*cp2 != '^') {
6590           /* Found illegal VMS, assume UNIX */
6591           cmp_rslt = 1;
6592           break;
6593         }
6594       cp1++;
6595       cp1 = strchr(cp1, '/');
6596     }
6597   }
6598
6599   /* Look for "." and ".." */
6600   if (decc_filename_unix_report) {
6601     if (spec[0] == '.') {
6602       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6603         cmp_rslt = 1;
6604       }
6605       else {
6606         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6607           cmp_rslt = 1;
6608         }
6609       }
6610     }
6611   }
6612   /* This is already UNIX or at least nothing VMS understands */
6613   if (cmp_rslt) {
6614     strcpy(rslt,spec);
6615     return rslt;
6616   }
6617
6618   cp1 = rslt;
6619   cp2 = spec;
6620   dirend = strrchr(spec,']');
6621   if (dirend == NULL) dirend = strrchr(spec,'>');
6622   if (dirend == NULL) dirend = strchr(spec,':');
6623   if (dirend == NULL) {
6624     strcpy(rslt,spec);
6625     return rslt;
6626   }
6627
6628   /* Special case 1 - sys$posix_root = / */
6629 #if __CRTL_VER >= 70000000
6630   if (!decc_disable_posix_root) {
6631     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6632       *cp1 = '/';
6633       cp1++;
6634       cp2 = cp2 + 15;
6635       }
6636   }
6637 #endif
6638
6639   /* Special case 2 - Convert NLA0: to /dev/null */
6640 #if __CRTL_VER < 70000000
6641   cmp_rslt = strncmp(spec,"NLA0:", 5);
6642   if (cmp_rslt != 0)
6643      cmp_rslt = strncmp(spec,"nla0:", 5);
6644 #else
6645   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6646 #endif
6647   if (cmp_rslt == 0) {
6648     strcpy(rslt, "/dev/null");
6649     cp1 = cp1 + 9;
6650     cp2 = cp2 + 5;
6651     if (spec[6] != '\0') {
6652       cp1[9] == '/';
6653       cp1++;
6654       cp2++;
6655     }
6656   }
6657
6658    /* Also handle special case "SYS$SCRATCH:" */
6659 #if __CRTL_VER < 70000000
6660   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6661   if (cmp_rslt != 0)
6662      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6663 #else
6664   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6665 #endif
6666   tmp = PerlMem_malloc(VMS_MAXRSS);
6667   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6668   if (cmp_rslt == 0) {
6669   int islnm;
6670
6671     islnm = my_trnlnm(tmp, "TMP", 0);
6672     if (!islnm) {
6673       strcpy(rslt, "/tmp");
6674       cp1 = cp1 + 4;
6675       cp2 = cp2 + 12;
6676       if (spec[12] != '\0') {
6677         cp1[4] == '/';
6678         cp1++;
6679         cp2++;
6680       }
6681     }
6682   }
6683
6684   if (*cp2 != '[' && *cp2 != '<') {
6685     *(cp1++) = '/';
6686   }
6687   else {  /* the VMS spec begins with directories */
6688     cp2++;
6689     if (*cp2 == ']' || *cp2 == '>') {
6690       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6691       PerlMem_free(tmp);
6692       return rslt;
6693     }
6694     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6695       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6696         if (ts) Safefree(rslt);
6697         PerlMem_free(tmp);
6698         return NULL;
6699       }
6700       trnlnm_iter_count = 0;
6701       do {
6702         cp3 = tmp;
6703         while (*cp3 != ':' && *cp3) cp3++;
6704         *(cp3++) = '\0';
6705         if (strchr(cp3,']') != NULL) break;
6706         trnlnm_iter_count++;
6707         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6708       } while (vmstrnenv(tmp,tmp,0,fildev,0));
6709       if (ts && !buf &&
6710           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6711         retlen = devlen + dirlen;
6712         Renew(rslt,retlen+1+2*expand,char);
6713         cp1 = rslt;
6714       }
6715       cp3 = tmp;
6716       *(cp1++) = '/';
6717       while (*cp3) {
6718         *(cp1++) = *(cp3++);
6719         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6720             PerlMem_free(tmp);
6721             return NULL; /* No room */
6722         }
6723       }
6724       *(cp1++) = '/';
6725     }
6726     if ((*cp2 == '^')) {
6727         /* EFS file escape, pass the next character as is */
6728         /* Fix me: HEX encoding for Unicode not implemented */
6729         cp2++;
6730     }
6731     else if ( *cp2 == '.') {
6732       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6733         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6734         cp2 += 3;
6735       }
6736       else cp2++;
6737     }
6738   }
6739   PerlMem_free(tmp);
6740   for (; cp2 <= dirend; cp2++) {
6741     if ((*cp2 == '^')) {
6742         /* EFS file escape, pass the next character as is */
6743         /* Fix me: HEX encoding for Unicode not implemented */
6744         *(cp1++) = *(++cp2);
6745         /* An escaped dot stays as is -- don't convert to slash */
6746         if (*cp2 == '.') cp2++;
6747     }
6748     if (*cp2 == ':') {
6749       *(cp1++) = '/';
6750       if (*(cp2+1) == '[') cp2++;
6751     }
6752     else if (*cp2 == ']' || *cp2 == '>') {
6753       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6754     }
6755     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6756       *(cp1++) = '/';
6757       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6758         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6759                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6760         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6761             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6762       }
6763       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6764         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6765         cp2 += 2;
6766       }
6767     }
6768     else if (*cp2 == '-') {
6769       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6770         while (*cp2 == '-') {
6771           cp2++;
6772           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6773         }
6774         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6775           if (ts) Safefree(rslt);                        /* filespecs like */
6776           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
6777           return NULL;
6778         }
6779       }
6780       else *(cp1++) = *cp2;
6781     }
6782     else *(cp1++) = *cp2;
6783   }
6784   while (*cp2) {
6785     if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++;  /* '^.' --> '.' */
6786     *(cp1++) = *(cp2++);
6787   }
6788   *cp1 = '\0';
6789
6790   /* This still leaves /000000/ when working with a
6791    * VMS device root or concealed root.
6792    */
6793   {
6794   int ulen;
6795   char * zeros;
6796
6797       ulen = strlen(rslt);
6798
6799       /* Get rid of "000000/ in rooted filespecs */
6800       if (ulen > 7) {
6801         zeros = strstr(rslt, "/000000/");
6802         if (zeros != NULL) {
6803           int mlen;
6804           mlen = ulen - (zeros - rslt) - 7;
6805           memmove(zeros, &zeros[7], mlen);
6806           ulen = ulen - 7;
6807           rslt[ulen] = '\0';
6808         }
6809       }
6810   }
6811
6812   return rslt;
6813
6814 }  /* end of do_tounixspec() */
6815 /*}}}*/
6816 /* External entry points */
6817 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6818   { return do_tounixspec(spec,buf,0, NULL); }
6819 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6820   { return do_tounixspec(spec,buf,1, NULL); }
6821 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6822   { return do_tounixspec(spec,buf,0, utf8_fl); }
6823 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6824   { return do_tounixspec(spec,buf,1, utf8_fl); }
6825
6826 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6827
6828 /*
6829  This procedure is used to identify if a path is based in either
6830  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6831  it returns the OpenVMS format directory for it.
6832
6833  It is expecting specifications of only '/' or '/xxxx/'
6834
6835  If a posix root does not exist, or 'xxxx' is not a directory
6836  in the posix root, it returns a failure.
6837
6838  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6839
6840  It is used only internally by posix_to_vmsspec_hardway().
6841  */
6842
6843 static int posix_root_to_vms
6844   (char *vmspath, int vmspath_len,
6845    const char *unixpath,
6846    const int * utf8_fl)
6847 {
6848 int sts;
6849 struct FAB myfab = cc$rms_fab;
6850 rms_setup_nam(mynam);
6851 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6852 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6853 char * esa, * esal, * rsa, * rsal;
6854 char *vms_delim;
6855 int dir_flag;
6856 int unixlen;
6857
6858     dir_flag = 0;
6859     vmspath[0] = '\0';
6860     unixlen = strlen(unixpath);
6861     if (unixlen == 0) {
6862       return RMS$_FNF;
6863     }
6864
6865 #if __CRTL_VER >= 80200000
6866   /* If not a posix spec already, convert it */
6867   if (decc_posix_compliant_pathnames) {
6868     if (strncmp(unixpath,"\"^UP^",5) != 0) {
6869       sprintf(vmspath,"\"^UP^%s\"",unixpath);
6870     }
6871     else {
6872       /* This is already a VMS specification, no conversion */
6873       unixlen--;
6874       strncpy(vmspath,unixpath, vmspath_len);
6875     }
6876   }
6877   else
6878 #endif
6879   {
6880   int path_len;
6881   int i,j;
6882
6883      /* Check to see if this is under the POSIX root */
6884      if (decc_disable_posix_root) {
6885         return RMS$_FNF;
6886      }
6887
6888      /* Skip leading / */
6889      if (unixpath[0] == '/') {
6890         unixpath++;
6891         unixlen--;
6892      }
6893
6894
6895      strcpy(vmspath,"SYS$POSIX_ROOT:");
6896
6897      /* If this is only the / , or blank, then... */
6898      if (unixpath[0] == '\0') {
6899         /* by definition, this is the answer */
6900         return SS$_NORMAL;
6901      }
6902
6903      /* Need to look up a directory */
6904      vmspath[15] = '[';
6905      vmspath[16] = '\0';
6906
6907      /* Copy and add '^' escape characters as needed */
6908      j = 16;
6909      i = 0;
6910      while (unixpath[i] != 0) {
6911      int k;
6912
6913         j += copy_expand_unix_filename_escape
6914             (&vmspath[j], &unixpath[i], &k, utf8_fl);
6915         i += k;
6916      }
6917
6918      path_len = strlen(vmspath);
6919      if (vmspath[path_len - 1] == '/')
6920         path_len--;
6921      vmspath[path_len] = ']';
6922      path_len++;
6923      vmspath[path_len] = '\0';
6924
6925   }
6926   vmspath[vmspath_len] = 0;
6927   if (unixpath[unixlen - 1] == '/')
6928   dir_flag = 1;
6929   esal = PerlMem_malloc(VMS_MAXRSS);
6930   if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6931   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6932   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6933   rsal = PerlMem_malloc(VMS_MAXRSS);
6934   if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6935   rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6936   if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6937   rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
6938   rms_bind_fab_nam(myfab, mynam);
6939   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
6940   rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
6941   if (decc_efs_case_preserve)
6942     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6943 #ifdef NAML$M_OPEN_SPECIAL
6944   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6945 #endif
6946
6947   /* Set up the remaining naml fields */
6948   sts = sys$parse(&myfab);
6949
6950   /* It failed! Try again as a UNIX filespec */
6951   if (!(sts & 1)) {
6952     PerlMem_free(esal);
6953     PerlMem_free(esa);
6954     PerlMem_free(rsal);
6955     PerlMem_free(rsa);
6956     return sts;
6957   }
6958
6959    /* get the Device ID and the FID */
6960    sts = sys$search(&myfab);
6961
6962    /* These are no longer needed */
6963    PerlMem_free(esa);
6964    PerlMem_free(rsal);
6965    PerlMem_free(rsa);
6966
6967    /* on any failure, returned the POSIX ^UP^ filespec */
6968    if (!(sts & 1)) {
6969       PerlMem_free(esal);
6970       return sts;
6971    }
6972    specdsc.dsc$a_pointer = vmspath;
6973    specdsc.dsc$w_length = vmspath_len;
6974
6975    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6976    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6977    sts = lib$fid_to_name
6978       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6979
6980   /* on any failure, returned the POSIX ^UP^ filespec */
6981   if (!(sts & 1)) {
6982      /* This can happen if user does not have permission to read directories */
6983      if (strncmp(unixpath,"\"^UP^",5) != 0)
6984        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6985      else
6986        strcpy(vmspath, unixpath);
6987   }
6988   else {
6989     vmspath[specdsc.dsc$w_length] = 0;
6990
6991     /* Are we expecting a directory? */
6992     if (dir_flag != 0) {
6993     int i;
6994     char *eptr;
6995
6996       eptr = NULL;
6997
6998       i = specdsc.dsc$w_length - 1;
6999       while (i > 0) {
7000       int zercnt;
7001         zercnt = 0;
7002         /* Version must be '1' */
7003         if (vmspath[i--] != '1')
7004           break;
7005         /* Version delimiter is one of ".;" */
7006         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7007           break;
7008         i--;
7009         if (vmspath[i--] != 'R')
7010           break;
7011         if (vmspath[i--] != 'I')
7012           break;
7013         if (vmspath[i--] != 'D')
7014           break;
7015         if (vmspath[i--] != '.')
7016           break;
7017         eptr = &vmspath[i+1];
7018         while (i > 0) {
7019           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7020             if (vmspath[i-1] != '^') {
7021               if (zercnt != 6) {
7022                 *eptr = vmspath[i];
7023                 eptr[1] = '\0';
7024                 vmspath[i] = '.';
7025                 break;
7026               }
7027               else {
7028                 /* Get rid of 6 imaginary zero directory filename */
7029                 vmspath[i+1] = '\0';
7030               }
7031             }
7032           }
7033           if (vmspath[i] == '0')
7034             zercnt++;
7035           else
7036             zercnt = 10;
7037           i--;
7038         }
7039         break;
7040       }
7041     }
7042   }
7043   PerlMem_free(esal);
7044   return sts;
7045 }
7046
7047 /* /dev/mumble needs to be handled special.
7048    /dev/null becomes NLA0:, And there is the potential for other stuff
7049    like /dev/tty which may need to be mapped to something.
7050 */
7051
7052 static int
7053 slash_dev_special_to_vms
7054    (const char * unixptr,
7055     char * vmspath,
7056     int vmspath_len)
7057 {
7058 char * nextslash;
7059 int len;
7060 int cmp;
7061 int islnm;
7062
7063     unixptr += 4;
7064     nextslash = strchr(unixptr, '/');
7065     len = strlen(unixptr);
7066     if (nextslash != NULL)
7067         len = nextslash - unixptr;
7068     cmp = strncmp("null", unixptr, 5);
7069     if (cmp == 0) {
7070         if (vmspath_len >= 6) {
7071             strcpy(vmspath, "_NLA0:");
7072             return SS$_NORMAL;
7073         }
7074     }
7075 }
7076
7077
7078 /* The built in routines do not understand perl's special needs, so
7079     doing a manual conversion from UNIX to VMS
7080
7081     If the utf8_fl is not null and points to a non-zero value, then
7082     treat 8 bit characters as UTF-8.
7083
7084     The sequence starting with '$(' and ending with ')' will be passed
7085     through with out interpretation instead of being escaped.
7086
7087   */
7088 static int posix_to_vmsspec_hardway
7089   (char *vmspath, int vmspath_len,
7090    const char *unixpath,
7091    int dir_flag,
7092    int * utf8_fl) {
7093
7094 char *esa;
7095 const char *unixptr;
7096 const char *unixend;
7097 char *vmsptr;
7098 const char *lastslash;
7099 const char *lastdot;
7100 int unixlen;
7101 int vmslen;
7102 int dir_start;
7103 int dir_dot;
7104 int quoted;
7105 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7106 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7107
7108   if (utf8_fl != NULL)
7109     *utf8_fl = 0;
7110
7111   unixptr = unixpath;
7112   dir_dot = 0;
7113
7114   /* Ignore leading "/" characters */
7115   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7116     unixptr++;
7117   }
7118   unixlen = strlen(unixptr);
7119
7120   /* Do nothing with blank paths */
7121   if (unixlen == 0) {
7122     vmspath[0] = '\0';
7123     return SS$_NORMAL;
7124   }
7125
7126   quoted = 0;
7127   /* This could have a "^UP^ on the front */
7128   if (strncmp(unixptr,"\"^UP^",5) == 0) {
7129     quoted = 1;
7130     unixptr+= 5;
7131     unixlen-= 5;
7132   }
7133
7134   lastslash = strrchr(unixptr,'/');
7135   lastdot = strrchr(unixptr,'.');
7136   unixend = strrchr(unixptr,'\"');
7137   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7138     unixend = unixptr + unixlen;
7139   }
7140
7141   /* last dot is last dot or past end of string */
7142   if (lastdot == NULL)
7143     lastdot = unixptr + unixlen;
7144
7145   /* if no directories, set last slash to beginning of string */
7146   if (lastslash == NULL) {
7147     lastslash = unixptr;
7148   }
7149   else {
7150     /* Watch out for trailing "." after last slash, still a directory */
7151     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7152       lastslash = unixptr + unixlen;
7153     }
7154
7155     /* Watch out for traiing ".." after last slash, still a directory */
7156     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7157       lastslash = unixptr + unixlen;
7158     }
7159
7160     /* dots in directories are aways escaped */
7161     if (lastdot < lastslash)
7162       lastdot = unixptr + unixlen;
7163   }
7164
7165   /* if (unixptr < lastslash) then we are in a directory */
7166
7167   dir_start = 0;
7168
7169   vmsptr = vmspath;
7170   vmslen = 0;
7171
7172   /* Start with the UNIX path */
7173   if (*unixptr != '/') {
7174     /* relative paths */
7175
7176     /* If allowing logical names on relative pathnames, then handle here */
7177     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7178         !decc_posix_compliant_pathnames) {
7179     char * nextslash;
7180     int seg_len;
7181     char * trn;
7182     int islnm;
7183
7184         /* Find the next slash */
7185         nextslash = strchr(unixptr,'/');
7186
7187         esa = PerlMem_malloc(vmspath_len);
7188         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7189
7190         trn = PerlMem_malloc(VMS_MAXRSS);
7191         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7192
7193         if (nextslash != NULL) {
7194
7195             seg_len = nextslash - unixptr;
7196             strncpy(esa, unixptr, seg_len);
7197             esa[seg_len] = 0;
7198         }
7199         else {
7200             strcpy(esa, unixptr);
7201             seg_len = strlen(unixptr);
7202         }
7203         /* trnlnm(section) */
7204         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7205
7206         if (islnm) {
7207             /* Now fix up the directory */
7208
7209             /* Split up the path to find the components */
7210             sts = vms_split_path
7211                   (trn,
7212                    &v_spec,
7213                    &v_len,
7214                    &r_spec,
7215                    &r_len,
7216                    &d_spec,
7217                    &d_len,
7218                    &n_spec,
7219                    &n_len,
7220                    &e_spec,
7221                    &e_len,
7222                    &vs_spec,
7223                    &vs_len);
7224
7225             while (sts == 0) {
7226             char * strt;
7227             int cmp;
7228
7229                 /* A logical name must be a directory  or the full
7230                    specification.  It is only a full specification if
7231                    it is the only component */
7232                 if ((unixptr[seg_len] == '\0') ||
7233                     (unixptr[seg_len+1] == '\0')) {
7234
7235                     /* Is a directory being required? */
7236                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7237                         /* Not a logical name */
7238                         break;
7239                     }
7240
7241
7242                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7243                         /* This must be a directory */
7244                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7245                             strcpy(vmsptr, esa);
7246                             vmslen=strlen(vmsptr);
7247                             vmsptr[vmslen] = ':';
7248                             vmslen++;
7249                             vmsptr[vmslen] = '\0';
7250                             return SS$_NORMAL;
7251                         }
7252                     }
7253
7254                 }
7255
7256
7257                 /* must be dev/directory - ignore version */
7258                 if ((n_len + e_len) != 0)
7259                     break;
7260
7261                 /* transfer the volume */
7262                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7263                     strncpy(vmsptr, v_spec, v_len);
7264                     vmsptr += v_len;
7265                     vmsptr[0] = '\0';
7266                     vmslen += v_len;
7267                 }
7268
7269                 /* unroot the rooted directory */
7270                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7271                     r_spec[0] = '[';
7272                     r_spec[r_len - 1] = ']';
7273
7274                     /* This should not be there, but nothing is perfect */
7275                     if (r_len > 9) {
7276                         cmp = strcmp(&r_spec[1], "000000.");
7277                         if (cmp == 0) {
7278                             r_spec += 7;
7279                             r_spec[7] = '[';
7280                             r_len -= 7;
7281                             if (r_len == 2)
7282                                 r_len = 0;
7283                         }
7284                     }
7285                     if (r_len > 0) {
7286                         strncpy(vmsptr, r_spec, r_len);
7287                         vmsptr += r_len;
7288                         vmslen += r_len;
7289                         vmsptr[0] = '\0';
7290                     }
7291                 }
7292                 /* Bring over the directory. */
7293                 if ((d_len > 0) &&
7294                     ((d_len + vmslen) < vmspath_len)) {
7295                     d_spec[0] = '[';
7296                     d_spec[d_len - 1] = ']';
7297                     if (d_len > 9) {
7298                         cmp = strcmp(&d_spec[1], "000000.");
7299                         if (cmp == 0) {
7300                             d_spec += 7;
7301                             d_spec[7] = '[';
7302                             d_len -= 7;
7303                             if (d_len == 2)
7304                                 d_len = 0;
7305                         }
7306                     }
7307
7308                     if (r_len > 0) {
7309                         /* Remove the redundant root */
7310                         if (r_len > 0) {
7311                             /* remove the ][ */
7312                             vmsptr--;
7313                             vmslen--;
7314                             d_spec++;
7315                             d_len--;
7316                         }
7317                         strncpy(vmsptr, d_spec, d_len);
7318                             vmsptr += d_len;
7319                             vmslen += d_len;
7320                             vmsptr[0] = '\0';
7321                     }
7322                 }
7323                 break;
7324             }
7325         }
7326
7327         PerlMem_free(esa);
7328         PerlMem_free(trn);
7329     }
7330
7331     if (lastslash > unixptr) {
7332     int dotdir_seen;
7333
7334       /* skip leading ./ */
7335       dotdir_seen = 0;
7336       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7337         dotdir_seen = 1;
7338         unixptr++;
7339         unixptr++;
7340       }
7341
7342       /* Are we still in a directory? */
7343       if (unixptr <= lastslash) {
7344         *vmsptr++ = '[';
7345         vmslen = 1;
7346         dir_start = 1;
7347
7348         /* if not backing up, then it is relative forward. */
7349         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7350               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7351           *vmsptr++ = '.';
7352           vmslen++;
7353           dir_dot = 1;
7354           }
7355        }
7356        else {
7357          if (dotdir_seen) {
7358            /* Perl wants an empty directory here to tell the difference
7359             * between a DCL commmand and a filename
7360             */
7361           *vmsptr++ = '[';
7362           *vmsptr++ = ']';
7363           vmslen = 2;
7364         }
7365       }
7366     }
7367     else {
7368       /* Handle two special files . and .. */
7369       if (unixptr[0] == '.') {
7370         if (&unixptr[1] == unixend) {
7371           *vmsptr++ = '[';
7372           *vmsptr++ = ']';
7373           vmslen += 2;
7374           *vmsptr++ = '\0';
7375           return SS$_NORMAL;
7376         }
7377         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7378           *vmsptr++ = '[';
7379           *vmsptr++ = '-';
7380           *vmsptr++ = ']';
7381           vmslen += 3;
7382           *vmsptr++ = '\0';
7383           return SS$_NORMAL;
7384         }
7385       }
7386     }
7387   }
7388   else {        /* Absolute PATH handling */
7389   int sts;
7390   char * nextslash;
7391   int seg_len;
7392     /* Need to find out where root is */
7393
7394     /* In theory, this procedure should never get an absolute POSIX pathname
7395      * that can not be found on the POSIX root.
7396      * In practice, that can not be relied on, and things will show up
7397      * here that are a VMS device name or concealed logical name instead.
7398      * So to make things work, this procedure must be tolerant.
7399      */
7400     esa = PerlMem_malloc(vmspath_len);
7401     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7402
7403     sts = SS$_NORMAL;
7404     nextslash = strchr(&unixptr[1],'/');
7405     seg_len = 0;
7406     if (nextslash != NULL) {
7407     int cmp;
7408       seg_len = nextslash - &unixptr[1];
7409       strncpy(vmspath, unixptr, seg_len + 1);
7410       vmspath[seg_len+1] = 0;
7411       cmp = 1;
7412       if (seg_len == 3) {
7413         cmp = strncmp(vmspath, "dev", 4);
7414         if (cmp == 0) {
7415             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7416             if (sts = SS$_NORMAL)
7417                 return SS$_NORMAL;
7418         }
7419       }
7420       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7421     }
7422
7423     if ($VMS_STATUS_SUCCESS(sts)) {
7424       /* This is verified to be a real path */
7425
7426       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7427       if ($VMS_STATUS_SUCCESS(sts)) {
7428         strcpy(vmspath, esa);
7429         vmslen = strlen(vmspath);
7430         vmsptr = vmspath + vmslen;
7431         unixptr++;
7432         if (unixptr < lastslash) {
7433         char * rptr;
7434           vmsptr--;
7435           *vmsptr++ = '.';
7436           dir_start = 1;
7437           dir_dot = 1;
7438           if (vmslen > 7) {
7439           int cmp;
7440             rptr = vmsptr - 7;
7441             cmp = strcmp(rptr,"000000.");
7442             if (cmp == 0) {
7443               vmslen -= 7;
7444               vmsptr -= 7;
7445               vmsptr[1] = '\0';
7446             } /* removing 6 zeros */
7447           } /* vmslen < 7, no 6 zeros possible */
7448         } /* Not in a directory */
7449       } /* Posix root found */
7450       else {
7451         /* No posix root, fall back to default directory */
7452         strcpy(vmspath, "SYS$DISK:[");
7453         vmsptr = &vmspath[10];
7454         vmslen = 10;
7455         if (unixptr > lastslash) {
7456            *vmsptr = ']';
7457            vmsptr++;
7458            vmslen++;
7459         }
7460         else {
7461            dir_start = 1;
7462         }
7463       }
7464     } /* end of verified real path handling */
7465     else {
7466     int add_6zero;
7467     int islnm;
7468
7469       /* Ok, we have a device or a concealed root that is not in POSIX
7470        * or we have garbage.  Make the best of it.
7471        */
7472
7473       /* Posix to VMS destroyed this, so copy it again */
7474       strncpy(vmspath, &unixptr[1], seg_len);
7475       vmspath[seg_len] = 0;
7476       vmslen = seg_len;
7477       vmsptr = &vmsptr[vmslen];
7478       islnm = 0;
7479
7480       /* Now do we need to add the fake 6 zero directory to it? */
7481       add_6zero = 1;
7482       if ((*lastslash == '/') && (nextslash < lastslash)) {
7483         /* No there is another directory */
7484         add_6zero = 0;
7485       }
7486       else {
7487       int trnend;
7488       int cmp;
7489
7490         /* now we have foo:bar or foo:[000000]bar to decide from */
7491         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7492
7493         if (!islnm && !decc_posix_compliant_pathnames) {
7494
7495             cmp = strncmp("bin", vmspath, 4);
7496             if (cmp == 0) {
7497                 /* bin => SYS$SYSTEM: */
7498                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7499             }
7500             else {
7501                 /* tmp => SYS$SCRATCH: */
7502                 cmp = strncmp("tmp", vmspath, 4);
7503                 if (cmp == 0) {
7504                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7505                 }
7506             }
7507         }
7508
7509         trnend = islnm ? islnm - 1 : 0;
7510
7511         /* if this was a logical name, ']' or '>' must be present */
7512         /* if not a logical name, then assume a device and hope. */
7513         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7514
7515         /* if log name and trailing '.' then rooted - treat as device */
7516         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7517
7518         /* Fix me, if not a logical name, a device lookup should be
7519          * done to see if the device is file structured.  If the device
7520          * is not file structured, the 6 zeros should not be put on.
7521          *
7522          * As it is, perl is occasionally looking for dev:[000000]tty.
7523          * which looks a little strange.
7524          *
7525          * Not that easy to detect as "/dev" may be file structured with
7526          * special device files.
7527          */
7528
7529         if ((add_6zero == 0) && (*nextslash == '/') &&
7530             (&nextslash[1] == unixend)) {
7531           /* No real directory present */
7532           add_6zero = 1;
7533         }
7534       }
7535
7536       /* Put the device delimiter on */
7537       *vmsptr++ = ':';
7538       vmslen++;
7539       unixptr = nextslash;
7540       unixptr++;
7541
7542       /* Start directory if needed */
7543       if (!islnm || add_6zero) {
7544         *vmsptr++ = '[';
7545         vmslen++;
7546         dir_start = 1;
7547       }
7548
7549       /* add fake 000000] if needed */
7550       if (add_6zero) {
7551         *vmsptr++ = '0';
7552         *vmsptr++ = '0';
7553         *vmsptr++ = '0';
7554         *vmsptr++ = '0';
7555         *vmsptr++ = '0';
7556         *vmsptr++ = '0';
7557         *vmsptr++ = ']';
7558         vmslen += 7;
7559         dir_start = 0;
7560       }
7561
7562     } /* non-POSIX translation */
7563     PerlMem_free(esa);
7564   } /* End of relative/absolute path handling */
7565
7566   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7567   int dash_flag;
7568   int in_cnt;
7569   int out_cnt;
7570
7571     dash_flag = 0;
7572
7573     if (dir_start != 0) {
7574
7575       /* First characters in a directory are handled special */
7576       while ((*unixptr == '/') ||
7577              ((*unixptr == '.') &&
7578               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7579                 (&unixptr[1]==unixend)))) {
7580       int loop_flag;
7581
7582         loop_flag = 0;
7583
7584         /* Skip redundant / in specification */
7585         while ((*unixptr == '/') && (dir_start != 0)) {
7586           loop_flag = 1;
7587           unixptr++;
7588           if (unixptr == lastslash)
7589             break;
7590         }
7591         if (unixptr == lastslash)
7592           break;
7593
7594         /* Skip redundant ./ characters */
7595         while ((*unixptr == '.') &&
7596                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
7597           loop_flag = 1;
7598           unixptr++;
7599           if (unixptr == lastslash)
7600             break;
7601           if (*unixptr == '/')
7602             unixptr++;
7603         }
7604         if (unixptr == lastslash)
7605           break;
7606
7607         /* Skip redundant ../ characters */
7608         while ((*unixptr == '.') && (unixptr[1] == '.') &&
7609              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
7610           /* Set the backing up flag */
7611           loop_flag = 1;
7612           dir_dot = 0;
7613           dash_flag = 1;
7614           *vmsptr++ = '-';
7615           vmslen++;
7616           unixptr++; /* first . */
7617           unixptr++; /* second . */
7618           if (unixptr == lastslash)
7619             break;
7620           if (*unixptr == '/') /* The slash */
7621             unixptr++;
7622         }
7623         if (unixptr == lastslash)
7624           break;
7625
7626         /* To do: Perl expects /.../ to be translated to [...] on VMS */
7627         /* Not needed when VMS is pretending to be UNIX. */
7628
7629         /* Is this loop stuck because of too many dots? */
7630         if (loop_flag == 0) {
7631           /* Exit the loop and pass the rest through */
7632           break;
7633         }
7634       }
7635
7636       /* Are we done with directories yet? */
7637       if (unixptr >= lastslash) {
7638
7639         /* Watch out for trailing dots */
7640         if (dir_dot != 0) {
7641             vmslen --;
7642             vmsptr--;
7643         }
7644         *vmsptr++ = ']';
7645         vmslen++;
7646         dash_flag = 0;
7647         dir_start = 0;
7648         if (*unixptr == '/')
7649           unixptr++;
7650       }
7651       else {
7652         /* Have we stopped backing up? */
7653         if (dash_flag) {
7654           *vmsptr++ = '.';
7655           vmslen++;
7656           dash_flag = 0;
7657           /* dir_start continues to be = 1 */
7658         }
7659         if (*unixptr == '-') {
7660           *vmsptr++ = '^';
7661           *vmsptr++ = *unixptr++;
7662           vmslen += 2;
7663           dir_start = 0;
7664
7665           /* Now are we done with directories yet? */
7666           if (unixptr >= lastslash) {
7667
7668             /* Watch out for trailing dots */
7669             if (dir_dot != 0) {
7670               vmslen --;
7671               vmsptr--;
7672             }
7673
7674             *vmsptr++ = ']';
7675             vmslen++;
7676             dash_flag = 0;
7677             dir_start = 0;
7678           }
7679         }
7680       }
7681     }
7682
7683     /* All done? */
7684     if (unixptr >= unixend)
7685       break;
7686
7687     /* Normal characters - More EFS work probably needed */
7688     dir_start = 0;
7689     dir_dot = 0;
7690
7691     switch(*unixptr) {
7692     case '/':
7693         /* remove multiple / */
7694         while (unixptr[1] == '/') {
7695            unixptr++;
7696         }
7697         if (unixptr == lastslash) {
7698           /* Watch out for trailing dots */
7699           if (dir_dot != 0) {
7700             vmslen --;
7701             vmsptr--;
7702           }
7703           *vmsptr++ = ']';
7704         }
7705         else {
7706           dir_start = 1;
7707           *vmsptr++ = '.';
7708           dir_dot = 1;
7709
7710           /* To do: Perl expects /.../ to be translated to [...] on VMS */
7711           /* Not needed when VMS is pretending to be UNIX. */
7712
7713         }
7714         dash_flag = 0;
7715         if (unixptr != unixend)
7716           unixptr++;
7717         vmslen++;
7718         break;
7719     case '.':
7720         if ((unixptr < lastdot) || (unixptr < lastslash) ||
7721             (&unixptr[1] == unixend)) {
7722           *vmsptr++ = '^';
7723           *vmsptr++ = '.';
7724           vmslen += 2;
7725           unixptr++;
7726
7727           /* trailing dot ==> '^..' on VMS */
7728           if (unixptr == unixend) {
7729             *vmsptr++ = '.';
7730             vmslen++;
7731             unixptr++;
7732           }
7733           break;
7734         }
7735
7736         *vmsptr++ = *unixptr++;
7737         vmslen ++;
7738         break;
7739     case '"':
7740         if (quoted && (&unixptr[1] == unixend)) {
7741             unixptr++;
7742             break;
7743         }
7744         in_cnt = copy_expand_unix_filename_escape
7745                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7746         vmsptr += out_cnt;
7747         unixptr += in_cnt;
7748         break;
7749     case '~':
7750     case ';':
7751     case '\\':
7752     case '?':
7753     case ' ':
7754     default:
7755         in_cnt = copy_expand_unix_filename_escape
7756                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7757         vmsptr += out_cnt;
7758         unixptr += in_cnt;
7759         break;
7760     }
7761   }
7762
7763   /* Make sure directory is closed */
7764   if (unixptr == lastslash) {
7765     char *vmsptr2;
7766     vmsptr2 = vmsptr - 1;
7767
7768     if (*vmsptr2 != ']') {
7769       *vmsptr2--;
7770
7771       /* directories do not end in a dot bracket */
7772       if (*vmsptr2 == '.') {
7773         vmsptr2--;
7774
7775         /* ^. is allowed */
7776         if (*vmsptr2 != '^') {
7777           vmsptr--; /* back up over the dot */
7778         }
7779       }
7780       *vmsptr++ = ']';
7781     }
7782   }
7783   else {
7784     char *vmsptr2;
7785     /* Add a trailing dot if a file with no extension */
7786     vmsptr2 = vmsptr - 1;
7787     if ((vmslen > 1) &&
7788         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7789         (*vmsptr2 != ')') && (*lastdot != '.')) {
7790         *vmsptr++ = '.';
7791         vmslen++;
7792     }
7793   }
7794
7795   *vmsptr = '\0';
7796   return SS$_NORMAL;
7797 }
7798 #endif
7799
7800  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7801 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7802 {
7803 char * result;
7804 int utf8_flag;
7805
7806    /* If a UTF8 flag is being passed, honor it */
7807    utf8_flag = 0;
7808    if (utf8_fl != NULL) {
7809      utf8_flag = *utf8_fl;
7810     *utf8_fl = 0;
7811    }
7812
7813    if (utf8_flag) {
7814      /* If there is a possibility of UTF8, then if any UTF8 characters
7815         are present, then they must be converted to VTF-7
7816       */
7817      result = strcpy(rslt, path); /* FIX-ME */
7818    }
7819    else
7820      result = strcpy(rslt, path);
7821
7822    return result;
7823 }
7824
7825
7826 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7827 static char *mp_do_tovmsspec
7828    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7829   static char __tovmsspec_retbuf[VMS_MAXRSS];
7830   char *rslt, *dirend;
7831   char *lastdot;
7832   char *vms_delim;
7833   register char *cp1;
7834   const char *cp2;
7835   unsigned long int infront = 0, hasdir = 1;
7836   int rslt_len;
7837   int no_type_seen;
7838   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7839   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7840
7841   if (path == NULL) return NULL;
7842   rslt_len = VMS_MAXRSS-1;
7843   if (buf) rslt = buf;
7844   else if (ts) Newx(rslt, VMS_MAXRSS, char);
7845   else rslt = __tovmsspec_retbuf;
7846
7847   /* '.' and '..' are "[]" and "[-]" for a quick check */
7848   if (path[0] == '.') {
7849     if (path[1] == '\0') {
7850       strcpy(rslt,"[]");
7851       if (utf8_flag != NULL)
7852         *utf8_flag = 0;
7853       return rslt;
7854     }
7855     else {
7856       if (path[1] == '.' && path[2] == '\0') {
7857         strcpy(rslt,"[-]");
7858         if (utf8_flag != NULL)
7859            *utf8_flag = 0;
7860         return rslt;
7861       }
7862     }
7863   }
7864
7865    /* Posix specifications are now a native VMS format */
7866   /*--------------------------------------------------*/
7867 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7868   if (decc_posix_compliant_pathnames) {
7869     if (strncmp(path,"\"^UP^",5) == 0) {
7870       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7871       return rslt;
7872     }
7873   }
7874 #endif
7875
7876   /* This is really the only way to see if this is already in VMS format */
7877   sts = vms_split_path
7878        (path,
7879         &v_spec,
7880         &v_len,
7881         &r_spec,
7882         &r_len,
7883         &d_spec,
7884         &d_len,
7885         &n_spec,
7886         &n_len,
7887         &e_spec,
7888         &e_len,
7889         &vs_spec,
7890         &vs_len);
7891   if (sts == 0) {
7892     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7893        replacement, because the above parse just took care of most of
7894        what is needed to do vmspath when the specification is already
7895        in VMS format.
7896
7897        And if it is not already, it is easier to do the conversion as
7898        part of this routine than to call this routine and then work on
7899        the result.
7900      */
7901
7902     /* If VMS punctuation was found, it is already VMS format */
7903     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7904       if (utf8_flag != NULL)
7905         *utf8_flag = 0;
7906       strcpy(rslt, path);
7907       return rslt;
7908     }
7909     /* Now, what to do with trailing "." cases where there is no
7910        extension?  If this is a UNIX specification, and EFS characters
7911        are enabled, then the trailing "." should be converted to a "^.".
7912        But if this was already a VMS specification, then it should be
7913        left alone.
7914
7915        So in the case of ambiguity, leave the specification alone.
7916      */
7917
7918
7919     /* If there is a possibility of UTF8, then if any UTF8 characters
7920         are present, then they must be converted to VTF-7
7921      */
7922     if (utf8_flag != NULL)
7923       *utf8_flag = 0;
7924     strcpy(rslt, path);
7925     return rslt;
7926   }
7927
7928   dirend = strrchr(path,'/');
7929
7930   if (dirend == NULL) {
7931      /* If we get here with no UNIX directory delimiters, then this is
7932         not a complete file specification, either garbage a UNIX glob
7933         specification that can not be converted to a VMS wildcard, or
7934         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7935         so apparently other programs expect this also.
7936
7937         utf8 flag setting needs to be preserved.
7938       */
7939       strcpy(rslt, path);
7940       return rslt;
7941   }
7942
7943 /* If POSIX mode active, handle the conversion */
7944 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7945   if (decc_efs_charset) {
7946     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7947     return rslt;
7948   }
7949 #endif
7950
7951   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7952     if (!*(dirend+2)) dirend +=2;
7953     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7954     if (decc_efs_charset == 0) {
7955       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7956     }
7957   }
7958
7959   cp1 = rslt;
7960   cp2 = path;
7961   lastdot = strrchr(cp2,'.');
7962   if (*cp2 == '/') {
7963     char *trndev;
7964     int islnm, rooted;
7965     STRLEN trnend;
7966
7967     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7968     if (!*(cp2+1)) {
7969       if (decc_disable_posix_root) {
7970         strcpy(rslt,"sys$disk:[000000]");
7971       }
7972       else {
7973         strcpy(rslt,"sys$posix_root:[000000]");
7974       }
7975       if (utf8_flag != NULL)
7976         *utf8_flag = 0;
7977       return rslt;
7978     }
7979     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7980     *cp1 = '\0';
7981     trndev = PerlMem_malloc(VMS_MAXRSS);
7982     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7983     islnm =  my_trnlnm(rslt,trndev,0);
7984
7985      /* DECC special handling */
7986     if (!islnm) {
7987       if (strcmp(rslt,"bin") == 0) {
7988         strcpy(rslt,"sys$system");
7989         cp1 = rslt + 10;
7990         *cp1 = 0;
7991         islnm =  my_trnlnm(rslt,trndev,0);
7992       }
7993       else if (strcmp(rslt,"tmp") == 0) {
7994         strcpy(rslt,"sys$scratch");
7995         cp1 = rslt + 11;
7996         *cp1 = 0;
7997         islnm =  my_trnlnm(rslt,trndev,0);
7998       }
7999       else if (!decc_disable_posix_root) {
8000         strcpy(rslt, "sys$posix_root");
8001         cp1 = rslt + 13;
8002         *cp1 = 0;
8003         cp2 = path;
8004         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
8005         islnm =  my_trnlnm(rslt,trndev,0);
8006       }
8007       else if (strcmp(rslt,"dev") == 0) {
8008         if (strncmp(cp2,"/null", 5) == 0) {
8009           if ((cp2[5] == 0) || (cp2[5] == '/')) {
8010             strcpy(rslt,"NLA0");
8011             cp1 = rslt + 4;
8012             *cp1 = 0;
8013             cp2 = cp2 + 5;
8014             islnm =  my_trnlnm(rslt,trndev,0);
8015           }
8016         }
8017       }
8018     }
8019
8020     trnend = islnm ? strlen(trndev) - 1 : 0;
8021     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8022     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8023     /* If the first element of the path is a logical name, determine
8024      * whether it has to be translated so we can add more directories. */
8025     if (!islnm || rooted) {
8026       *(cp1++) = ':';
8027       *(cp1++) = '[';
8028       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8029       else cp2++;
8030     }
8031     else {
8032       if (cp2 != dirend) {
8033         strcpy(rslt,trndev);
8034         cp1 = rslt + trnend;
8035         if (*cp2 != 0) {
8036           *(cp1++) = '.';
8037           cp2++;
8038         }
8039       }
8040       else {
8041         if (decc_disable_posix_root) {
8042           *(cp1++) = ':';
8043           hasdir = 0;
8044         }
8045       }
8046     }
8047     PerlMem_free(trndev);
8048   }
8049   else {
8050     *(cp1++) = '[';
8051     if (*cp2 == '.') {
8052       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8053         cp2 += 2;         /* skip over "./" - it's redundant */
8054         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
8055       }
8056       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8057         *(cp1++) = '-';                                 /* "../" --> "-" */
8058         cp2 += 3;
8059       }
8060       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8061                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8062         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8063         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8064         cp2 += 4;
8065       }
8066       else if ((cp2 != lastdot) || (lastdot < dirend)) {
8067         /* Escape the extra dots in EFS file specifications */
8068         *(cp1++) = '^';
8069       }
8070       if (cp2 > dirend) cp2 = dirend;
8071     }
8072     else *(cp1++) = '.';
8073   }
8074   for (; cp2 < dirend; cp2++) {
8075     if (*cp2 == '/') {
8076       if (*(cp2-1) == '/') continue;
8077       if (*(cp1-1) != '.') *(cp1++) = '.';
8078       infront = 0;
8079     }
8080     else if (!infront && *cp2 == '.') {
8081       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8082       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
8083       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8084         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8085         else if (*(cp1-2) == '[') *(cp1-1) = '-';
8086         else {  /* back up over previous directory name */
8087           cp1--;
8088           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8089           if (*(cp1-1) == '[') {
8090             memcpy(cp1,"000000.",7);
8091             cp1 += 7;
8092           }
8093         }
8094         cp2 += 2;
8095         if (cp2 == dirend) break;
8096       }
8097       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8098                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8099         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8100         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8101         if (!*(cp2+3)) {
8102           *(cp1++) = '.';  /* Simulate trailing '/' */
8103           cp2 += 2;  /* for loop will incr this to == dirend */
8104         }
8105         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
8106       }
8107       else {
8108         if (decc_efs_charset == 0)
8109           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
8110         else {
8111           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
8112           *(cp1++) = '.';
8113         }
8114       }
8115     }
8116     else {
8117       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
8118       if (*cp2 == '.') {
8119         if (decc_efs_charset == 0)
8120           *(cp1++) = '_';
8121         else {
8122           *(cp1++) = '^';
8123           *(cp1++) = '.';
8124         }
8125       }
8126       else                  *(cp1++) =  *cp2;
8127       infront = 1;
8128     }
8129   }
8130   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8131   if (hasdir) *(cp1++) = ']';
8132   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
8133   /* fixme for ODS5 */
8134   no_type_seen = 0;
8135   if (cp2 > lastdot)
8136     no_type_seen = 1;
8137   while (*cp2) {
8138     switch(*cp2) {
8139     case '?':
8140         if (decc_efs_charset == 0)
8141           *(cp1++) = '%';
8142         else
8143           *(cp1++) = '?';
8144         cp2++;
8145     case ' ':
8146         *(cp1)++ = '^';
8147         *(cp1)++ = '_';
8148         cp2++;
8149         break;
8150     case '.':
8151         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8152             decc_readdir_dropdotnotype) {
8153           *(cp1)++ = '^';
8154           *(cp1)++ = '.';
8155           cp2++;
8156
8157           /* trailing dot ==> '^..' on VMS */
8158           if (*cp2 == '\0') {
8159             *(cp1++) = '.';
8160             no_type_seen = 0;
8161           }
8162         }
8163         else {
8164           *(cp1++) = *(cp2++);
8165           no_type_seen = 0;
8166         }
8167         break;
8168     case '$':
8169          /* This could be a macro to be passed through */
8170         *(cp1++) = *(cp2++);
8171         if (*cp2 == '(') {
8172         const char * save_cp2;
8173         char * save_cp1;
8174         int is_macro;
8175
8176             /* paranoid check */
8177             save_cp2 = cp2;
8178             save_cp1 = cp1;
8179             is_macro = 0;
8180
8181             /* Test through */
8182             *(cp1++) = *(cp2++);
8183             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8184                 *(cp1++) = *(cp2++);
8185                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8186                     *(cp1++) = *(cp2++);
8187                 }
8188                 if (*cp2 == ')') {
8189                     *(cp1++) = *(cp2++);
8190                     is_macro = 1;
8191                 }
8192             }
8193             if (is_macro == 0) {
8194                 /* Not really a macro - never mind */
8195                 cp2 = save_cp2;
8196                 cp1 = save_cp1;
8197             }
8198         }
8199         break;
8200     case '\"':
8201     case '~':
8202     case '`':
8203     case '!':
8204     case '#':
8205     case '%':
8206     case '^':
8207         /* Don't escape again if following character is
8208          * already something we escape.
8209          */
8210         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8211             *(cp1++) = *(cp2++);
8212             break;
8213         }
8214         /* But otherwise fall through and escape it. */
8215     case '&':
8216     case '(':
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         *(cp1++) = '^';
8232         *(cp1++) = *(cp2++);
8233         break;
8234     case ';':
8235         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8236          * which is wrong.  UNIX notation should be ".dir." unless
8237          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8238          * changing this behavior could break more things at this time.
8239          * efs character set effectively does not allow "." to be a version
8240          * delimiter as a further complication about changing this.
8241          */
8242         if (decc_filename_unix_report != 0) {
8243           *(cp1++) = '^';
8244         }
8245         *(cp1++) = *(cp2++);
8246         break;
8247     default:
8248         *(cp1++) = *(cp2++);
8249     }
8250   }
8251   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8252   char *lcp1;
8253     lcp1 = cp1;
8254     lcp1--;
8255      /* Fix me for "^]", but that requires making sure that you do
8256       * not back up past the start of the filename
8257       */
8258     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8259       *cp1++ = '.';
8260   }
8261   *cp1 = '\0';
8262
8263   if (utf8_flag != NULL)
8264     *utf8_flag = 0;
8265   return rslt;
8266
8267 }  /* end of do_tovmsspec() */
8268 /*}}}*/
8269 /* External entry points */
8270 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8271   { return do_tovmsspec(path,buf,0,NULL); }
8272 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8273   { return do_tovmsspec(path,buf,1,NULL); }
8274 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8275   { return do_tovmsspec(path,buf,0,utf8_fl); }
8276 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8277   { return do_tovmsspec(path,buf,1,utf8_fl); }
8278
8279 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8280 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8281   static char __tovmspath_retbuf[VMS_MAXRSS];
8282   int vmslen;
8283   char *pathified, *vmsified, *cp;
8284
8285   if (path == NULL) return NULL;
8286   pathified = PerlMem_malloc(VMS_MAXRSS);
8287   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8288   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8289     PerlMem_free(pathified);
8290     return NULL;
8291   }
8292
8293   vmsified = NULL;
8294   if (buf == NULL)
8295      Newx(vmsified, VMS_MAXRSS, char);
8296   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8297     PerlMem_free(pathified);
8298     if (vmsified) Safefree(vmsified);
8299     return NULL;
8300   }
8301   PerlMem_free(pathified);
8302   if (buf) {
8303     return buf;
8304   }
8305   else if (ts) {
8306     vmslen = strlen(vmsified);
8307     Newx(cp,vmslen+1,char);
8308     memcpy(cp,vmsified,vmslen);
8309     cp[vmslen] = '\0';
8310     Safefree(vmsified);
8311     return cp;
8312   }
8313   else {
8314     strcpy(__tovmspath_retbuf,vmsified);
8315     Safefree(vmsified);
8316     return __tovmspath_retbuf;
8317   }
8318
8319 }  /* end of do_tovmspath() */
8320 /*}}}*/
8321 /* External entry points */
8322 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8323   { return do_tovmspath(path,buf,0, NULL); }
8324 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8325   { return do_tovmspath(path,buf,1, NULL); }
8326 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8327   { return do_tovmspath(path,buf,0,utf8_fl); }
8328 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8329   { return do_tovmspath(path,buf,1,utf8_fl); }
8330
8331
8332 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8333 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8334   static char __tounixpath_retbuf[VMS_MAXRSS];
8335   int unixlen;
8336   char *pathified, *unixified, *cp;
8337
8338   if (path == NULL) return NULL;
8339   pathified = PerlMem_malloc(VMS_MAXRSS);
8340   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8341   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8342     PerlMem_free(pathified);
8343     return NULL;
8344   }
8345
8346   unixified = NULL;
8347   if (buf == NULL) {
8348       Newx(unixified, VMS_MAXRSS, char);
8349   }
8350   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8351     PerlMem_free(pathified);
8352     if (unixified) Safefree(unixified);
8353     return NULL;
8354   }
8355   PerlMem_free(pathified);
8356   if (buf) {
8357     return buf;
8358   }
8359   else if (ts) {
8360     unixlen = strlen(unixified);
8361     Newx(cp,unixlen+1,char);
8362     memcpy(cp,unixified,unixlen);
8363     cp[unixlen] = '\0';
8364     Safefree(unixified);
8365     return cp;
8366   }
8367   else {
8368     strcpy(__tounixpath_retbuf,unixified);
8369     Safefree(unixified);
8370     return __tounixpath_retbuf;
8371   }
8372
8373 }  /* end of do_tounixpath() */
8374 /*}}}*/
8375 /* External entry points */
8376 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8377   { return do_tounixpath(path,buf,0,NULL); }
8378 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8379   { return do_tounixpath(path,buf,1,NULL); }
8380 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8381   { return do_tounixpath(path,buf,0,utf8_fl); }
8382 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8383   { return do_tounixpath(path,buf,1,utf8_fl); }
8384
8385 /*
8386  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
8387  *
8388  *****************************************************************************
8389  *                                                                           *
8390  *  Copyright (C) 1989-1994, 2007 by                                         *
8391  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
8392  *                                                                           *
8393  *  Permission is hereby granted for the reproduction of this software       *
8394  *  on condition that this copyright notice is included in source            *
8395  *  distributions of the software.  The code may be modified and             *
8396  *  distributed under the same terms as Perl itself.                         *
8397  *                                                                           *
8398  *  27-Aug-1994 Modified for inclusion in perl5                              *
8399  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
8400  *****************************************************************************
8401  */
8402
8403 /*
8404  * getredirection() is intended to aid in porting C programs
8405  * to VMS (Vax-11 C).  The native VMS environment does not support
8406  * '>' and '<' I/O redirection, or command line wild card expansion,
8407  * or a command line pipe mechanism using the '|' AND background
8408  * command execution '&'.  All of these capabilities are provided to any
8409  * C program which calls this procedure as the first thing in the
8410  * main program.
8411  * The piping mechanism will probably work with almost any 'filter' type
8412  * of program.  With suitable modification, it may useful for other
8413  * portability problems as well.
8414  *
8415  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
8416  */
8417 struct list_item
8418     {
8419     struct list_item *next;
8420     char *value;
8421     };
8422
8423 static void add_item(struct list_item **head,
8424                      struct list_item **tail,
8425                      char *value,
8426                      int *count);
8427
8428 static void mp_expand_wild_cards(pTHX_ char *item,
8429                                 struct list_item **head,
8430                                 struct list_item **tail,
8431                                 int *count);
8432
8433 static int background_process(pTHX_ int argc, char **argv);
8434
8435 static void pipe_and_fork(pTHX_ char **cmargv);
8436
8437 /*{{{ void getredirection(int *ac, char ***av)*/
8438 static void
8439 mp_getredirection(pTHX_ int *ac, char ***av)
8440 /*
8441  * Process vms redirection arg's.  Exit if any error is seen.
8442  * If getredirection() processes an argument, it is erased
8443  * from the vector.  getredirection() returns a new argc and argv value.
8444  * In the event that a background command is requested (by a trailing "&"),
8445  * this routine creates a background subprocess, and simply exits the program.
8446  *
8447  * Warning: do not try to simplify the code for vms.  The code
8448  * presupposes that getredirection() is called before any data is
8449  * read from stdin or written to stdout.
8450  *
8451  * Normal usage is as follows:
8452  *
8453  *      main(argc, argv)
8454  *      int             argc;
8455  *      char            *argv[];
8456  *      {
8457  *              getredirection(&argc, &argv);
8458  *      }
8459  */
8460 {
8461     int                 argc = *ac;     /* Argument Count         */
8462     char                **argv = *av;   /* Argument Vector        */
8463     char                *ap;            /* Argument pointer       */
8464     int                 j;              /* argv[] index           */
8465     int                 item_count = 0; /* Count of Items in List */
8466     struct list_item    *list_head = 0; /* First Item in List       */
8467     struct list_item    *list_tail;     /* Last Item in List        */
8468     char                *in = NULL;     /* Input File Name          */
8469     char                *out = NULL;    /* Output File Name         */
8470     char                *outmode = "w"; /* Mode to Open Output File */
8471     char                *err = NULL;    /* Error File Name          */
8472     char                *errmode = "w"; /* Mode to Open Error File  */
8473     int                 cmargc = 0;     /* Piped Command Arg Count  */
8474     char                **cmargv = NULL;/* Piped Command Arg Vector */
8475
8476     /*
8477      * First handle the case where the last thing on the line ends with
8478      * a '&'.  This indicates the desire for the command to be run in a
8479      * subprocess, so we satisfy that desire.
8480      */
8481     ap = argv[argc-1];
8482     if (0 == strcmp("&", ap))
8483        exit(background_process(aTHX_ --argc, argv));
8484     if (*ap && '&' == ap[strlen(ap)-1])
8485         {
8486         ap[strlen(ap)-1] = '\0';
8487        exit(background_process(aTHX_ argc, argv));
8488         }
8489     /*
8490      * Now we handle the general redirection cases that involve '>', '>>',
8491      * '<', and pipes '|'.
8492      */
8493     for (j = 0; j < argc; ++j)
8494         {
8495         if (0 == strcmp("<", argv[j]))
8496             {
8497             if (j+1 >= argc)
8498                 {
8499                 fprintf(stderr,"No input file after < on command line");
8500                 exit(LIB$_WRONUMARG);
8501                 }
8502             in = argv[++j];
8503             continue;
8504             }
8505         if ('<' == *(ap = argv[j]))
8506             {
8507             in = 1 + ap;
8508             continue;
8509             }
8510         if (0 == strcmp(">", ap))
8511             {
8512             if (j+1 >= argc)
8513                 {
8514                 fprintf(stderr,"No output file after > on command line");
8515                 exit(LIB$_WRONUMARG);
8516                 }
8517             out = argv[++j];
8518             continue;
8519             }
8520         if ('>' == *ap)
8521             {
8522             if ('>' == ap[1])
8523                 {
8524                 outmode = "a";
8525                 if ('\0' == ap[2])
8526                     out = argv[++j];
8527                 else
8528                     out = 2 + ap;
8529                 }
8530             else
8531                 out = 1 + ap;
8532             if (j >= argc)
8533                 {
8534                 fprintf(stderr,"No output file after > or >> on command line");
8535                 exit(LIB$_WRONUMARG);
8536                 }
8537             continue;
8538             }
8539         if (('2' == *ap) && ('>' == ap[1]))
8540             {
8541             if ('>' == ap[2])
8542                 {
8543                 errmode = "a";
8544                 if ('\0' == ap[3])
8545                     err = argv[++j];
8546                 else
8547                     err = 3 + ap;
8548                 }
8549             else
8550                 if ('\0' == ap[2])
8551                     err = argv[++j];
8552                 else
8553                     err = 2 + ap;
8554             if (j >= argc)
8555                 {
8556                 fprintf(stderr,"No output file after 2> or 2>> on command line");
8557                 exit(LIB$_WRONUMARG);
8558                 }
8559             continue;
8560             }
8561         if (0 == strcmp("|", argv[j]))
8562             {
8563             if (j+1 >= argc)
8564                 {
8565                 fprintf(stderr,"No command into which to pipe on command line");
8566                 exit(LIB$_WRONUMARG);
8567                 }
8568             cmargc = argc-(j+1);
8569             cmargv = &argv[j+1];
8570             argc = j;
8571             continue;
8572             }
8573         if ('|' == *(ap = argv[j]))
8574             {
8575             ++argv[j];
8576             cmargc = argc-j;
8577             cmargv = &argv[j];
8578             argc = j;
8579             continue;
8580             }
8581         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
8582         }
8583     /*
8584      * Allocate and fill in the new argument vector, Some Unix's terminate
8585      * the list with an extra null pointer.
8586      */
8587     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
8588     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8589     *av = argv;
8590     for (j = 0; j < item_count; ++j, list_head = list_head->next)
8591         argv[j] = list_head->value;
8592     *ac = item_count;
8593     if (cmargv != NULL)
8594         {
8595         if (out != NULL)
8596             {
8597             fprintf(stderr,"'|' and '>' may not both be specified on command line");
8598             exit(LIB$_INVARGORD);
8599             }
8600         pipe_and_fork(aTHX_ cmargv);
8601         }
8602
8603     /* Check for input from a pipe (mailbox) */
8604
8605     if (in == NULL && 1 == isapipe(0))
8606         {
8607         char mbxname[L_tmpnam];
8608         long int bufsize;
8609         long int dvi_item = DVI$_DEVBUFSIZ;
8610         $DESCRIPTOR(mbxnam, "");
8611         $DESCRIPTOR(mbxdevnam, "");
8612
8613         /* Input from a pipe, reopen it in binary mode to disable       */
8614         /* carriage control processing.                                 */
8615
8616         fgetname(stdin, mbxname);
8617         mbxnam.dsc$a_pointer = mbxname;
8618         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
8619         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
8620         mbxdevnam.dsc$a_pointer = mbxname;
8621         mbxdevnam.dsc$w_length = sizeof(mbxname);
8622         dvi_item = DVI$_DEVNAM;
8623         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
8624         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
8625         set_errno(0);
8626         set_vaxc_errno(1);
8627         freopen(mbxname, "rb", stdin);
8628         if (errno != 0)
8629             {
8630             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
8631             exit(vaxc$errno);
8632             }
8633         }
8634     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8635         {
8636         fprintf(stderr,"Can't open input file %s as stdin",in);
8637         exit(vaxc$errno);
8638         }
8639     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8640         {
8641         fprintf(stderr,"Can't open output file %s as stdout",out);
8642         exit(vaxc$errno);
8643         }
8644         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8645
8646     if (err != NULL) {
8647         if (strcmp(err,"&1") == 0) {
8648             dup2(fileno(stdout), fileno(stderr));
8649             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8650         } else {
8651         FILE *tmperr;
8652         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8653             {
8654             fprintf(stderr,"Can't open error file %s as stderr",err);
8655             exit(vaxc$errno);
8656             }
8657             fclose(tmperr);
8658            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8659                 {
8660                 exit(vaxc$errno);
8661                 }
8662             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8663         }
8664         }
8665 #ifdef ARGPROC_DEBUG
8666     PerlIO_printf(Perl_debug_log, "Arglist:\n");
8667     for (j = 0; j < *ac;  ++j)
8668         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8669 #endif
8670    /* Clear errors we may have hit expanding wildcards, so they don't
8671       show up in Perl's $! later */
8672    set_errno(0); set_vaxc_errno(1);
8673 }  /* end of getredirection() */
8674 /*}}}*/
8675
8676 static void add_item(struct list_item **head,
8677                      struct list_item **tail,
8678                      char *value,
8679                      int *count)
8680 {
8681     if (*head == 0)
8682         {
8683         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8684         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8685         *tail = *head;
8686         }
8687     else {
8688         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8689         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8690         *tail = (*tail)->next;
8691         }
8692     (*tail)->value = value;
8693     ++(*count);
8694 }
8695
8696 static void mp_expand_wild_cards(pTHX_ char *item,
8697                               struct list_item **head,
8698                               struct list_item **tail,
8699                               int *count)
8700 {
8701 int expcount = 0;
8702 unsigned long int context = 0;
8703 int isunix = 0;
8704 int item_len = 0;
8705 char *had_version;
8706 char *had_device;
8707 int had_directory;
8708 char *devdir,*cp;
8709 char *vmsspec;
8710 $DESCRIPTOR(filespec, "");
8711 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8712 $DESCRIPTOR(resultspec, "");
8713 unsigned long int lff_flags = 0;
8714 int sts;
8715 int rms_sts;
8716
8717 #ifdef VMS_LONGNAME_SUPPORT
8718     lff_flags = LIB$M_FIL_LONG_NAMES;
8719 #endif
8720
8721     for (cp = item; *cp; cp++) {
8722         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8723         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8724     }
8725     if (!*cp || isspace(*cp))
8726         {
8727         add_item(head, tail, item, count);
8728         return;
8729         }
8730     else
8731         {
8732      /* "double quoted" wild card expressions pass as is */
8733      /* From DCL that means using e.g.:                  */
8734      /* perl program """perl.*"""                        */
8735      item_len = strlen(item);
8736      if ( '"' == *item && '"' == item[item_len-1] )
8737        {
8738        item++;
8739        item[item_len-2] = '\0';
8740        add_item(head, tail, item, count);
8741        return;
8742        }
8743      }
8744     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8745     resultspec.dsc$b_class = DSC$K_CLASS_D;
8746     resultspec.dsc$a_pointer = NULL;
8747     vmsspec = PerlMem_malloc(VMS_MAXRSS);
8748     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8749     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8750       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8751     if (!isunix || !filespec.dsc$a_pointer)
8752       filespec.dsc$a_pointer = item;
8753     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8754     /*
8755      * Only return version specs, if the caller specified a version
8756      */
8757     had_version = strchr(item, ';');
8758     /*
8759      * Only return device and directory specs, if the caller specifed either.
8760      */
8761     had_device = strchr(item, ':');
8762     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8763
8764     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8765                                  (&filespec, &resultspec, &context,
8766                                   &defaultspec, 0, &rms_sts, &lff_flags)))
8767         {
8768         char *string;
8769         char *c;
8770
8771         string = PerlMem_malloc(resultspec.dsc$w_length+1);
8772         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8773         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8774         string[resultspec.dsc$w_length] = '\0';
8775         if (NULL == had_version)
8776             *(strrchr(string, ';')) = '\0';
8777         if ((!had_directory) && (had_device == NULL))
8778             {
8779             if (NULL == (devdir = strrchr(string, ']')))
8780                 devdir = strrchr(string, '>');
8781             strcpy(string, devdir + 1);
8782             }
8783         /*
8784          * Be consistent with what the C RTL has already done to the rest of
8785          * the argv items and lowercase all of these names.
8786          */
8787         if (!decc_efs_case_preserve) {
8788             for (c = string; *c; ++c)
8789             if (isupper(*c))
8790                 *c = tolower(*c);
8791         }
8792         if (isunix) trim_unixpath(string,item,1);
8793         add_item(head, tail, string, count);
8794         ++expcount;
8795     }
8796     PerlMem_free(vmsspec);
8797     if (sts != RMS$_NMF)
8798         {
8799         set_vaxc_errno(sts);
8800         switch (sts)
8801             {
8802             case RMS$_FNF: case RMS$_DNF:
8803                 set_errno(ENOENT); break;
8804             case RMS$_DIR:
8805                 set_errno(ENOTDIR); break;
8806             case RMS$_DEV:
8807                 set_errno(ENODEV); break;
8808             case RMS$_FNM: case RMS$_SYN:
8809                 set_errno(EINVAL); break;
8810             case RMS$_PRV:
8811                 set_errno(EACCES); break;
8812             default:
8813                 _ckvmssts_noperl(sts);
8814             }
8815         }
8816     if (expcount == 0)
8817         add_item(head, tail, item, count);
8818     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8819     _ckvmssts_noperl(lib$find_file_end(&context));
8820 }
8821
8822 static int child_st[2];/* Event Flag set when child process completes   */
8823
8824 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
8825
8826 static unsigned long int exit_handler(int *status)
8827 {
8828 short iosb[4];
8829
8830     if (0 == child_st[0])
8831         {
8832 #ifdef ARGPROC_DEBUG
8833         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8834 #endif
8835         fflush(stdout);     /* Have to flush pipe for binary data to    */
8836                             /* terminate properly -- <tp@mccall.com>    */
8837         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8838         sys$dassgn(child_chan);
8839         fclose(stdout);
8840         sys$synch(0, child_st);
8841         }
8842     return(1);
8843 }
8844
8845 static void sig_child(int chan)
8846 {
8847 #ifdef ARGPROC_DEBUG
8848     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8849 #endif
8850     if (child_st[0] == 0)
8851         child_st[0] = 1;
8852 }
8853
8854 static struct exit_control_block exit_block =
8855     {
8856     0,
8857     exit_handler,
8858     1,
8859     &exit_block.exit_status,
8860     0
8861     };
8862
8863 static void
8864 pipe_and_fork(pTHX_ char **cmargv)
8865 {
8866     PerlIO *fp;
8867     struct dsc$descriptor_s *vmscmd;
8868     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8869     int sts, j, l, ismcr, quote, tquote = 0;
8870
8871     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8872     vms_execfree(vmscmd);
8873
8874     j = l = 0;
8875     p = subcmd;
8876     q = cmargv[0];
8877     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
8878               && toupper(*(q+2)) == 'R' && !*(q+3);
8879
8880     while (q && l < MAX_DCL_LINE_LENGTH) {
8881         if (!*q) {
8882             if (j > 0 && quote) {
8883                 *p++ = '"';
8884                 l++;
8885             }
8886             q = cmargv[++j];
8887             if (q) {
8888                 if (ismcr && j > 1) quote = 1;
8889                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
8890                 *p++ = ' ';
8891                 l++;
8892                 if (quote || tquote) {
8893                     *p++ = '"';
8894                     l++;
8895                 }
8896             }
8897         } else {
8898             if ((quote||tquote) && *q == '"') {
8899                 *p++ = '"';
8900                 l++;
8901             }
8902             *p++ = *q++;
8903             l++;
8904         }
8905     }
8906     *p = '\0';
8907
8908     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8909     if (fp == NULL) {
8910         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8911     }
8912 }
8913
8914 static int background_process(pTHX_ int argc, char **argv)
8915 {
8916 char command[MAX_DCL_SYMBOL + 1] = "$";
8917 $DESCRIPTOR(value, "");
8918 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8919 static $DESCRIPTOR(null, "NLA0:");
8920 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8921 char pidstring[80];
8922 $DESCRIPTOR(pidstr, "");
8923 int pid;
8924 unsigned long int flags = 17, one = 1, retsts;
8925 int len;
8926
8927     strcat(command, argv[0]);
8928     len = strlen(command);
8929     while (--argc && (len < MAX_DCL_SYMBOL))
8930         {
8931         strcat(command, " \"");
8932         strcat(command, *(++argv));
8933         strcat(command, "\"");
8934         len = strlen(command);
8935         }
8936     value.dsc$a_pointer = command;
8937     value.dsc$w_length = strlen(value.dsc$a_pointer);
8938     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8939     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8940     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8941         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8942     }
8943     else {
8944         _ckvmssts_noperl(retsts);
8945     }
8946 #ifdef ARGPROC_DEBUG
8947     PerlIO_printf(Perl_debug_log, "%s\n", command);
8948 #endif
8949     sprintf(pidstring, "%08X", pid);
8950     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8951     pidstr.dsc$a_pointer = pidstring;
8952     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8953     lib$set_symbol(&pidsymbol, &pidstr);
8954     return(SS$_NORMAL);
8955 }
8956 /*}}}*/
8957 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8958
8959
8960 /* OS-specific initialization at image activation (not thread startup) */
8961 /* Older VAXC header files lack these constants */
8962 #ifndef JPI$_RIGHTS_SIZE
8963 #  define JPI$_RIGHTS_SIZE 817
8964 #endif
8965 #ifndef KGB$M_SUBSYSTEM
8966 #  define KGB$M_SUBSYSTEM 0x8
8967 #endif
8968
8969 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8970
8971 /*{{{void vms_image_init(int *, char ***)*/
8972 void
8973 vms_image_init(int *argcp, char ***argvp)
8974 {
8975   char eqv[LNM$C_NAMLENGTH+1] = "";
8976   unsigned int len, tabct = 8, tabidx = 0;
8977   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8978   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8979   unsigned short int dummy, rlen;
8980   struct dsc$descriptor_s **tabvec;
8981 #if defined(PERL_IMPLICIT_CONTEXT)
8982   pTHX = NULL;
8983 #endif
8984   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8985                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8986                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8987                                  {          0,                0,    0,      0} };
8988
8989 #ifdef KILL_BY_SIGPRC
8990     Perl_csighandler_init();
8991 #endif
8992
8993   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8994   _ckvmssts_noperl(iosb[0]);
8995   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8996     if (iprv[i]) {           /* Running image installed with privs? */
8997       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8998       will_taint = TRUE;
8999       break;
9000     }
9001   }
9002   /* Rights identifiers might trigger tainting as well. */
9003   if (!will_taint && (rlen || rsz)) {
9004     while (rlen < rsz) {
9005       /* We didn't get all the identifiers on the first pass.  Allocate a
9006        * buffer much larger than $GETJPI wants (rsz is size in bytes that
9007        * were needed to hold all identifiers at time of last call; we'll
9008        * allocate that many unsigned long ints), and go back and get 'em.
9009        * If it gave us less than it wanted to despite ample buffer space,
9010        * something's broken.  Is your system missing a system identifier?
9011        */
9012       if (rsz <= jpilist[1].buflen) {
9013          /* Perl_croak accvios when used this early in startup. */
9014          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9015                          rsz, (unsigned long) jpilist[1].buflen,
9016                          "Check your rights database for corruption.\n");
9017          exit(SS$_ABORT);
9018       }
9019       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9020       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9021       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9022       jpilist[1].buflen = rsz * sizeof(unsigned long int);
9023       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9024       _ckvmssts_noperl(iosb[0]);
9025     }
9026     mask = jpilist[1].bufadr;
9027     /* Check attribute flags for each identifier (2nd longword); protected
9028      * subsystem identifiers trigger tainting.
9029      */
9030     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9031       if (mask[i] & KGB$M_SUBSYSTEM) {
9032         will_taint = TRUE;
9033         break;
9034       }
9035     }
9036     if (mask != rlst) PerlMem_free(mask);
9037   }
9038
9039   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9040    * logical, some versions of the CRTL will add a phanthom /000000/
9041    * directory.  This needs to be removed.
9042    */
9043   if (decc_filename_unix_report) {
9044   char * zeros;
9045   int ulen;
9046     ulen = strlen(argvp[0][0]);
9047     if (ulen > 7) {
9048       zeros = strstr(argvp[0][0], "/000000/");
9049       if (zeros != NULL) {
9050         int mlen;
9051         mlen = ulen - (zeros - argvp[0][0]) - 7;
9052         memmove(zeros, &zeros[7], mlen);
9053         ulen = ulen - 7;
9054         argvp[0][0][ulen] = '\0';
9055       }
9056     }
9057     /* It also may have a trailing dot that needs to be removed otherwise
9058      * it will be converted to VMS mode incorrectly.
9059      */
9060     ulen--;
9061     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9062       argvp[0][0][ulen] = '\0';
9063   }
9064
9065   /* We need to use this hack to tell Perl it should run with tainting,
9066    * since its tainting flag may be part of the PL_curinterp struct, which
9067    * hasn't been allocated when vms_image_init() is called.
9068    */
9069   if (will_taint) {
9070     char **newargv, **oldargv;
9071     oldargv = *argvp;
9072     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9073     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9074     newargv[0] = oldargv[0];
9075     newargv[1] = PerlMem_malloc(3 * sizeof(char));
9076     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9077     strcpy(newargv[1], "-T");
9078     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9079     (*argcp)++;
9080     newargv[*argcp] = NULL;
9081     /* We orphan the old argv, since we don't know where it's come from,
9082      * so we don't know how to free it.
9083      */
9084     *argvp = newargv;
9085   }
9086   else {  /* Did user explicitly request tainting? */
9087     int i;
9088     char *cp, **av = *argvp;
9089     for (i = 1; i < *argcp; i++) {
9090       if (*av[i] != '-') break;
9091       for (cp = av[i]+1; *cp; cp++) {
9092         if (*cp == 'T') { will_taint = 1; break; }
9093         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9094                   strchr("DFIiMmx",*cp)) break;
9095       }
9096       if (will_taint) break;
9097     }
9098   }
9099
9100   for (tabidx = 0;
9101        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9102        tabidx++) {
9103     if (!tabidx) {
9104       tabvec = (struct dsc$descriptor_s **)
9105             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9106       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9107     }
9108     else if (tabidx >= tabct) {
9109       tabct += 8;
9110       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9111       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9112     }
9113     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9114     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9115     tabvec[tabidx]->dsc$w_length  = 0;
9116     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
9117     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
9118     tabvec[tabidx]->dsc$a_pointer = NULL;
9119     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9120   }
9121   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9122
9123   getredirection(argcp,argvp);
9124 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9125   {
9126 # include <reentrancy.h>
9127   decc$set_reentrancy(C$C_MULTITHREAD);
9128   }
9129 #endif
9130   return;
9131 }
9132 /*}}}*/
9133
9134
9135 /* trim_unixpath()
9136  * Trim Unix-style prefix off filespec, so it looks like what a shell
9137  * glob expansion would return (i.e. from specified prefix on, not
9138  * full path).  Note that returned filespec is Unix-style, regardless
9139  * of whether input filespec was VMS-style or Unix-style.
9140  *
9141  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9142  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
9143  * vector of options; at present, only bit 0 is used, and if set tells
9144  * trim unixpath to try the current default directory as a prefix when
9145  * presented with a possibly ambiguous ... wildcard.
9146  *
9147  * Returns !=0 on success, with trimmed filespec replacing contents of
9148  * fspec, and 0 on failure, with contents of fpsec unchanged.
9149  */
9150 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9151 int
9152 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9153 {
9154   char *unixified, *unixwild,
9155        *template, *base, *end, *cp1, *cp2;
9156   register int tmplen, reslen = 0, dirs = 0;
9157
9158   unixwild = PerlMem_malloc(VMS_MAXRSS);
9159   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
9160   if (!wildspec || !fspec) return 0;
9161   template = unixwild;
9162   if (strpbrk(wildspec,"]>:") != NULL) {
9163     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
9164         PerlMem_free(unixwild);
9165         return 0;
9166     }
9167   }
9168   else {
9169     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9170     unixwild[VMS_MAXRSS-1] = 0;
9171   }
9172   unixified = PerlMem_malloc(VMS_MAXRSS);
9173   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
9174   if (strpbrk(fspec,"]>:") != NULL) {
9175     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
9176         PerlMem_free(unixwild);
9177         PerlMem_free(unixified);
9178         return 0;
9179     }
9180     else base = unixified;
9181     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9182      * check to see that final result fits into (isn't longer than) fspec */
9183     reslen = strlen(fspec);
9184   }
9185   else base = fspec;
9186
9187   /* No prefix or absolute path on wildcard, so nothing to remove */
9188   if (!*template || *template == '/') {
9189     PerlMem_free(unixwild);
9190     if (base == fspec) {
9191         PerlMem_free(unixified);
9192         return 1;
9193     }
9194     tmplen = strlen(unixified);
9195     if (tmplen > reslen) {
9196         PerlMem_free(unixified);
9197         return 0;  /* not enough space */
9198     }
9199     /* Copy unixified resultant, including trailing NUL */
9200     memmove(fspec,unixified,tmplen+1);
9201     PerlMem_free(unixified);
9202     return 1;
9203   }
9204
9205   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
9206   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9207     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9208     for (cp1 = end ;cp1 >= base; cp1--)
9209       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9210         { cp1++; break; }
9211     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9212     PerlMem_free(unixified);
9213     PerlMem_free(unixwild);
9214     return 1;
9215   }
9216   else {
9217     char *tpl, *lcres;
9218     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9219     int ells = 1, totells, segdirs, match;
9220     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9221                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9222
9223     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9224     totells = ells;
9225     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9226     tpl = PerlMem_malloc(VMS_MAXRSS);
9227     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
9228     if (ellipsis == template && opts & 1) {
9229       /* Template begins with an ellipsis.  Since we can't tell how many
9230        * directory names at the front of the resultant to keep for an
9231        * arbitrary starting point, we arbitrarily choose the current
9232        * default directory as a starting point.  If it's there as a prefix,
9233        * clip it off.  If not, fall through and act as if the leading
9234        * ellipsis weren't there (i.e. return shortest possible path that
9235        * could match template).
9236        */
9237       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9238           PerlMem_free(tpl);
9239           PerlMem_free(unixified);
9240           PerlMem_free(unixwild);
9241           return 0;
9242       }
9243       if (!decc_efs_case_preserve) {
9244         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9245           if (_tolower(*cp1) != _tolower(*cp2)) break;
9246       }
9247       segdirs = dirs - totells;  /* Min # of dirs we must have left */
9248       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9249       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9250         memmove(fspec,cp2+1,end - cp2);
9251         PerlMem_free(tpl);
9252         PerlMem_free(unixified);
9253         PerlMem_free(unixwild);
9254         return 1;
9255       }
9256     }
9257     /* First off, back up over constant elements at end of path */
9258     if (dirs) {
9259       for (front = end ; front >= base; front--)
9260          if (*front == '/' && !dirs--) { front++; break; }
9261     }
9262     lcres = PerlMem_malloc(VMS_MAXRSS);
9263     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
9264     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9265          cp1++,cp2++) {
9266             if (!decc_efs_case_preserve) {
9267                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
9268             }
9269             else {
9270                 *cp2 = *cp1;
9271             }
9272     }
9273     if (cp1 != '\0') {
9274         PerlMem_free(tpl);
9275         PerlMem_free(unixified);
9276         PerlMem_free(unixwild);
9277         PerlMem_free(lcres);
9278         return 0;  /* Path too long. */
9279     }
9280     lcend = cp2;
9281     *cp2 = '\0';  /* Pick up with memcpy later */
9282     lcfront = lcres + (front - base);
9283     /* Now skip over each ellipsis and try to match the path in front of it. */
9284     while (ells--) {
9285       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9286         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
9287             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
9288       if (cp1 < template) break; /* template started with an ellipsis */
9289       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9290         ellipsis = cp1; continue;
9291       }
9292       wilddsc.dsc$a_pointer = tpl;
9293       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9294       nextell = cp1;
9295       for (segdirs = 0, cp2 = tpl;
9296            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9297            cp1++, cp2++) {
9298          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9299          else {
9300             if (!decc_efs_case_preserve) {
9301               *cp2 = _tolower(*cp1);  /* else lowercase for match */
9302             }
9303             else {
9304               *cp2 = *cp1;  /* else preserve case for match */
9305             }
9306          }
9307          if (*cp2 == '/') segdirs++;
9308       }
9309       if (cp1 != ellipsis - 1) {
9310           PerlMem_free(tpl);
9311           PerlMem_free(unixified);
9312           PerlMem_free(unixwild);
9313           PerlMem_free(lcres);
9314           return 0; /* Path too long */
9315       }
9316       /* Back up at least as many dirs as in template before matching */
9317       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9318         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9319       for (match = 0; cp1 > lcres;) {
9320         resdsc.dsc$a_pointer = cp1;
9321         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9322           match++;
9323           if (match == 1) lcfront = cp1;
9324         }
9325         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9326       }
9327       if (!match) {
9328         PerlMem_free(tpl);
9329         PerlMem_free(unixified);
9330         PerlMem_free(unixwild);
9331         PerlMem_free(lcres);
9332         return 0;  /* Can't find prefix ??? */
9333       }
9334       if (match > 1 && opts & 1) {
9335         /* This ... wildcard could cover more than one set of dirs (i.e.
9336          * a set of similar dir names is repeated).  If the template
9337          * contains more than 1 ..., upstream elements could resolve the
9338          * ambiguity, but it's not worth a full backtracking setup here.
9339          * As a quick heuristic, clip off the current default directory
9340          * if it's present to find the trimmed spec, else use the
9341          * shortest string that this ... could cover.
9342          */
9343         char def[NAM$C_MAXRSS+1], *st;
9344
9345         if (getcwd(def, sizeof def,0) == NULL) {
9346             Safefree(unixified);
9347             Safefree(unixwild);
9348             Safefree(lcres);
9349             Safefree(tpl);
9350             return 0;
9351         }
9352         if (!decc_efs_case_preserve) {
9353           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9354             if (_tolower(*cp1) != _tolower(*cp2)) break;
9355         }
9356         segdirs = dirs - totells;  /* Min # of dirs we must have left */
9357         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9358         if (*cp1 == '\0' && *cp2 == '/') {
9359           memmove(fspec,cp2+1,end - cp2);
9360           PerlMem_free(tpl);
9361           PerlMem_free(unixified);
9362           PerlMem_free(unixwild);
9363           PerlMem_free(lcres);
9364           return 1;
9365         }
9366         /* Nope -- stick with lcfront from above and keep going. */
9367       }
9368     }
9369     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9370     PerlMem_free(tpl);
9371     PerlMem_free(unixified);
9372     PerlMem_free(unixwild);
9373     PerlMem_free(lcres);
9374     return 1;
9375     ellipsis = nextell;
9376   }
9377
9378 }  /* end of trim_unixpath() */
9379 /*}}}*/
9380
9381
9382 /*
9383  *  VMS readdir() routines.
9384  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9385  *
9386  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
9387  *  Minor modifications to original routines.
9388  */
9389
9390 /* readdir may have been redefined by reentr.h, so make sure we get
9391  * the local version for what we do here.
9392  */
9393 #ifdef readdir
9394 # undef readdir
9395 #endif
9396 #if !defined(PERL_IMPLICIT_CONTEXT)
9397 # define readdir Perl_readdir
9398 #else
9399 # define readdir(a) Perl_readdir(aTHX_ a)
9400 #endif
9401
9402     /* Number of elements in vms_versions array */
9403 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
9404
9405 /*
9406  *  Open a directory, return a handle for later use.
9407  */
9408 /*{{{ DIR *opendir(char*name) */
9409 DIR *
9410 Perl_opendir(pTHX_ const char *name)
9411 {
9412     DIR *dd;
9413     char *dir;
9414     Stat_t sb;
9415
9416     Newx(dir, VMS_MAXRSS, char);
9417     if (do_tovmspath(name,dir,0,NULL) == NULL) {
9418       Safefree(dir);
9419       return NULL;
9420     }
9421     /* Check access before stat; otherwise stat does not
9422      * accurately report whether it's a directory.
9423      */
9424     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9425       /* cando_by_name has already set errno */
9426       Safefree(dir);
9427       return NULL;
9428     }
9429     if (flex_stat(dir,&sb) == -1) return NULL;
9430     if (!S_ISDIR(sb.st_mode)) {
9431       Safefree(dir);
9432       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
9433       return NULL;
9434     }
9435     /* Get memory for the handle, and the pattern. */
9436     Newx(dd,1,DIR);
9437     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9438
9439     /* Fill in the fields; mainly playing with the descriptor. */
9440     sprintf(dd->pattern, "%s*.*",dir);
9441     Safefree(dir);
9442     dd->context = 0;
9443     dd->count = 0;
9444     dd->flags = 0;
9445     /* By saying we always want the result of readdir() in unix format, we
9446      * are really saying we want all the escapes removed.  Otherwise the caller,
9447      * having no way to know whether it's already in VMS format, might send it
9448      * through tovmsspec again, thus double escaping.
9449      */
9450     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
9451     dd->pat.dsc$a_pointer = dd->pattern;
9452     dd->pat.dsc$w_length = strlen(dd->pattern);
9453     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9454     dd->pat.dsc$b_class = DSC$K_CLASS_S;
9455 #if defined(USE_ITHREADS)
9456     Newx(dd->mutex,1,perl_mutex);
9457     MUTEX_INIT( (perl_mutex *) dd->mutex );
9458 #else
9459     dd->mutex = NULL;
9460 #endif
9461
9462     return dd;
9463 }  /* end of opendir() */
9464 /*}}}*/
9465
9466 /*
9467  *  Set the flag to indicate we want versions or not.
9468  */
9469 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9470 void
9471 vmsreaddirversions(DIR *dd, int flag)
9472 {
9473     if (flag)
9474         dd->flags |= PERL_VMSDIR_M_VERSIONS;
9475     else
9476         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9477 }
9478 /*}}}*/
9479
9480 /*
9481  *  Free up an opened directory.
9482  */
9483 /*{{{ void closedir(DIR *dd)*/
9484 void
9485 Perl_closedir(DIR *dd)
9486 {
9487     int sts;
9488
9489     sts = lib$find_file_end(&dd->context);
9490     Safefree(dd->pattern);
9491 #if defined(USE_ITHREADS)
9492     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
9493     Safefree(dd->mutex);
9494 #endif
9495     Safefree(dd);
9496 }
9497 /*}}}*/
9498
9499 /*
9500  *  Collect all the version numbers for the current file.
9501  */
9502 static void
9503 collectversions(pTHX_ DIR *dd)
9504 {
9505     struct dsc$descriptor_s     pat;
9506     struct dsc$descriptor_s     res;
9507     struct dirent *e;
9508     char *p, *text, *buff;
9509     int i;
9510     unsigned long context, tmpsts;
9511
9512     /* Convenient shorthand. */
9513     e = &dd->entry;
9514
9515     /* Add the version wildcard, ignoring the "*.*" put on before */
9516     i = strlen(dd->pattern);
9517     Newx(text,i + e->d_namlen + 3,char);
9518     strcpy(text, dd->pattern);
9519     sprintf(&text[i - 3], "%s;*", e->d_name);
9520
9521     /* Set up the pattern descriptor. */
9522     pat.dsc$a_pointer = text;
9523     pat.dsc$w_length = i + e->d_namlen - 1;
9524     pat.dsc$b_dtype = DSC$K_DTYPE_T;
9525     pat.dsc$b_class = DSC$K_CLASS_S;
9526
9527     /* Set up result descriptor. */
9528     Newx(buff, VMS_MAXRSS, char);
9529     res.dsc$a_pointer = buff;
9530     res.dsc$w_length = VMS_MAXRSS - 1;
9531     res.dsc$b_dtype = DSC$K_DTYPE_T;
9532     res.dsc$b_class = DSC$K_CLASS_S;
9533
9534     /* Read files, collecting versions. */
9535     for (context = 0, e->vms_verscount = 0;
9536          e->vms_verscount < VERSIZE(e);
9537          e->vms_verscount++) {
9538         unsigned long rsts;
9539         unsigned long flags = 0;
9540
9541 #ifdef VMS_LONGNAME_SUPPORT
9542         flags = LIB$M_FIL_LONG_NAMES;
9543 #endif
9544         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
9545         if (tmpsts == RMS$_NMF || context == 0) break;
9546         _ckvmssts(tmpsts);
9547         buff[VMS_MAXRSS - 1] = '\0';
9548         if ((p = strchr(buff, ';')))
9549             e->vms_versions[e->vms_verscount] = atoi(p + 1);
9550         else
9551             e->vms_versions[e->vms_verscount] = -1;
9552     }
9553
9554     _ckvmssts(lib$find_file_end(&context));
9555     Safefree(text);
9556     Safefree(buff);
9557
9558 }  /* end of collectversions() */
9559
9560 /*
9561  *  Read the next entry from the directory.
9562  */
9563 /*{{{ struct dirent *readdir(DIR *dd)*/
9564 struct dirent *
9565 Perl_readdir(pTHX_ DIR *dd)
9566 {
9567     struct dsc$descriptor_s     res;
9568     char *p, *buff;
9569     unsigned long int tmpsts;
9570     unsigned long rsts;
9571     unsigned long flags = 0;
9572     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
9573     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
9574
9575     /* Set up result descriptor, and get next file. */
9576     Newx(buff, VMS_MAXRSS, char);
9577     res.dsc$a_pointer = buff;
9578     res.dsc$w_length = VMS_MAXRSS - 1;
9579     res.dsc$b_dtype = DSC$K_DTYPE_T;
9580     res.dsc$b_class = DSC$K_CLASS_S;
9581
9582 #ifdef VMS_LONGNAME_SUPPORT
9583     flags = LIB$M_FIL_LONG_NAMES;
9584 #endif
9585
9586     tmpsts = lib$find_file
9587         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
9588     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
9589     if (!(tmpsts & 1)) {
9590       set_vaxc_errno(tmpsts);
9591       switch (tmpsts) {
9592         case RMS$_PRV:
9593           set_errno(EACCES); break;
9594         case RMS$_DEV:
9595           set_errno(ENODEV); break;
9596         case RMS$_DIR:
9597           set_errno(ENOTDIR); break;
9598         case RMS$_FNF: case RMS$_DNF:
9599           set_errno(ENOENT); break;
9600         default:
9601           set_errno(EVMSERR);
9602       }
9603       Safefree(buff);
9604       return NULL;
9605     }
9606     dd->count++;
9607     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
9608     buff[res.dsc$w_length] = '\0';
9609     p = buff + res.dsc$w_length;
9610     while (--p >= buff) if (!isspace(*p)) break;
9611     *p = '\0';
9612     if (!decc_efs_case_preserve) {
9613       for (p = buff; *p; p++) *p = _tolower(*p);
9614     }
9615
9616     /* Skip any directory component and just copy the name. */
9617     sts = vms_split_path
9618        (buff,
9619         &v_spec,
9620         &v_len,
9621         &r_spec,
9622         &r_len,
9623         &d_spec,
9624         &d_len,
9625         &n_spec,
9626         &n_len,
9627         &e_spec,
9628         &e_len,
9629         &vs_spec,
9630         &vs_len);
9631
9632     /* Drop NULL extensions on UNIX file specification */
9633     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
9634         (e_len == 1) && decc_readdir_dropdotnotype)) {
9635         e_len = 0;
9636         e_spec[0] = '\0';
9637     }
9638
9639     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9640     dd->entry.d_name[n_len + e_len] = '\0';
9641     dd->entry.d_namlen = strlen(dd->entry.d_name);
9642
9643     /* Convert the filename to UNIX format if needed */
9644     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9645
9646         /* Translate the encoded characters. */
9647         /* Fixme: Unicode handling could result in embedded 0 characters */
9648         if (strchr(dd->entry.d_name, '^') != NULL) {
9649             char new_name[256];
9650             char * q;
9651             p = dd->entry.d_name;
9652             q = new_name;
9653             while (*p != 0) {
9654                 int inchars_read, outchars_added;
9655                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9656                 p += inchars_read;
9657                 q += outchars_added;
9658                 /* fix-me */
9659                 /* if outchars_added > 1, then this is a wide file specification */
9660                 /* Wide file specifications need to be passed in Perl */
9661                 /* counted strings apparently with a Unicode flag */
9662             }
9663             *q = 0;
9664             strcpy(dd->entry.d_name, new_name);
9665             dd->entry.d_namlen = strlen(dd->entry.d_name);
9666         }
9667     }
9668
9669     dd->entry.vms_verscount = 0;
9670     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9671     Safefree(buff);
9672     return &dd->entry;
9673
9674 }  /* end of readdir() */
9675 /*}}}*/
9676
9677 /*
9678  *  Read the next entry from the directory -- thread-safe version.
9679  */
9680 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9681 int
9682 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9683 {
9684     int retval;
9685
9686     MUTEX_LOCK( (perl_mutex *) dd->mutex );
9687
9688     entry = readdir(dd);
9689     *result = entry;
9690     retval = ( *result == NULL ? errno : 0 );
9691
9692     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9693
9694     return retval;
9695
9696 }  /* end of readdir_r() */
9697 /*}}}*/
9698
9699 /*
9700  *  Return something that can be used in a seekdir later.
9701  */
9702 /*{{{ long telldir(DIR *dd)*/
9703 long
9704 Perl_telldir(DIR *dd)
9705 {
9706     return dd->count;
9707 }
9708 /*}}}*/
9709
9710 /*
9711  *  Return to a spot where we used to be.  Brute force.
9712  */
9713 /*{{{ void seekdir(DIR *dd,long count)*/
9714 void
9715 Perl_seekdir(pTHX_ DIR *dd, long count)
9716 {
9717     int old_flags;
9718
9719     /* If we haven't done anything yet... */
9720     if (dd->count == 0)
9721         return;
9722
9723     /* Remember some state, and clear it. */
9724     old_flags = dd->flags;
9725     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9726     _ckvmssts(lib$find_file_end(&dd->context));
9727     dd->context = 0;
9728
9729     /* The increment is in readdir(). */
9730     for (dd->count = 0; dd->count < count; )
9731         readdir(dd);
9732
9733     dd->flags = old_flags;
9734
9735 }  /* end of seekdir() */
9736 /*}}}*/
9737
9738 /* VMS subprocess management
9739  *
9740  * my_vfork() - just a vfork(), after setting a flag to record that
9741  * the current script is trying a Unix-style fork/exec.
9742  *
9743  * vms_do_aexec() and vms_do_exec() are called in response to the
9744  * perl 'exec' function.  If this follows a vfork call, then they
9745  * call out the regular perl routines in doio.c which do an
9746  * execvp (for those who really want to try this under VMS).
9747  * Otherwise, they do exactly what the perl docs say exec should
9748  * do - terminate the current script and invoke a new command
9749  * (See below for notes on command syntax.)
9750  *
9751  * do_aspawn() and do_spawn() implement the VMS side of the perl
9752  * 'system' function.
9753  *
9754  * Note on command arguments to perl 'exec' and 'system': When handled
9755  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9756  * are concatenated to form a DCL command string.  If the first non-numeric
9757  * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
9758  * the command string is handed off to DCL directly.  Otherwise,
9759  * the first token of the command is taken as the filespec of an image
9760  * to run.  The filespec is expanded using a default type of '.EXE' and
9761  * the process defaults for device, directory, etc., and if found, the resultant
9762  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9763  * the command string as parameters.  This is perhaps a bit complicated,
9764  * but I hope it will form a happy medium between what VMS folks expect
9765  * from lib$spawn and what Unix folks expect from exec.
9766  */
9767
9768 static int vfork_called;
9769
9770 /*{{{int my_vfork()*/
9771 int
9772 my_vfork()
9773 {
9774   vfork_called++;
9775   return vfork();
9776 }
9777 /*}}}*/
9778
9779
9780 static void
9781 vms_execfree(struct dsc$descriptor_s *vmscmd)
9782 {
9783   if (vmscmd) {
9784       if (vmscmd->dsc$a_pointer) {
9785           PerlMem_free(vmscmd->dsc$a_pointer);
9786       }
9787       PerlMem_free(vmscmd);
9788   }
9789 }
9790
9791 static char *
9792 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9793 {
9794   char *junk, *tmps = NULL;
9795   register size_t cmdlen = 0;
9796   size_t rlen;
9797   register SV **idx;
9798   STRLEN n_a;
9799
9800   idx = mark;
9801   if (really) {
9802     tmps = SvPV(really,rlen);
9803     if (*tmps) {
9804       cmdlen += rlen + 1;
9805       idx++;
9806     }
9807   }
9808
9809   for (idx++; idx <= sp; idx++) {
9810     if (*idx) {
9811       junk = SvPVx(*idx,rlen);
9812       cmdlen += rlen ? rlen + 1 : 0;
9813     }
9814   }
9815   Newx(PL_Cmd, cmdlen+1, char);
9816
9817   if (tmps && *tmps) {
9818     strcpy(PL_Cmd,tmps);
9819     mark++;
9820   }
9821   else *PL_Cmd = '\0';
9822   while (++mark <= sp) {
9823     if (*mark) {
9824       char *s = SvPVx(*mark,n_a);
9825       if (!*s) continue;
9826       if (*PL_Cmd) strcat(PL_Cmd," ");
9827       strcat(PL_Cmd,s);
9828     }
9829   }
9830   return PL_Cmd;
9831
9832 }  /* end of setup_argstr() */
9833
9834
9835 static unsigned long int
9836 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9837                    struct dsc$descriptor_s **pvmscmd)
9838 {
9839   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9840   char image_name[NAM$C_MAXRSS+1];
9841   char image_argv[NAM$C_MAXRSS+1];
9842   $DESCRIPTOR(defdsc,".EXE");
9843   $DESCRIPTOR(defdsc2,".");
9844   $DESCRIPTOR(resdsc,resspec);
9845   struct dsc$descriptor_s *vmscmd;
9846   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9847   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9848   register char *s, *rest, *cp, *wordbreak;
9849   char * cmd;
9850   int cmdlen;
9851   register int isdcl;
9852
9853   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9854   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9855
9856   /* Make a copy for modification */
9857   cmdlen = strlen(incmd);
9858   cmd = PerlMem_malloc(cmdlen+1);
9859   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9860   strncpy(cmd, incmd, cmdlen);
9861   cmd[cmdlen] = 0;
9862   image_name[0] = 0;
9863   image_argv[0] = 0;
9864
9865   vmscmd->dsc$a_pointer = NULL;
9866   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
9867   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
9868   vmscmd->dsc$w_length = 0;
9869   if (pvmscmd) *pvmscmd = vmscmd;
9870
9871   if (suggest_quote) *suggest_quote = 0;
9872
9873   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9874     PerlMem_free(cmd);
9875     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
9876   }
9877
9878   s = cmd;
9879
9880   while (*s && isspace(*s)) s++;
9881
9882   if (*s == '@' || *s == '$') {
9883     vmsspec[0] = *s;  rest = s + 1;
9884     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9885   }
9886   else { cp = vmsspec; rest = s; }
9887   if (*rest == '.' || *rest == '/') {
9888     char *cp2;
9889     for (cp2 = resspec;
9890          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9891          rest++, cp2++) *cp2 = *rest;
9892     *cp2 = '\0';
9893     if (do_tovmsspec(resspec,cp,0,NULL)) {
9894       s = vmsspec;
9895
9896       /* When a UNIX spec with no file type is translated to VMS, */
9897       /* A trailing '.' is appended under ODS-5 rules.            */
9898       /* Here we do not want that trailing "." as it prevents     */
9899       /* Looking for a implied ".exe" type. */
9900       if (decc_efs_charset) {
9901           int i;
9902           i = strlen(vmsspec);
9903           if (vmsspec[i-1] == '.') {
9904               vmsspec[i-1] = '\0';
9905           }
9906       }
9907
9908       if (*rest) {
9909         for (cp2 = vmsspec + strlen(vmsspec);
9910              *rest && cp2 - vmsspec < sizeof vmsspec;
9911              rest++, cp2++) *cp2 = *rest;
9912         *cp2 = '\0';
9913       }
9914     }
9915   }
9916   /* Intuit whether verb (first word of cmd) is a DCL command:
9917    *   - if first nonspace char is '@', it's a DCL indirection
9918    * otherwise
9919    *   - if verb contains a filespec separator, it's not a DCL command
9920    *   - if it doesn't, caller tells us whether to default to a DCL
9921    *     command, or to a local image unless told it's DCL (by leading '$')
9922    */
9923   if (*s == '@') {
9924       isdcl = 1;
9925       if (suggest_quote) *suggest_quote = 1;
9926   } else {
9927     register char *filespec = strpbrk(s,":<[.;");
9928     rest = wordbreak = strpbrk(s," \"\t/");
9929     if (!wordbreak) wordbreak = s + strlen(s);
9930     if (*s == '$') check_img = 0;
9931     if (filespec && (filespec < wordbreak)) isdcl = 0;
9932     else isdcl = !check_img;
9933   }
9934
9935   if (!isdcl) {
9936     int rsts;
9937     imgdsc.dsc$a_pointer = s;
9938     imgdsc.dsc$w_length = wordbreak - s;
9939     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9940     if (!(retsts&1)) {
9941         _ckvmssts(lib$find_file_end(&cxt));
9942         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9943       if (!(retsts & 1) && *s == '$') {
9944         _ckvmssts(lib$find_file_end(&cxt));
9945         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9946         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9947         if (!(retsts&1)) {
9948           _ckvmssts(lib$find_file_end(&cxt));
9949           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9950         }
9951       }
9952     }
9953     _ckvmssts(lib$find_file_end(&cxt));
9954
9955     if (retsts & 1) {
9956       FILE *fp;
9957       s = resspec;
9958       while (*s && !isspace(*s)) s++;
9959       *s = '\0';
9960
9961       /* check that it's really not DCL with no file extension */
9962       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9963       if (fp) {
9964         char b[256] = {0,0,0,0};
9965         read(fileno(fp), b, 256);
9966         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9967         if (isdcl) {
9968           int shebang_len;
9969
9970           /* Check for script */
9971           shebang_len = 0;
9972           if ((b[0] == '#') && (b[1] == '!'))
9973              shebang_len = 2;
9974 #ifdef ALTERNATE_SHEBANG
9975           else {
9976             shebang_len = strlen(ALTERNATE_SHEBANG);
9977             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9978               char * perlstr;
9979                 perlstr = strstr("perl",b);
9980                 if (perlstr == NULL)
9981                   shebang_len = 0;
9982             }
9983             else
9984               shebang_len = 0;
9985           }
9986 #endif
9987
9988           if (shebang_len > 0) {
9989           int i;
9990           int j;
9991           char tmpspec[NAM$C_MAXRSS + 1];
9992
9993             i = shebang_len;
9994              /* Image is following after white space */
9995             /*--------------------------------------*/
9996             while (isprint(b[i]) && isspace(b[i]))
9997                 i++;
9998
9999             j = 0;
10000             while (isprint(b[i]) && !isspace(b[i])) {
10001                 tmpspec[j++] = b[i++];
10002                 if (j >= NAM$C_MAXRSS)
10003                    break;
10004             }
10005             tmpspec[j] = '\0';
10006
10007              /* There may be some default parameters to the image */
10008             /*---------------------------------------------------*/
10009             j = 0;
10010             while (isprint(b[i])) {
10011                 image_argv[j++] = b[i++];
10012                 if (j >= NAM$C_MAXRSS)
10013                    break;
10014             }
10015             while ((j > 0) && !isprint(image_argv[j-1]))
10016                 j--;
10017             image_argv[j] = 0;
10018
10019             /* It will need to be converted to VMS format and validated */
10020             if (tmpspec[0] != '\0') {
10021               char * iname;
10022
10023                /* Try to find the exact program requested to be run */
10024               /*---------------------------------------------------*/
10025               iname = do_rmsexpand
10026                  (tmpspec, image_name, 0, ".exe",
10027                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10028               if (iname != NULL) {
10029                 if (cando_by_name_int
10030                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10031                   /* MCR prefix needed */
10032                   isdcl = 0;
10033                 }
10034                 else {
10035                    /* Try again with a null type */
10036                   /*----------------------------*/
10037                   iname = do_rmsexpand
10038                     (tmpspec, image_name, 0, ".",
10039                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10040                   if (iname != NULL) {
10041                     if (cando_by_name_int
10042                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10043                       /* MCR prefix needed */
10044                       isdcl = 0;
10045                     }
10046                   }
10047                 }
10048
10049                  /* Did we find the image to run the script? */
10050                 /*------------------------------------------*/
10051                 if (isdcl) {
10052                   char *tchr;
10053
10054                    /* Assume DCL or foreign command exists */
10055                   /*--------------------------------------*/
10056                   tchr = strrchr(tmpspec, '/');
10057                   if (tchr != NULL) {
10058                     tchr++;
10059                   }
10060                   else {
10061                     tchr = tmpspec;
10062                   }
10063                   strcpy(image_name, tchr);
10064                 }
10065               }
10066             }
10067           }
10068         }
10069         fclose(fp);
10070       }
10071       if (check_img && isdcl) return RMS$_FNF;
10072
10073       if (cando_by_name(S_IXUSR,0,resspec)) {
10074         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10075         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10076         if (!isdcl) {
10077             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10078             if (image_name[0] != 0) {
10079                 strcat(vmscmd->dsc$a_pointer, image_name);
10080                 strcat(vmscmd->dsc$a_pointer, " ");
10081             }
10082         } else if (image_name[0] != 0) {
10083             strcpy(vmscmd->dsc$a_pointer, image_name);
10084             strcat(vmscmd->dsc$a_pointer, " ");
10085         } else {
10086             strcpy(vmscmd->dsc$a_pointer,"@");
10087         }
10088         if (suggest_quote) *suggest_quote = 1;
10089
10090         /* If there is an image name, use original command */
10091         if (image_name[0] == 0)
10092             strcat(vmscmd->dsc$a_pointer,resspec);
10093         else {
10094             rest = cmd;
10095             while (*rest && isspace(*rest)) rest++;
10096         }
10097
10098         if (image_argv[0] != 0) {
10099           strcat(vmscmd->dsc$a_pointer,image_argv);
10100           strcat(vmscmd->dsc$a_pointer, " ");
10101         }
10102         if (rest) {
10103            int rest_len;
10104            int vmscmd_len;
10105
10106            rest_len = strlen(rest);
10107            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10108            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10109               strcat(vmscmd->dsc$a_pointer,rest);
10110            else
10111              retsts = CLI$_BUFOVF;
10112         }
10113         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10114         PerlMem_free(cmd);
10115         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10116       }
10117       else
10118         retsts = RMS$_PRV;
10119     }
10120   }
10121   /* It's either a DCL command or we couldn't find a suitable image */
10122   vmscmd->dsc$w_length = strlen(cmd);
10123
10124   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10125   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10126   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10127
10128   PerlMem_free(cmd);
10129
10130   /* check if it's a symbol (for quoting purposes) */
10131   if (suggest_quote && !*suggest_quote) {
10132     int iss;
10133     char equiv[LNM$C_NAMLENGTH];
10134     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10135     eqvdsc.dsc$a_pointer = equiv;
10136
10137     iss = lib$get_symbol(vmscmd,&eqvdsc);
10138     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10139   }
10140   if (!(retsts & 1)) {
10141     /* just hand off status values likely to be due to user error */
10142     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10143         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10144        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10145     else { _ckvmssts(retsts); }
10146   }
10147
10148   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10149
10150 }  /* end of setup_cmddsc() */
10151
10152
10153 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10154 bool
10155 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10156 {
10157 bool exec_sts;
10158 char * cmd;
10159
10160   if (sp > mark) {
10161     if (vfork_called) {           /* this follows a vfork - act Unixish */
10162       vfork_called--;
10163       if (vfork_called < 0) {
10164         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10165         vfork_called = 0;
10166       }
10167       else return do_aexec(really,mark,sp);
10168     }
10169                                            /* no vfork - act VMSish */
10170     cmd = setup_argstr(aTHX_ really,mark,sp);
10171     exec_sts = vms_do_exec(cmd);
10172     Safefree(cmd);  /* Clean up from setup_argstr() */
10173     return exec_sts;
10174   }
10175
10176   return FALSE;
10177 }  /* end of vms_do_aexec() */
10178 /*}}}*/
10179
10180 /* {{{bool vms_do_exec(char *cmd) */
10181 bool
10182 Perl_vms_do_exec(pTHX_ const char *cmd)
10183 {
10184   struct dsc$descriptor_s *vmscmd;
10185
10186   if (vfork_called) {             /* this follows a vfork - act Unixish */
10187     vfork_called--;
10188     if (vfork_called < 0) {
10189       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10190       vfork_called = 0;
10191     }
10192     else return do_exec(cmd);
10193   }
10194
10195   {                               /* no vfork - act VMSish */
10196     unsigned long int retsts;
10197
10198     TAINT_ENV();
10199     TAINT_PROPER("exec");
10200     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10201       retsts = lib$do_command(vmscmd);
10202
10203     switch (retsts) {
10204       case RMS$_FNF: case RMS$_DNF:
10205         set_errno(ENOENT); break;
10206       case RMS$_DIR:
10207         set_errno(ENOTDIR); break;
10208       case RMS$_DEV:
10209         set_errno(ENODEV); break;
10210       case RMS$_PRV:
10211         set_errno(EACCES); break;
10212       case RMS$_SYN:
10213         set_errno(EINVAL); break;
10214       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10215         set_errno(E2BIG); break;
10216       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10217         _ckvmssts(retsts); /* fall through */
10218       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10219         set_errno(EVMSERR);
10220     }
10221     set_vaxc_errno(retsts);
10222     if (ckWARN(WARN_EXEC)) {
10223       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10224              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10225     }
10226     vms_execfree(vmscmd);
10227   }
10228
10229   return FALSE;
10230
10231 }  /* end of vms_do_exec() */
10232 /*}}}*/
10233
10234 int do_spawn2(pTHX_ const char *, int);
10235
10236 int
10237 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10238 {
10239 unsigned long int sts;
10240 char * cmd;
10241 int flags = 0;
10242
10243   if (sp > mark) {
10244
10245     /* We'll copy the (undocumented?) Win32 behavior and allow a
10246      * numeric first argument.  But the only value we'll support
10247      * through do_aspawn is a value of 1, which means spawn without
10248      * waiting for completion -- other values are ignored.
10249      */
10250     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10251         ++mark;
10252         flags = SvIVx(*mark);
10253     }
10254
10255     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10256         flags = CLI$M_NOWAIT;
10257     else
10258         flags = 0;
10259
10260     cmd = setup_argstr(aTHX_ really, mark, sp);
10261     sts = do_spawn2(aTHX_ cmd, flags);
10262     /* pp_sys will clean up cmd */
10263     return sts;
10264   }
10265   return SS$_ABORT;
10266 }  /* end of do_aspawn() */
10267 /*}}}*/
10268
10269
10270 /* {{{int do_spawn(char* cmd) */
10271 int
10272 Perl_do_spawn(pTHX_ char* cmd)
10273 {
10274     PERL_ARGS_ASSERT_DO_SPAWN;
10275
10276     return do_spawn2(aTHX_ cmd, 0);
10277 }
10278 /*}}}*/
10279
10280 /* {{{int do_spawn_nowait(char* cmd) */
10281 int
10282 Perl_do_spawn_nowait(pTHX_ char* cmd)
10283 {
10284     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10285
10286     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10287 }
10288 /*}}}*/
10289
10290 /* {{{int do_spawn2(char *cmd) */
10291 int
10292 do_spawn2(pTHX_ const char *cmd, int flags)
10293 {
10294   unsigned long int sts, substs;
10295
10296   /* The caller of this routine expects to Safefree(PL_Cmd) */
10297   Newx(PL_Cmd,10,char);
10298
10299   TAINT_ENV();
10300   TAINT_PROPER("spawn");
10301   if (!cmd || !*cmd) {
10302     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10303     if (!(sts & 1)) {
10304       switch (sts) {
10305         case RMS$_FNF:  case RMS$_DNF:
10306           set_errno(ENOENT); break;
10307         case RMS$_DIR:
10308           set_errno(ENOTDIR); break;
10309         case RMS$_DEV:
10310           set_errno(ENODEV); break;
10311         case RMS$_PRV:
10312           set_errno(EACCES); break;
10313         case RMS$_SYN:
10314           set_errno(EINVAL); break;
10315         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10316           set_errno(E2BIG); break;
10317         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10318           _ckvmssts(sts); /* fall through */
10319         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10320           set_errno(EVMSERR);
10321       }
10322       set_vaxc_errno(sts);
10323       if (ckWARN(WARN_EXEC)) {
10324         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10325                     Strerror(errno));
10326       }
10327     }
10328     sts = substs;
10329   }
10330   else {
10331     char mode[3];
10332     PerlIO * fp;
10333     if (flags & CLI$M_NOWAIT)
10334         strcpy(mode, "n");
10335     else
10336         strcpy(mode, "nW");
10337
10338     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10339     if (fp != NULL)
10340       my_pclose(fp);
10341     /* sts will be the pid in the nowait case */
10342   }
10343   return sts;
10344 }  /* end of do_spawn2() */
10345 /*}}}*/
10346
10347
10348 static unsigned int *sockflags, sockflagsize;
10349
10350 /*
10351  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10352  * routines found in some versions of the CRTL can't deal with sockets.
10353  * We don't shim the other file open routines since a socket isn't
10354  * likely to be opened by a name.
10355  */
10356 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10357 FILE *my_fdopen(int fd, const char *mode)
10358 {
10359   FILE *fp = fdopen(fd, mode);
10360
10361   if (fp) {
10362     unsigned int fdoff = fd / sizeof(unsigned int);
10363     Stat_t sbuf; /* native stat; we don't need flex_stat */
10364     if (!sockflagsize || fdoff > sockflagsize) {
10365       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
10366       else           Newx  (sockflags,fdoff+2,unsigned int);
10367       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10368       sockflagsize = fdoff + 2;
10369     }
10370     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
10371       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10372   }
10373   return fp;
10374
10375 }
10376 /*}}}*/
10377
10378
10379 /*
10380  * Clear the corresponding bit when the (possibly) socket stream is closed.
10381  * There still a small hole: we miss an implicit close which might occur
10382  * via freopen().  >> Todo
10383  */
10384 /*{{{ int my_fclose(FILE *fp)*/
10385 int my_fclose(FILE *fp) {
10386   if (fp) {
10387     unsigned int fd = fileno(fp);
10388     unsigned int fdoff = fd / sizeof(unsigned int);
10389
10390     if (sockflagsize && fdoff < sockflagsize)
10391       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10392   }
10393   return fclose(fp);
10394 }
10395 /*}}}*/
10396
10397
10398 /*
10399  * A simple fwrite replacement which outputs itmsz*nitm chars without
10400  * introducing record boundaries every itmsz chars.
10401  * We are using fputs, which depends on a terminating null.  We may
10402  * well be writing binary data, so we need to accommodate not only
10403  * data with nulls sprinkled in the middle but also data with no null
10404  * byte at the end.
10405  */
10406 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10407 int
10408 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
10409 {
10410   register char *cp, *end, *cpd, *data;
10411   register unsigned int fd = fileno(dest);
10412   register unsigned int fdoff = fd / sizeof(unsigned int);
10413   int retval;
10414   int bufsize = itmsz * nitm + 1;
10415
10416   if (fdoff < sockflagsize &&
10417       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10418     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10419     return nitm;
10420   }
10421
10422   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
10423   memcpy( data, src, itmsz*nitm );
10424   data[itmsz*nitm] = '\0';
10425
10426   end = data + itmsz * nitm;
10427   retval = (int) nitm; /* on success return # items written */
10428
10429   cpd = data;
10430   while (cpd <= end) {
10431     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10432     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
10433     if (cp < end)
10434       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10435     cpd = cp + 1;
10436   }
10437
10438   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
10439   return retval;
10440
10441 }  /* end of my_fwrite() */
10442 /*}}}*/
10443
10444 /*{{{ int my_flush(FILE *fp)*/
10445 int
10446 Perl_my_flush(pTHX_ FILE *fp)
10447 {
10448     int res;
10449     if ((res = fflush(fp)) == 0 && fp) {
10450 #ifdef VMS_DO_SOCKETS
10451         Stat_t s;
10452         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
10453 #endif
10454             res = fsync(fileno(fp));
10455     }
10456 /*
10457  * If the flush succeeded but set end-of-file, we need to clear
10458  * the error because our caller may check ferror().  BTW, this
10459  * probably means we just flushed an empty file.
10460  */
10461     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10462
10463     return res;
10464 }
10465 /*}}}*/
10466
10467 /*
10468  * Here are replacements for the following Unix routines in the VMS environment:
10469  *      getpwuid    Get information for a particular UIC or UID
10470  *      getpwnam    Get information for a named user
10471  *      getpwent    Get information for each user in the rights database
10472  *      setpwent    Reset search to the start of the rights database
10473  *      endpwent    Finish searching for users in the rights database
10474  *
10475  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10476  * (defined in pwd.h), which contains the following fields:-
10477  *      struct passwd {
10478  *              char        *pw_name;    Username (in lower case)
10479  *              char        *pw_passwd;  Hashed password
10480  *              unsigned int pw_uid;     UIC
10481  *              unsigned int pw_gid;     UIC group  number
10482  *              char        *pw_unixdir; Default device/directory (VMS-style)
10483  *              char        *pw_gecos;   Owner name
10484  *              char        *pw_dir;     Default device/directory (Unix-style)
10485  *              char        *pw_shell;   Default CLI name (eg. DCL)
10486  *      };
10487  * If the specified user does not exist, getpwuid and getpwnam return NULL.
10488  *
10489  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10490  * not the UIC member number (eg. what's returned by getuid()),
10491  * getpwuid() can accept either as input (if uid is specified, the caller's
10492  * UIC group is used), though it won't recognise gid=0.
10493  *
10494  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10495  * information about other users in your group or in other groups, respectively.
10496  * If the required privilege is not available, then these routines fill only
10497  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10498  * string).
10499  *
10500  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10501  */
10502
10503 /* sizes of various UAF record fields */
10504 #define UAI$S_USERNAME 12
10505 #define UAI$S_IDENT    31
10506 #define UAI$S_OWNER    31
10507 #define UAI$S_DEFDEV   31
10508 #define UAI$S_DEFDIR   63
10509 #define UAI$S_DEFCLI   31
10510 #define UAI$S_PWD       8
10511
10512 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
10513                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10514                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
10515
10516 static char __empty[]= "";
10517 static struct passwd __passwd_empty=
10518     {(char *) __empty, (char *) __empty, 0, 0,
10519      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10520 static int contxt= 0;
10521 static struct passwd __pwdcache;
10522 static char __pw_namecache[UAI$S_IDENT+1];
10523
10524 /*
10525  * This routine does most of the work extracting the user information.
10526  */
10527 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
10528 {
10529     static struct {
10530         unsigned char length;
10531         char pw_gecos[UAI$S_OWNER+1];
10532     } owner;
10533     static union uicdef uic;
10534     static struct {
10535         unsigned char length;
10536         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
10537     } defdev;
10538     static struct {
10539         unsigned char length;
10540         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
10541     } defdir;
10542     static struct {
10543         unsigned char length;
10544         char pw_shell[UAI$S_DEFCLI+1];
10545     } defcli;
10546     static char pw_passwd[UAI$S_PWD+1];
10547
10548     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
10549     struct dsc$descriptor_s name_desc;
10550     unsigned long int sts;
10551
10552     static struct itmlst_3 itmlst[]= {
10553         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
10554         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
10555         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
10556         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
10557         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
10558         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
10559         {0,                0,           NULL,    NULL}};
10560
10561     name_desc.dsc$w_length=  strlen(name);
10562     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10563     name_desc.dsc$b_class=   DSC$K_CLASS_S;
10564     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
10565
10566 /*  Note that sys$getuai returns many fields as counted strings. */
10567     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
10568     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
10569       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
10570     }
10571     else { _ckvmssts(sts); }
10572     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
10573
10574     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
10575     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
10576     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
10577     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
10578     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
10579     owner.pw_gecos[lowner]=            '\0';
10580     defdev.pw_dir[ldefdev+ldefdir]= '\0';
10581     defcli.pw_shell[ldefcli]=          '\0';
10582     if (valid_uic(uic)) {
10583         pwd->pw_uid= uic.uic$l_uic;
10584         pwd->pw_gid= uic.uic$v_group;
10585     }
10586     else
10587       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
10588     pwd->pw_passwd=  pw_passwd;
10589     pwd->pw_gecos=   owner.pw_gecos;
10590     pwd->pw_dir=     defdev.pw_dir;
10591     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
10592     pwd->pw_shell=   defcli.pw_shell;
10593     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
10594         int ldir;
10595         ldir= strlen(pwd->pw_unixdir) - 1;
10596         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
10597     }
10598     else
10599         strcpy(pwd->pw_unixdir, pwd->pw_dir);
10600     if (!decc_efs_case_preserve)
10601         __mystrtolower(pwd->pw_unixdir);
10602     return 1;
10603 }
10604
10605 /*
10606  * Get information for a named user.
10607 */
10608 /*{{{struct passwd *getpwnam(char *name)*/
10609 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
10610 {
10611     struct dsc$descriptor_s name_desc;
10612     union uicdef uic;
10613     unsigned long int status, sts;
10614
10615     __pwdcache = __passwd_empty;
10616     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
10617       /* We still may be able to determine pw_uid and pw_gid */
10618       name_desc.dsc$w_length=  strlen(name);
10619       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10620       name_desc.dsc$b_class=   DSC$K_CLASS_S;
10621       name_desc.dsc$a_pointer= (char *) name;
10622       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
10623         __pwdcache.pw_uid= uic.uic$l_uic;
10624         __pwdcache.pw_gid= uic.uic$v_group;
10625       }
10626       else {
10627         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
10628           set_vaxc_errno(sts);
10629           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
10630           return NULL;
10631         }
10632         else { _ckvmssts(sts); }
10633       }
10634     }
10635     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
10636     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
10637     __pwdcache.pw_name= __pw_namecache;
10638     return &__pwdcache;
10639 }  /* end of my_getpwnam() */
10640 /*}}}*/
10641
10642 /*
10643  * Get information for a particular UIC or UID.
10644  * Called by my_getpwent with uid=-1 to list all users.
10645 */
10646 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
10647 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
10648 {
10649     const $DESCRIPTOR(name_desc,__pw_namecache);
10650     unsigned short lname;
10651     union uicdef uic;
10652     unsigned long int status;
10653
10654     if (uid == (unsigned int) -1) {
10655       do {
10656         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
10657         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
10658           set_vaxc_errno(status);
10659           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10660           my_endpwent();
10661           return NULL;
10662         }
10663         else { _ckvmssts(status); }
10664       } while (!valid_uic (uic));
10665     }
10666     else {
10667       uic.uic$l_uic= uid;
10668       if (!uic.uic$v_group)
10669         uic.uic$v_group= PerlProc_getgid();
10670       if (valid_uic(uic))
10671         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
10672       else status = SS$_IVIDENT;
10673       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
10674           status == RMS$_PRV) {
10675         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10676         return NULL;
10677       }
10678       else { _ckvmssts(status); }
10679     }
10680     __pw_namecache[lname]= '\0';
10681     __mystrtolower(__pw_namecache);
10682
10683     __pwdcache = __passwd_empty;
10684     __pwdcache.pw_name = __pw_namecache;
10685
10686 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10687     The identifier's value is usually the UIC, but it doesn't have to be,
10688     so if we can, we let fillpasswd update this. */
10689     __pwdcache.pw_uid =  uic.uic$l_uic;
10690     __pwdcache.pw_gid =  uic.uic$v_group;
10691
10692     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10693     return &__pwdcache;
10694
10695 }  /* end of my_getpwuid() */
10696 /*}}}*/
10697
10698 /*
10699  * Get information for next user.
10700 */
10701 /*{{{struct passwd *my_getpwent()*/
10702 struct passwd *Perl_my_getpwent(pTHX)
10703 {
10704     return (my_getpwuid((unsigned int) -1));
10705 }
10706 /*}}}*/
10707
10708 /*
10709  * Finish searching rights database for users.
10710 */
10711 /*{{{void my_endpwent()*/
10712 void Perl_my_endpwent(pTHX)
10713 {
10714     if (contxt) {
10715       _ckvmssts(sys$finish_rdb(&contxt));
10716       contxt= 0;
10717     }
10718 }
10719 /*}}}*/
10720
10721 #ifdef HOMEGROWN_POSIX_SIGNALS
10722   /* Signal handling routines, pulled into the core from POSIX.xs.
10723    *
10724    * We need these for threads, so they've been rolled into the core,
10725    * rather than left in POSIX.xs.
10726    *
10727    * (DRS, Oct 23, 1997)
10728    */
10729
10730   /* sigset_t is atomic under VMS, so these routines are easy */
10731 /*{{{int my_sigemptyset(sigset_t *) */
10732 int my_sigemptyset(sigset_t *set) {
10733     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10734     *set = 0; return 0;
10735 }
10736 /*}}}*/
10737
10738
10739 /*{{{int my_sigfillset(sigset_t *)*/
10740 int my_sigfillset(sigset_t *set) {
10741     int i;
10742     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10743     for (i = 0; i < NSIG; i++) *set |= (1 << i);
10744     return 0;
10745 }
10746 /*}}}*/
10747
10748
10749 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10750 int my_sigaddset(sigset_t *set, int sig) {
10751     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10752     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10753     *set |= (1 << (sig - 1));
10754     return 0;
10755 }
10756 /*}}}*/
10757
10758
10759 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10760 int my_sigdelset(sigset_t *set, int sig) {
10761     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10762     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10763     *set &= ~(1 << (sig - 1));
10764     return 0;
10765 }
10766 /*}}}*/
10767
10768
10769 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10770 int my_sigismember(sigset_t *set, int sig) {
10771     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10772     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10773     return *set & (1 << (sig - 1));
10774 }
10775 /*}}}*/
10776
10777
10778 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10779 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10780     sigset_t tempmask;
10781
10782     /* If set and oset are both null, then things are badly wrong. Bail out. */
10783     if ((oset == NULL) && (set == NULL)) {
10784       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10785       return -1;
10786     }
10787
10788     /* If set's null, then we're just handling a fetch. */
10789     if (set == NULL) {
10790         tempmask = sigblock(0);
10791     }
10792     else {
10793       switch (how) {
10794       case SIG_SETMASK:
10795         tempmask = sigsetmask(*set);
10796         break;
10797       case SIG_BLOCK:
10798         tempmask = sigblock(*set);
10799         break;
10800       case SIG_UNBLOCK:
10801         tempmask = sigblock(0);
10802         sigsetmask(*oset & ~tempmask);
10803         break;
10804       default:
10805         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10806         return -1;
10807       }
10808     }
10809
10810     /* Did they pass us an oset? If so, stick our holding mask into it */
10811     if (oset)
10812       *oset = tempmask;
10813
10814     return 0;
10815 }
10816 /*}}}*/
10817 #endif  /* HOMEGROWN_POSIX_SIGNALS */
10818
10819
10820 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10821  * my_utime(), and flex_stat(), all of which operate on UTC unless
10822  * VMSISH_TIMES is true.
10823  */
10824 /* method used to handle UTC conversions:
10825  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
10826  */
10827 static int gmtime_emulation_type;
10828 /* number of secs to add to UTC POSIX-style time to get local time */
10829 static long int utc_offset_secs;
10830
10831 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10832  * in vmsish.h.  #undef them here so we can call the CRTL routines
10833  * directly.
10834  */
10835 #undef gmtime
10836 #undef localtime
10837 #undef time
10838
10839
10840 /*
10841  * DEC C previous to 6.0 corrupts the behavior of the /prefix
10842  * qualifier with the extern prefix pragma.  This provisional
10843  * hack circumvents this prefix pragma problem in previous
10844  * precompilers.
10845  */
10846 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10847 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10848 #    pragma __extern_prefix save
10849 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
10850 #    define gmtime decc$__utctz_gmtime
10851 #    define localtime decc$__utctz_localtime
10852 #    define time decc$__utc_time
10853 #    pragma __extern_prefix restore
10854
10855      struct tm *gmtime(), *localtime();
10856
10857 #  endif
10858 #endif
10859
10860
10861 static time_t toutc_dst(time_t loc) {
10862   struct tm *rsltmp;
10863
10864   if ((rsltmp = localtime(&loc)) == NULL) return -1;
10865   loc -= utc_offset_secs;
10866   if (rsltmp->tm_isdst) loc -= 3600;
10867   return loc;
10868 }
10869 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10870        ((gmtime_emulation_type || my_time(NULL)), \
10871        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10872        ((secs) - utc_offset_secs))))
10873
10874 static time_t toloc_dst(time_t utc) {
10875   struct tm *rsltmp;
10876
10877   utc += utc_offset_secs;
10878   if ((rsltmp = localtime(&utc)) == NULL) return -1;
10879   if (rsltmp->tm_isdst) utc += 3600;
10880   return utc;
10881 }
10882 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10883        ((gmtime_emulation_type || my_time(NULL)), \
10884        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10885        ((secs) + utc_offset_secs))))
10886
10887 #ifndef RTL_USES_UTC
10888 /*
10889
10890     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
10891         DST starts on 1st sun of april      at 02:00  std time
10892             ends on last sun of october     at 02:00  dst time
10893     see the UCX management command reference, SET CONFIG TIMEZONE
10894     for formatting info.
10895
10896     No, it's not as general as it should be, but then again, NOTHING
10897     will handle UK times in a sensible way.
10898 */
10899
10900
10901 /*
10902     parse the DST start/end info:
10903     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10904 */
10905
10906 static char *
10907 tz_parse_startend(char *s, struct tm *w, int *past)
10908 {
10909     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10910     int ly, dozjd, d, m, n, hour, min, sec, j, k;
10911     time_t g;
10912
10913     if (!s)    return 0;
10914     if (!w) return 0;
10915     if (!past) return 0;
10916
10917     ly = 0;
10918     if (w->tm_year % 4        == 0) ly = 1;
10919     if (w->tm_year % 100      == 0) ly = 0;
10920     if (w->tm_year+1900 % 400 == 0) ly = 1;
10921     if (ly) dinm[1]++;
10922
10923     dozjd = isdigit(*s);
10924     if (*s == 'J' || *s == 'j' || dozjd) {
10925         if (!dozjd && !isdigit(*++s)) return 0;
10926         d = *s++ - '0';
10927         if (isdigit(*s)) {
10928             d = d*10 + *s++ - '0';
10929             if (isdigit(*s)) {
10930                 d = d*10 + *s++ - '0';
10931             }
10932         }
10933         if (d == 0) return 0;
10934         if (d > 366) return 0;
10935         d--;
10936         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
10937         g = d * 86400;
10938         dozjd = 1;
10939     } else if (*s == 'M' || *s == 'm') {
10940         if (!isdigit(*++s)) return 0;
10941         m = *s++ - '0';
10942         if (isdigit(*s)) m = 10*m + *s++ - '0';
10943         if (*s != '.') return 0;
10944         if (!isdigit(*++s)) return 0;
10945         n = *s++ - '0';
10946         if (n < 1 || n > 5) return 0;
10947         if (*s != '.') return 0;
10948         if (!isdigit(*++s)) return 0;
10949         d = *s++ - '0';
10950         if (d > 6) return 0;
10951     }
10952
10953     if (*s == '/') {
10954         if (!isdigit(*++s)) return 0;
10955         hour = *s++ - '0';
10956         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10957         if (*s == ':') {
10958             if (!isdigit(*++s)) return 0;
10959             min = *s++ - '0';
10960             if (isdigit(*s)) min = 10*min + *s++ - '0';
10961             if (*s == ':') {
10962                 if (!isdigit(*++s)) return 0;
10963                 sec = *s++ - '0';
10964                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10965             }
10966         }
10967     } else {
10968         hour = 2;
10969         min = 0;
10970         sec = 0;
10971     }
10972
10973     if (dozjd) {
10974         if (w->tm_yday < d) goto before;
10975         if (w->tm_yday > d) goto after;
10976     } else {
10977         if (w->tm_mon+1 < m) goto before;
10978         if (w->tm_mon+1 > m) goto after;
10979
10980         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
10981         k = d - j; /* mday of first d */
10982         if (k <= 0) k += 7;
10983         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
10984         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10985         if (w->tm_mday < k) goto before;
10986         if (w->tm_mday > k) goto after;
10987     }
10988
10989     if (w->tm_hour < hour) goto before;
10990     if (w->tm_hour > hour) goto after;
10991     if (w->tm_min  < min)  goto before;
10992     if (w->tm_min  > min)  goto after;
10993     if (w->tm_sec  < sec)  goto before;
10994     goto after;
10995
10996 before:
10997     *past = 0;
10998     return s;
10999 after:
11000     *past = 1;
11001     return s;
11002 }
11003
11004
11005
11006
11007 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
11008
11009 static char *
11010 tz_parse_offset(char *s, int *offset)
11011 {
11012     int hour = 0, min = 0, sec = 0;
11013     int neg = 0;
11014     if (!s) return 0;
11015     if (!offset) return 0;
11016
11017     if (*s == '-') {neg++; s++;}
11018     if (*s == '+') s++;
11019     if (!isdigit(*s)) return 0;
11020     hour = *s++ - '0';
11021     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11022     if (hour > 24) return 0;
11023     if (*s == ':') {
11024         if (!isdigit(*++s)) return 0;
11025         min = *s++ - '0';
11026         if (isdigit(*s)) min = min*10 + (*s++ - '0');
11027         if (min > 59) return 0;
11028         if (*s == ':') {
11029             if (!isdigit(*++s)) return 0;
11030             sec = *s++ - '0';
11031             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11032             if (sec > 59) return 0;
11033         }
11034     }
11035
11036     *offset = (hour*60+min)*60 + sec;
11037     if (neg) *offset = -*offset;
11038     return s;
11039 }
11040
11041 /*
11042     input time is w, whatever type of time the CRTL localtime() uses.
11043     sets dst, the zone, and the gmtoff (seconds)
11044
11045     caches the value of TZ and UCX$TZ env variables; note that
11046     my_setenv looks for these and sets a flag if they're changed
11047     for efficiency.
11048
11049     We have to watch out for the "australian" case (dst starts in
11050     october, ends in april)...flagged by "reverse" and checked by
11051     scanning through the months of the previous year.
11052
11053 */
11054
11055 static int
11056 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11057 {
11058     time_t when;
11059     struct tm *w2;
11060     char *s,*s2;
11061     char *dstzone, *tz, *s_start, *s_end;
11062     int std_off, dst_off, isdst;
11063     int y, dststart, dstend;
11064     static char envtz[1025];  /* longer than any logical, symbol, ... */
11065     static char ucxtz[1025];
11066     static char reversed = 0;
11067
11068     if (!w) return 0;
11069
11070     if (tz_updated) {
11071         tz_updated = 0;
11072         reversed = -1;  /* flag need to check  */
11073         envtz[0] = ucxtz[0] = '\0';
11074         tz = my_getenv("TZ",0);
11075         if (tz) strcpy(envtz, tz);
11076         tz = my_getenv("UCX$TZ",0);
11077         if (tz) strcpy(ucxtz, tz);
11078         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
11079     }
11080     tz = envtz;
11081     if (!*tz) tz = ucxtz;
11082
11083     s = tz;
11084     while (isalpha(*s)) s++;
11085     s = tz_parse_offset(s, &std_off);
11086     if (!s) return 0;
11087     if (!*s) {                  /* no DST, hurray we're done! */
11088         isdst = 0;
11089         goto done;
11090     }
11091
11092     dstzone = s;
11093     while (isalpha(*s)) s++;
11094     s2 = tz_parse_offset(s, &dst_off);
11095     if (s2) {
11096         s = s2;
11097     } else {
11098         dst_off = std_off - 3600;
11099     }
11100
11101     if (!*s) {      /* default dst start/end?? */
11102         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
11103             s = strchr(ucxtz,',');
11104         }
11105         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
11106     }
11107     if (*s != ',') return 0;
11108
11109     when = *w;
11110     when = _toutc(when);      /* convert to utc */
11111     when = when - std_off;    /* convert to pseudolocal time*/
11112
11113     w2 = localtime(&when);
11114     y = w2->tm_year;
11115     s_start = s+1;
11116     s = tz_parse_startend(s_start,w2,&dststart);
11117     if (!s) return 0;
11118     if (*s != ',') return 0;
11119
11120     when = *w;
11121     when = _toutc(when);      /* convert to utc */
11122     when = when - dst_off;    /* convert to pseudolocal time*/
11123     w2 = localtime(&when);
11124     if (w2->tm_year != y) {   /* spans a year, just check one time */
11125         when += dst_off - std_off;
11126         w2 = localtime(&when);
11127     }
11128     s_end = s+1;
11129     s = tz_parse_startend(s_end,w2,&dstend);
11130     if (!s) return 0;
11131
11132     if (reversed == -1) {  /* need to check if start later than end */
11133         int j, ds, de;
11134
11135         when = *w;
11136         if (when < 2*365*86400) {
11137             when += 2*365*86400;
11138         } else {
11139             when -= 365*86400;
11140         }
11141         w2 =localtime(&when);
11142         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
11143
11144         for (j = 0; j < 12; j++) {
11145             w2 =localtime(&when);
11146             tz_parse_startend(s_start,w2,&ds);
11147             tz_parse_startend(s_end,w2,&de);
11148             if (ds != de) break;
11149             when += 30*86400;
11150         }
11151         reversed = 0;
11152         if (de && !ds) reversed = 1;
11153     }
11154
11155     isdst = dststart && !dstend;
11156     if (reversed) isdst = dststart  || !dstend;
11157
11158 done:
11159     if (dst)    *dst = isdst;
11160     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11161     if (isdst)  tz = dstzone;
11162     if (zone) {
11163         while(isalpha(*tz))  *zone++ = *tz++;
11164         *zone = '\0';
11165     }
11166     return 1;
11167 }
11168
11169 #endif /* !RTL_USES_UTC */
11170
11171 /* my_time(), my_localtime(), my_gmtime()
11172  * By default traffic in UTC time values, using CRTL gmtime() or
11173  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11174  * Note: We need to use these functions even when the CRTL has working
11175  * UTC support, since they also handle C<use vmsish qw(times);>
11176  *
11177  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11178  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11179  */
11180
11181 /*{{{time_t my_time(time_t *timep)*/
11182 time_t Perl_my_time(pTHX_ time_t *timep)
11183 {
11184   time_t when;
11185   struct tm *tm_p;
11186
11187   if (gmtime_emulation_type == 0) {
11188     int dstnow;
11189     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11190                               /* results of calls to gmtime() and localtime() */
11191                               /* for same &base */
11192
11193     gmtime_emulation_type++;
11194     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11195       char off[LNM$C_NAMLENGTH+1];;
11196
11197       gmtime_emulation_type++;
11198       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11199         gmtime_emulation_type++;
11200         utc_offset_secs = 0;
11201         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11202       }
11203       else { utc_offset_secs = atol(off); }
11204     }
11205     else { /* We've got a working gmtime() */
11206       struct tm gmt, local;
11207
11208       gmt = *tm_p;
11209       tm_p = localtime(&base);
11210       local = *tm_p;
11211       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11212       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11213       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11214       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11215     }
11216   }
11217
11218   when = time(NULL);
11219 # ifdef VMSISH_TIME
11220 # ifdef RTL_USES_UTC
11221   if (VMSISH_TIME) when = _toloc(when);
11222 # else
11223   if (!VMSISH_TIME) when = _toutc(when);
11224 # endif
11225 # endif
11226   if (timep != NULL) *timep = when;
11227   return when;
11228
11229 }  /* end of my_time() */
11230 /*}}}*/
11231
11232
11233 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11234 struct tm *
11235 Perl_my_gmtime(pTHX_ const time_t *timep)
11236 {
11237   char *p;
11238   time_t when;
11239   struct tm *rsltmp;
11240
11241   if (timep == NULL) {
11242     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11243     return NULL;
11244   }
11245   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11246
11247   when = *timep;
11248 # ifdef VMSISH_TIME
11249   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11250 #  endif
11251 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
11252   return gmtime(&when);
11253 # else
11254   /* CRTL localtime() wants local time as input, so does no tz correction */
11255   rsltmp = localtime(&when);
11256   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
11257   return rsltmp;
11258 #endif
11259 }  /* end of my_gmtime() */
11260 /*}}}*/
11261
11262
11263 /*{{{struct tm *my_localtime(const time_t *timep)*/
11264 struct tm *
11265 Perl_my_localtime(pTHX_ const time_t *timep)
11266 {
11267   time_t when, whenutc;
11268   struct tm *rsltmp;
11269   int dst, offset;
11270
11271   if (timep == NULL) {
11272     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11273     return NULL;
11274   }
11275   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11276   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11277
11278   when = *timep;
11279 # ifdef RTL_USES_UTC
11280 # ifdef VMSISH_TIME
11281   if (VMSISH_TIME) when = _toutc(when);
11282 # endif
11283   /* CRTL localtime() wants UTC as input, does tz correction itself */
11284   return localtime(&when);
11285
11286 # else /* !RTL_USES_UTC */
11287   whenutc = when;
11288 # ifdef VMSISH_TIME
11289   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
11290   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
11291 # endif
11292   dst = -1;
11293 #ifndef RTL_USES_UTC
11294   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
11295       when = whenutc - offset;                   /* pseudolocal time*/
11296   }
11297 # endif
11298   /* CRTL localtime() wants local time as input, so does no tz correction */
11299   rsltmp = localtime(&when);
11300   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11301   return rsltmp;
11302 # endif
11303
11304 } /*  end of my_localtime() */
11305 /*}}}*/
11306
11307 /* Reset definitions for later calls */
11308 #define gmtime(t)    my_gmtime(t)
11309 #define localtime(t) my_localtime(t)
11310 #define time(t)      my_time(t)
11311
11312
11313 /* my_utime - update modification/access time of a file
11314  *
11315  * VMS 7.3 and later implementation
11316  * Only the UTC translation is home-grown. The rest is handled by the
11317  * CRTL utime(), which will take into account the relevant feature
11318  * logicals and ODS-5 volume characteristics for true access times.
11319  *
11320  * pre VMS 7.3 implementation:
11321  * The calling sequence is identical to POSIX utime(), but under
11322  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11323  * not maintain access times.  Restrictions differ from the POSIX
11324  * definition in that the time can be changed as long as the
11325  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11326  * no separate checks are made to insure that the caller is the
11327  * owner of the file or has special privs enabled.
11328  * Code here is based on Joe Meadows' FILE utility.
11329  *
11330  */
11331
11332 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11333  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11334  * in 100 ns intervals.
11335  */
11336 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11337
11338 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11339 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11340 {
11341 #if __CRTL_VER >= 70300000
11342   struct utimbuf utc_utimes, *utc_utimesp;
11343
11344   if (utimes != NULL) {
11345     utc_utimes.actime = utimes->actime;
11346     utc_utimes.modtime = utimes->modtime;
11347 # ifdef VMSISH_TIME
11348     /* If input was local; convert to UTC for sys svc */
11349     if (VMSISH_TIME) {
11350       utc_utimes.actime = _toutc(utimes->actime);
11351       utc_utimes.modtime = _toutc(utimes->modtime);
11352     }
11353 # endif
11354     utc_utimesp = &utc_utimes;
11355   }
11356   else {
11357     utc_utimesp = NULL;
11358   }
11359
11360   return utime(file, utc_utimesp);
11361
11362 #else /* __CRTL_VER < 70300000 */
11363
11364   register int i;
11365   int sts;
11366   long int bintime[2], len = 2, lowbit, unixtime,
11367            secscale = 10000000; /* seconds --> 100 ns intervals */
11368   unsigned long int chan, iosb[2], retsts;
11369   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11370   struct FAB myfab = cc$rms_fab;
11371   struct NAM mynam = cc$rms_nam;
11372 #if defined (__DECC) && defined (__VAX)
11373   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11374    * at least through VMS V6.1, which causes a type-conversion warning.
11375    */
11376 #  pragma message save
11377 #  pragma message disable cvtdiftypes
11378 #endif
11379   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11380   struct fibdef myfib;
11381 #if defined (__DECC) && defined (__VAX)
11382   /* This should be right after the declaration of myatr, but due
11383    * to a bug in VAX DEC C, this takes effect a statement early.
11384    */
11385 #  pragma message restore
11386 #endif
11387   /* cast ok for read only parameter */
11388   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11389                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11390                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11391
11392   if (file == NULL || *file == '\0') {
11393     SETERRNO(ENOENT, LIB$_INVARG);
11394     return -1;
11395   }
11396
11397   /* Convert to VMS format ensuring that it will fit in 255 characters */
11398   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
11399       SETERRNO(ENOENT, LIB$_INVARG);
11400       return -1;
11401   }
11402   if (utimes != NULL) {
11403     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11404      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11405      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11406      * as input, we force the sign bit to be clear by shifting unixtime right
11407      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11408      */
11409     lowbit = (utimes->modtime & 1) ? secscale : 0;
11410     unixtime = (long int) utimes->modtime;
11411 #   ifdef VMSISH_TIME
11412     /* If input was UTC; convert to local for sys svc */
11413     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11414 #   endif
11415     unixtime >>= 1;  secscale <<= 1;
11416     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11417     if (!(retsts & 1)) {
11418       SETERRNO(EVMSERR, retsts);
11419       return -1;
11420     }
11421     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11422     if (!(retsts & 1)) {
11423       SETERRNO(EVMSERR, retsts);
11424       return -1;
11425     }
11426   }
11427   else {
11428     /* Just get the current time in VMS format directly */
11429     retsts = sys$gettim(bintime);
11430     if (!(retsts & 1)) {
11431       SETERRNO(EVMSERR, retsts);
11432       return -1;
11433     }
11434   }
11435
11436   myfab.fab$l_fna = vmsspec;
11437   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11438   myfab.fab$l_nam = &mynam;
11439   mynam.nam$l_esa = esa;
11440   mynam.nam$b_ess = (unsigned char) sizeof esa;
11441   mynam.nam$l_rsa = rsa;
11442   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11443   if (decc_efs_case_preserve)
11444       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11445
11446   /* Look for the file to be affected, letting RMS parse the file
11447    * specification for us as well.  I have set errno using only
11448    * values documented in the utime() man page for VMS POSIX.
11449    */
11450   retsts = sys$parse(&myfab,0,0);
11451   if (!(retsts & 1)) {
11452     set_vaxc_errno(retsts);
11453     if      (retsts == RMS$_PRV) set_errno(EACCES);
11454     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11455     else                         set_errno(EVMSERR);
11456     return -1;
11457   }
11458   retsts = sys$search(&myfab,0,0);
11459   if (!(retsts & 1)) {
11460     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11461     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11462     set_vaxc_errno(retsts);
11463     if      (retsts == RMS$_PRV) set_errno(EACCES);
11464     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11465     else                         set_errno(EVMSERR);
11466     return -1;
11467   }
11468
11469   devdsc.dsc$w_length = mynam.nam$b_dev;
11470   /* cast ok for read only parameter */
11471   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11472
11473   retsts = sys$assign(&devdsc,&chan,0,0);
11474   if (!(retsts & 1)) {
11475     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11476     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11477     set_vaxc_errno(retsts);
11478     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11479     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11480     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11481     else                               set_errno(EVMSERR);
11482     return -1;
11483   }
11484
11485   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11486   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11487
11488   memset((void *) &myfib, 0, sizeof myfib);
11489 #if defined(__DECC) || defined(__DECCXX)
11490   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11491   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11492   /* This prevents the revision time of the file being reset to the current
11493    * time as a result of our IO$_MODIFY $QIO. */
11494   myfib.fib$l_acctl = FIB$M_NORECORD;
11495 #else
11496   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11497   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11498   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11499 #endif
11500   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11501   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11502   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11503   _ckvmssts(sys$dassgn(chan));
11504   if (retsts & 1) retsts = iosb[0];
11505   if (!(retsts & 1)) {
11506     set_vaxc_errno(retsts);
11507     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11508     else                      set_errno(EVMSERR);
11509     return -1;
11510   }
11511
11512   return 0;
11513
11514 #endif /* #if __CRTL_VER >= 70300000 */
11515
11516 }  /* end of my_utime() */
11517 /*}}}*/
11518
11519 /*
11520  * flex_stat, flex_lstat, flex_fstat
11521  * basic stat, but gets it right when asked to stat
11522  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11523  */
11524
11525 #ifndef _USE_STD_STAT
11526 /* encode_dev packs a VMS device name string into an integer to allow
11527  * simple comparisons. This can be used, for example, to check whether two
11528  * files are located on the same device, by comparing their encoded device
11529  * names. Even a string comparison would not do, because stat() reuses the
11530  * device name buffer for each call; so without encode_dev, it would be
11531  * necessary to save the buffer and use strcmp (this would mean a number of
11532  * changes to the standard Perl code, to say nothing of what a Perl script
11533  * would have to do.
11534  *
11535  * The device lock id, if it exists, should be unique (unless perhaps compared
11536  * with lock ids transferred from other nodes). We have a lock id if the disk is
11537  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11538  * device names. Thus we use the lock id in preference, and only if that isn't
11539  * available, do we try to pack the device name into an integer (flagged by
11540  * the sign bit (LOCKID_MASK) being set).
11541  *
11542  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11543  * name and its encoded form, but it seems very unlikely that we will find
11544  * two files on different disks that share the same encoded device names,
11545  * and even more remote that they will share the same file id (if the test
11546  * is to check for the same file).
11547  *
11548  * A better method might be to use sys$device_scan on the first call, and to
11549  * search for the device, returning an index into the cached array.
11550  * The number returned would be more intelligible.
11551  * This is probably not worth it, and anyway would take quite a bit longer
11552  * on the first call.
11553  */
11554 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11555 static mydev_t encode_dev (pTHX_ const char *dev)
11556 {
11557   int i;
11558   unsigned long int f;
11559   mydev_t enc;
11560   char c;
11561   const char *q;
11562
11563   if (!dev || !dev[0]) return 0;
11564
11565 #if LOCKID_MASK
11566   {
11567     struct dsc$descriptor_s dev_desc;
11568     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11569
11570     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11571        can try that first. */
11572     dev_desc.dsc$w_length =  strlen (dev);
11573     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11574     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11575     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11576     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11577     if (!$VMS_STATUS_SUCCESS(status)) {
11578       switch (status) {
11579         case SS$_NOSUCHDEV:
11580           SETERRNO(ENODEV, status);
11581           return 0;
11582         default:
11583           _ckvmssts(status);
11584       }
11585     }
11586     if (lockid) return (lockid & ~LOCKID_MASK);
11587   }
11588 #endif
11589
11590   /* Otherwise we try to encode the device name */
11591   enc = 0;
11592   f = 1;
11593   i = 0;
11594   for (q = dev + strlen(dev); q--; q >= dev) {
11595     if (*q == ':')
11596         break;
11597     if (isdigit (*q))
11598       c= (*q) - '0';
11599     else if (isalpha (toupper (*q)))
11600       c= toupper (*q) - 'A' + (char)10;
11601     else
11602       continue; /* Skip '$'s */
11603     i++;
11604     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11605     if (i>1) f *= 36;
11606     enc += f * (unsigned long int) c;
11607   }
11608   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11609
11610 }  /* end of encode_dev() */
11611 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11612         device_no = encode_dev(aTHX_ devname)
11613 #else
11614 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11615         device_no = new_dev_no
11616 #endif
11617
11618 static int
11619 is_null_device(name)
11620     const char *name;
11621 {
11622   if (decc_bug_devnull != 0) {
11623     if (strncmp("/dev/null", name, 9) == 0)
11624       return 1;
11625   }
11626     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11627        The underscore prefix, controller letter, and unit number are
11628        independently optional; for our purposes, the colon punctuation
11629        is not.  The colon can be trailed by optional directory and/or
11630        filename, but two consecutive colons indicates a nodename rather
11631        than a device.  [pr]  */
11632   if (*name == '_') ++name;
11633   if (tolower(*name++) != 'n') return 0;
11634   if (tolower(*name++) != 'l') return 0;
11635   if (tolower(*name) == 'a') ++name;
11636   if (*name == '0') ++name;
11637   return (*name++ == ':') && (*name != ':');
11638 }
11639
11640
11641 static I32
11642 Perl_cando_by_name_int
11643    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11644 {
11645   char usrname[L_cuserid];
11646   struct dsc$descriptor_s usrdsc =
11647          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11648   char *vmsname = NULL, *fileified = NULL;
11649   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11650   unsigned short int retlen, trnlnm_iter_count;
11651   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11652   union prvdef curprv;
11653   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11654          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11655          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11656   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11657          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11658          {0,0,0,0}};
11659   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11660          {0,0,0,0}};
11661   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11662   Stat_t st;
11663   static int profile_context = -1;
11664
11665   if (!fname || !*fname) return FALSE;
11666
11667   /* Make sure we expand logical names, since sys$check_access doesn't */
11668   fileified = PerlMem_malloc(VMS_MAXRSS);
11669   if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
11670   if (!strpbrk(fname,"/]>:")) {
11671       strcpy(fileified,fname);
11672       trnlnm_iter_count = 0;
11673       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11674         trnlnm_iter_count++;
11675         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11676       }
11677       fname = fileified;
11678   }
11679
11680   vmsname = PerlMem_malloc(VMS_MAXRSS);
11681   if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11682   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11683     /* Don't know if already in VMS format, so make sure */
11684     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11685       PerlMem_free(fileified);
11686       PerlMem_free(vmsname);
11687       return FALSE;
11688     }
11689   }
11690   else {
11691     strcpy(vmsname,fname);
11692   }
11693
11694   /* sys$check_access needs a file spec, not a directory spec.
11695    * Don't use flex_stat here, as that depends on thread context
11696    * having been initialized, and we may get here during startup.
11697    */
11698
11699   retlen = namdsc.dsc$w_length = strlen(vmsname);
11700   if (vmsname[retlen-1] == ']'
11701       || vmsname[retlen-1] == '>'
11702       || vmsname[retlen-1] == ':'
11703       || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11704
11705       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11706         PerlMem_free(fileified);
11707         PerlMem_free(vmsname);
11708         return FALSE;
11709       }
11710       fname = fileified;
11711   }
11712   else {
11713       fname = vmsname;
11714   }
11715
11716   retlen = namdsc.dsc$w_length = strlen(fname);
11717   namdsc.dsc$a_pointer = (char *)fname;
11718
11719   switch (bit) {
11720     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11721       access = ARM$M_EXECUTE;
11722       flags = CHP$M_READ;
11723       break;
11724     case S_IRUSR: case S_IRGRP: case S_IROTH:
11725       access = ARM$M_READ;
11726       flags = CHP$M_READ | CHP$M_USEREADALL;
11727       break;
11728     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11729       access = ARM$M_WRITE;
11730       flags = CHP$M_READ | CHP$M_WRITE;
11731       break;
11732     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11733       access = ARM$M_DELETE;
11734       flags = CHP$M_READ | CHP$M_WRITE;
11735       break;
11736     default:
11737       if (fileified != NULL)
11738         PerlMem_free(fileified);
11739       if (vmsname != NULL)
11740         PerlMem_free(vmsname);
11741       return FALSE;
11742   }
11743
11744   /* Before we call $check_access, create a user profile with the current
11745    * process privs since otherwise it just uses the default privs from the
11746    * UAF and might give false positives or negatives.  This only works on
11747    * VMS versions v6.0 and later since that's when sys$create_user_profile
11748    * became available.
11749    */
11750
11751   /* get current process privs and username */
11752   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11753   _ckvmssts(iosb[0]);
11754
11755 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11756
11757   /* find out the space required for the profile */
11758   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11759                                     &usrprodsc.dsc$w_length,&profile_context));
11760
11761   /* allocate space for the profile and get it filled in */
11762   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11763   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11764   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11765                                     &usrprodsc.dsc$w_length,&profile_context));
11766
11767   /* use the profile to check access to the file; free profile & analyze results */
11768   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11769   PerlMem_free(usrprodsc.dsc$a_pointer);
11770   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11771
11772 #else
11773
11774   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11775
11776 #endif
11777
11778   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11779       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11780       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11781     set_vaxc_errno(retsts);
11782     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11783     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11784     else set_errno(ENOENT);
11785     if (fileified != NULL)
11786       PerlMem_free(fileified);
11787     if (vmsname != NULL)
11788       PerlMem_free(vmsname);
11789     return FALSE;
11790   }
11791   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11792     if (fileified != NULL)
11793       PerlMem_free(fileified);
11794     if (vmsname != NULL)
11795       PerlMem_free(vmsname);
11796     return TRUE;
11797   }
11798   _ckvmssts(retsts);
11799
11800   if (fileified != NULL)
11801     PerlMem_free(fileified);
11802   if (vmsname != NULL)
11803     PerlMem_free(vmsname);
11804   return FALSE;  /* Should never get here */
11805
11806 }
11807
11808 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
11809 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11810  * subset of the applicable information.
11811  */
11812 bool
11813 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11814 {
11815   return cando_by_name_int
11816         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11817 }  /* end of cando() */
11818 /*}}}*/
11819
11820
11821 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11822 I32
11823 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11824 {
11825    return cando_by_name_int(bit, effective, fname, 0);
11826
11827 }  /* end of cando_by_name() */
11828 /*}}}*/
11829
11830
11831 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11832 int
11833 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11834 {
11835   if (!fstat(fd,(stat_t *) statbufp)) {
11836     char *cptr;
11837     char *vms_filename;
11838     vms_filename = PerlMem_malloc(VMS_MAXRSS);
11839     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11840
11841     /* Save name for cando by name in VMS format */
11842     cptr = getname(fd, vms_filename, 1);
11843
11844     /* This should not happen, but just in case */
11845     if (cptr == NULL) {
11846         statbufp->st_devnam[0] = 0;
11847     }
11848     else {
11849         /* Make sure that the saved name fits in 255 characters */
11850         cptr = do_rmsexpand
11851                        (vms_filename,
11852                         statbufp->st_devnam,
11853                         0,
11854                         NULL,
11855                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11856                         NULL,
11857                         NULL);
11858         if (cptr == NULL)
11859             statbufp->st_devnam[0] = 0;
11860     }
11861     PerlMem_free(vms_filename);
11862
11863     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11864     VMS_DEVICE_ENCODE
11865         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11866
11867 #   ifdef RTL_USES_UTC
11868 #   ifdef VMSISH_TIME
11869     if (VMSISH_TIME) {
11870       statbufp->st_mtime = _toloc(statbufp->st_mtime);
11871       statbufp->st_atime = _toloc(statbufp->st_atime);
11872       statbufp->st_ctime = _toloc(statbufp->st_ctime);
11873     }
11874 #   endif
11875 #   else
11876 #   ifdef VMSISH_TIME
11877     if (!VMSISH_TIME) { /* Return UTC instead of local time */
11878 #   else
11879     if (1) {
11880 #   endif
11881       statbufp->st_mtime = _toutc(statbufp->st_mtime);
11882       statbufp->st_atime = _toutc(statbufp->st_atime);
11883       statbufp->st_ctime = _toutc(statbufp->st_ctime);
11884     }
11885 #endif
11886     return 0;
11887   }
11888   return -1;
11889
11890 }  /* end of flex_fstat() */
11891 /*}}}*/
11892
11893 #if !defined(__VAX) && __CRTL_VER >= 80200000
11894 #ifdef lstat
11895 #undef lstat
11896 #endif
11897 #else
11898 #ifdef lstat
11899 #undef lstat
11900 #endif
11901 #define lstat(_x, _y) stat(_x, _y)
11902 #endif
11903
11904 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11905
11906 static int
11907 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11908 {
11909     char fileified[VMS_MAXRSS];
11910     char temp_fspec[VMS_MAXRSS];
11911     char *save_spec;
11912     int retval = -1;
11913     int saved_errno, saved_vaxc_errno;
11914
11915     if (!fspec) return retval;
11916     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11917     strcpy(temp_fspec, fspec);
11918
11919     if (decc_bug_devnull != 0) {
11920       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11921         memset(statbufp,0,sizeof *statbufp);
11922         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11923         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11924         statbufp->st_uid = 0x00010001;
11925         statbufp->st_gid = 0x0001;
11926         time((time_t *)&statbufp->st_mtime);
11927         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11928         return 0;
11929       }
11930     }
11931
11932     /* Try for a directory name first.  If fspec contains a filename without
11933      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11934      * and sea:[wine.dark]water. exist, we prefer the directory here.
11935      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11936      * not sea:[wine.dark]., if the latter exists.  If the intended target is
11937      * the file with null type, specify this by calling flex_stat() with
11938      * a '.' at the end of fspec.
11939      *
11940      * If we are in Posix filespec mode, accept the filename as is.
11941      */
11942
11943
11944 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11945   /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11946    * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11947    */
11948   if (!decc_efs_charset)
11949     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11950 #endif
11951
11952 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11953   if (decc_posix_compliant_pathnames == 0) {
11954 #endif
11955     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11956       if (lstat_flag == 0)
11957         retval = stat(fileified,(stat_t *) statbufp);
11958       else
11959         retval = lstat(fileified,(stat_t *) statbufp);
11960       save_spec = fileified;
11961     }
11962     if (retval) {
11963       if (lstat_flag == 0)
11964         retval = stat(temp_fspec,(stat_t *) statbufp);
11965       else
11966         retval = lstat(temp_fspec,(stat_t *) statbufp);
11967       save_spec = temp_fspec;
11968     }
11969 /*
11970  * In debugging, on 8.3 Alpha, I found a case where stat was returning a
11971  * file not found error for a directory named foo:[bar.t] or /foo/bar/t
11972  * and lstat was working correctly for the same file.
11973  * The only syntax that was working for stat was "foo:[bar]t.dir".
11974  *
11975  * Other directories with the same syntax worked fine.
11976  * So work around the problem when it shows up here.
11977  */
11978     if (retval) {
11979         int save_errno = errno;
11980         if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
11981             if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
11982                 retval = stat(fileified, (stat_t *) statbufp);
11983                 save_spec = fileified;
11984             }
11985         }
11986         /* Restore the errno value if third stat does not succeed */
11987         if (retval != 0)
11988             errno = save_errno;
11989     }
11990 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11991   } else {
11992     if (lstat_flag == 0)
11993       retval = stat(temp_fspec,(stat_t *) statbufp);
11994     else
11995       retval = lstat(temp_fspec,(stat_t *) statbufp);
11996       save_spec = temp_fspec;
11997   }
11998 #endif
11999
12000 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12001   /* As you were... */
12002   if (!decc_efs_charset)
12003     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12004 #endif
12005
12006     if (!retval) {
12007     char * cptr;
12008     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12009
12010       /* If this is an lstat, do not follow the link */
12011       if (lstat_flag)
12012         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12013
12014       cptr = do_rmsexpand
12015        (save_spec, statbufp->st_devnam, 0, NULL, rmsex_flags, NULL, NULL);
12016       if (cptr == NULL)
12017         statbufp->st_devnam[0] = 0;
12018
12019       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12020       VMS_DEVICE_ENCODE
12021         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12022 #     ifdef RTL_USES_UTC
12023 #     ifdef VMSISH_TIME
12024       if (VMSISH_TIME) {
12025         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12026         statbufp->st_atime = _toloc(statbufp->st_atime);
12027         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12028       }
12029 #     endif
12030 #     else
12031 #     ifdef VMSISH_TIME
12032       if (!VMSISH_TIME) { /* Return UTC instead of local time */
12033 #     else
12034       if (1) {
12035 #     endif
12036         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12037         statbufp->st_atime = _toutc(statbufp->st_atime);
12038         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12039       }
12040 #     endif
12041     }
12042     /* If we were successful, leave errno where we found it */
12043     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
12044     return retval;
12045
12046 }  /* end of flex_stat_int() */
12047
12048
12049 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12050 int
12051 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12052 {
12053    return flex_stat_int(fspec, statbufp, 0);
12054 }
12055 /*}}}*/
12056
12057 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12058 int
12059 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12060 {
12061    return flex_stat_int(fspec, statbufp, 1);
12062 }
12063 /*}}}*/
12064
12065
12066 /*{{{char *my_getlogin()*/
12067 /* VMS cuserid == Unix getlogin, except calling sequence */
12068 char *
12069 my_getlogin(void)
12070 {
12071     static char user[L_cuserid];
12072     return cuserid(user);
12073 }
12074 /*}}}*/
12075
12076
12077 /*  rmscopy - copy a file using VMS RMS routines
12078  *
12079  *  Copies contents and attributes of spec_in to spec_out, except owner
12080  *  and protection information.  Name and type of spec_in are used as
12081  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12082  *  should try to propagate timestamps from the input file to the output file.
12083  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12084  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12085  *  propagated to the output file at creation iff the output file specification
12086  *  did not contain an explicit name or type, and the revision date is always
12087  *  updated at the end of the copy operation.  If it is greater than 0, then
12088  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12089  *  other than the revision date should be propagated, and bit 1 indicates
12090  *  that the revision date should be propagated.
12091  *
12092  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12093  *
12094  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12095  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12096  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12097  * as part of the Perl standard distribution under the terms of the
12098  * GNU General Public License or the Perl Artistic License.  Copies
12099  * of each may be found in the Perl standard distribution.
12100  */ /* FIXME */
12101 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12102 int
12103 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12104 {
12105     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12106          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12107     unsigned long int i, sts, sts2;
12108     int dna_len;
12109     struct FAB fab_in, fab_out;
12110     struct RAB rab_in, rab_out;
12111     rms_setup_nam(nam);
12112     rms_setup_nam(nam_out);
12113     struct XABDAT xabdat;
12114     struct XABFHC xabfhc;
12115     struct XABRDT xabrdt;
12116     struct XABSUM xabsum;
12117
12118     vmsin = PerlMem_malloc(VMS_MAXRSS);
12119     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
12120     vmsout = PerlMem_malloc(VMS_MAXRSS);
12121     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
12122     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
12123         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
12124       PerlMem_free(vmsin);
12125       PerlMem_free(vmsout);
12126       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12127       return 0;
12128     }
12129
12130     esa = PerlMem_malloc(VMS_MAXRSS);
12131     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
12132     esal = NULL;
12133 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12134     esal = PerlMem_malloc(VMS_MAXRSS);
12135     if (esal == NULL) _ckvmssts(SS$_INSFMEM);
12136 #endif
12137     fab_in = cc$rms_fab;
12138     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12139     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12140     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12141     fab_in.fab$l_fop = FAB$M_SQO;
12142     rms_bind_fab_nam(fab_in, nam);
12143     fab_in.fab$l_xab = (void *) &xabdat;
12144
12145     rsa = PerlMem_malloc(VMS_MAXRSS);
12146     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
12147     rsal = NULL;
12148 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12149     rsal = PerlMem_malloc(VMS_MAXRSS);
12150     if (rsal == NULL) _ckvmssts(SS$_INSFMEM);
12151 #endif
12152     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12153     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12154     rms_nam_esl(nam) = 0;
12155     rms_nam_rsl(nam) = 0;
12156     rms_nam_esll(nam) = 0;
12157     rms_nam_rsll(nam) = 0;
12158 #ifdef NAM$M_NO_SHORT_UPCASE
12159     if (decc_efs_case_preserve)
12160         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12161 #endif
12162
12163     xabdat = cc$rms_xabdat;        /* To get creation date */
12164     xabdat.xab$l_nxt = (void *) &xabfhc;
12165
12166     xabfhc = cc$rms_xabfhc;        /* To get record length */
12167     xabfhc.xab$l_nxt = (void *) &xabsum;
12168
12169     xabsum = cc$rms_xabsum;        /* To get key and area information */
12170
12171     if (!((sts = sys$open(&fab_in)) & 1)) {
12172       PerlMem_free(vmsin);
12173       PerlMem_free(vmsout);
12174       PerlMem_free(esa);
12175       if (esal != NULL)
12176         PerlMem_free(esal);
12177       PerlMem_free(rsa);
12178       if (rsal != NULL)
12179         PerlMem_free(rsal);
12180       set_vaxc_errno(sts);
12181       switch (sts) {
12182         case RMS$_FNF: case RMS$_DNF:
12183           set_errno(ENOENT); break;
12184         case RMS$_DIR:
12185           set_errno(ENOTDIR); break;
12186         case RMS$_DEV:
12187           set_errno(ENODEV); break;
12188         case RMS$_SYN:
12189           set_errno(EINVAL); break;
12190         case RMS$_PRV:
12191           set_errno(EACCES); break;
12192         default:
12193           set_errno(EVMSERR);
12194       }
12195       return 0;
12196     }
12197
12198     nam_out = nam;
12199     fab_out = fab_in;
12200     fab_out.fab$w_ifi = 0;
12201     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12202     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12203     fab_out.fab$l_fop = FAB$M_SQO;
12204     rms_bind_fab_nam(fab_out, nam_out);
12205     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12206     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12207     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12208     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12209     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
12210     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12211     if (rsa_out == NULL) _ckvmssts(SS$_INSFMEM);
12212     esal_out = NULL;
12213     rsal_out = NULL;
12214 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12215     esal_out = PerlMem_malloc(VMS_MAXRSS);
12216     if (esal_out == NULL) _ckvmssts(SS$_INSFMEM);
12217     rsal_out = PerlMem_malloc(VMS_MAXRSS);
12218     if (rsal_out == NULL) _ckvmssts(SS$_INSFMEM);
12219 #endif
12220     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12221     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12222
12223     if (preserve_dates == 0) {  /* Act like DCL COPY */
12224       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12225       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12226       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12227         PerlMem_free(vmsin);
12228         PerlMem_free(vmsout);
12229         PerlMem_free(esa);
12230         if (esal != NULL)
12231             PerlMem_free(esal);
12232         PerlMem_free(rsa);
12233         if (rsal != NULL)
12234             PerlMem_free(rsal);
12235         PerlMem_free(esa_out);
12236         if (esal_out != NULL)
12237             PerlMem_free(esal_out);
12238         PerlMem_free(rsa_out);
12239         if (rsal_out != NULL)
12240             PerlMem_free(rsal_out);
12241         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12242         set_vaxc_errno(sts);
12243         return 0;
12244       }
12245       fab_out.fab$l_xab = (void *) &xabdat;
12246       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12247         preserve_dates = 1;
12248     }
12249     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12250       preserve_dates =0;      /* bitmask from this point forward   */
12251
12252     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12253     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12254       PerlMem_free(vmsin);
12255       PerlMem_free(vmsout);
12256       PerlMem_free(esa);
12257       if (esal != NULL)
12258           PerlMem_free(esal);
12259       PerlMem_free(rsa);
12260       if (rsal != NULL)
12261           PerlMem_free(rsal);
12262       PerlMem_free(esa_out);
12263       if (esal_out != NULL)
12264           PerlMem_free(esal_out);
12265       PerlMem_free(rsa_out);
12266       if (rsal_out != NULL)
12267           PerlMem_free(rsal_out);
12268       set_vaxc_errno(sts);
12269       switch (sts) {
12270         case RMS$_DNF:
12271           set_errno(ENOENT); break;
12272         case RMS$_DIR:
12273           set_errno(ENOTDIR); break;
12274         case RMS$_DEV:
12275           set_errno(ENODEV); break;
12276         case RMS$_SYN:
12277           set_errno(EINVAL); break;
12278         case RMS$_PRV:
12279           set_errno(EACCES); break;
12280         default:
12281           set_errno(EVMSERR);
12282       }
12283       return 0;
12284     }
12285     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12286     if (preserve_dates & 2) {
12287       /* sys$close() will process xabrdt, not xabdat */
12288       xabrdt = cc$rms_xabrdt;
12289 #ifndef __GNUC__
12290       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12291 #else
12292       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12293        * is unsigned long[2], while DECC & VAXC use a struct */
12294       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12295 #endif
12296       fab_out.fab$l_xab = (void *) &xabrdt;
12297     }
12298
12299     ubf = PerlMem_malloc(32256);
12300     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
12301     rab_in = cc$rms_rab;
12302     rab_in.rab$l_fab = &fab_in;
12303     rab_in.rab$l_rop = RAB$M_BIO;
12304     rab_in.rab$l_ubf = ubf;
12305     rab_in.rab$w_usz = 32256;
12306     if (!((sts = sys$connect(&rab_in)) & 1)) {
12307       sys$close(&fab_in); sys$close(&fab_out);
12308       PerlMem_free(vmsin);
12309       PerlMem_free(vmsout);
12310       PerlMem_free(ubf);
12311       PerlMem_free(esa);
12312       if (esal != NULL)
12313           PerlMem_free(esal);
12314       PerlMem_free(rsa);
12315       if (rsal != NULL)
12316           PerlMem_free(rsal);
12317       PerlMem_free(esa_out);
12318       if (esal_out != NULL)
12319           PerlMem_free(esal_out);
12320       PerlMem_free(rsa_out);
12321       if (rsal_out != NULL)
12322           PerlMem_free(rsal_out);
12323       set_errno(EVMSERR); set_vaxc_errno(sts);
12324       return 0;
12325     }
12326
12327     rab_out = cc$rms_rab;
12328     rab_out.rab$l_fab = &fab_out;
12329     rab_out.rab$l_rbf = ubf;
12330     if (!((sts = sys$connect(&rab_out)) & 1)) {
12331       sys$close(&fab_in); sys$close(&fab_out);
12332       PerlMem_free(vmsin);
12333       PerlMem_free(vmsout);
12334       PerlMem_free(ubf);
12335       PerlMem_free(esa);
12336       if (esal != NULL)
12337           PerlMem_free(esal);
12338       PerlMem_free(rsa);
12339       if (rsal != NULL)
12340           PerlMem_free(rsal);
12341       PerlMem_free(esa_out);
12342       if (esal_out != NULL)
12343           PerlMem_free(esal_out);
12344       PerlMem_free(rsa_out);
12345       if (rsal_out != NULL)
12346           PerlMem_free(rsal_out);
12347       set_errno(EVMSERR); set_vaxc_errno(sts);
12348       return 0;
12349     }
12350
12351     while ((sts = sys$read(&rab_in))) {  /* always true  */
12352       if (sts == RMS$_EOF) break;
12353       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12354       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12355         sys$close(&fab_in); sys$close(&fab_out);
12356         PerlMem_free(vmsin);
12357         PerlMem_free(vmsout);
12358         PerlMem_free(ubf);
12359         PerlMem_free(esa);
12360         if (esal != NULL)
12361             PerlMem_free(esal);
12362         PerlMem_free(rsa);
12363         if (rsal != NULL)
12364             PerlMem_free(rsal);
12365         PerlMem_free(esa_out);
12366         if (esal_out != NULL)
12367             PerlMem_free(esal_out);
12368         PerlMem_free(rsa_out);
12369         if (rsal_out != NULL)
12370             PerlMem_free(rsal_out);
12371         set_errno(EVMSERR); set_vaxc_errno(sts);
12372         return 0;
12373       }
12374     }
12375
12376
12377     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12378     sys$close(&fab_in);  sys$close(&fab_out);
12379     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12380
12381     PerlMem_free(vmsin);
12382     PerlMem_free(vmsout);
12383     PerlMem_free(ubf);
12384     PerlMem_free(esa);
12385     if (esal != NULL)
12386         PerlMem_free(esal);
12387     PerlMem_free(rsa);
12388     if (rsal != NULL)
12389         PerlMem_free(rsal);
12390     PerlMem_free(esa_out);
12391     if (esal_out != NULL)
12392         PerlMem_free(esal_out);
12393     PerlMem_free(rsa_out);
12394     if (rsal_out != NULL)
12395         PerlMem_free(rsal_out);
12396
12397     if (!(sts & 1)) {
12398       set_errno(EVMSERR); set_vaxc_errno(sts);
12399       return 0;
12400     }
12401
12402     return 1;
12403
12404 }  /* end of rmscopy() */
12405 /*}}}*/
12406
12407
12408 /***  The following glue provides 'hooks' to make some of the routines
12409  * from this file available from Perl.  These routines are sufficiently
12410  * basic, and are required sufficiently early in the build process,
12411  * that's it's nice to have them available to miniperl as well as the
12412  * full Perl, so they're set up here instead of in an extension.  The
12413  * Perl code which handles importation of these names into a given
12414  * package lives in [.VMS]Filespec.pm in @INC.
12415  */
12416
12417 void
12418 rmsexpand_fromperl(pTHX_ CV *cv)
12419 {
12420   dXSARGS;
12421   char *fspec, *defspec = NULL, *rslt;
12422   STRLEN n_a;
12423   int fs_utf8, dfs_utf8;
12424
12425   fs_utf8 = 0;
12426   dfs_utf8 = 0;
12427   if (!items || items > 2)
12428     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12429   fspec = SvPV(ST(0),n_a);
12430   fs_utf8 = SvUTF8(ST(0));
12431   if (!fspec || !*fspec) XSRETURN_UNDEF;
12432   if (items == 2) {
12433     defspec = SvPV(ST(1),n_a);
12434     dfs_utf8 = SvUTF8(ST(1));
12435   }
12436   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12437   ST(0) = sv_newmortal();
12438   if (rslt != NULL) {
12439     sv_usepvn(ST(0),rslt,strlen(rslt));
12440     if (fs_utf8) {
12441         SvUTF8_on(ST(0));
12442     }
12443   }
12444   XSRETURN(1);
12445 }
12446
12447 void
12448 vmsify_fromperl(pTHX_ CV *cv)
12449 {
12450   dXSARGS;
12451   char *vmsified;
12452   STRLEN n_a;
12453   int utf8_fl;
12454
12455   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12456   utf8_fl = SvUTF8(ST(0));
12457   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12458   ST(0) = sv_newmortal();
12459   if (vmsified != NULL) {
12460     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12461     if (utf8_fl) {
12462         SvUTF8_on(ST(0));
12463     }
12464   }
12465   XSRETURN(1);
12466 }
12467
12468 void
12469 unixify_fromperl(pTHX_ CV *cv)
12470 {
12471   dXSARGS;
12472   char *unixified;
12473   STRLEN n_a;
12474   int utf8_fl;
12475
12476   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12477   utf8_fl = SvUTF8(ST(0));
12478   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12479   ST(0) = sv_newmortal();
12480   if (unixified != NULL) {
12481     sv_usepvn(ST(0),unixified,strlen(unixified));
12482     if (utf8_fl) {
12483         SvUTF8_on(ST(0));
12484     }
12485   }
12486   XSRETURN(1);
12487 }
12488
12489 void
12490 fileify_fromperl(pTHX_ CV *cv)
12491 {
12492   dXSARGS;
12493   char *fileified;
12494   STRLEN n_a;
12495   int utf8_fl;
12496
12497   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12498   utf8_fl = SvUTF8(ST(0));
12499   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12500   ST(0) = sv_newmortal();
12501   if (fileified != NULL) {
12502     sv_usepvn(ST(0),fileified,strlen(fileified));
12503     if (utf8_fl) {
12504         SvUTF8_on(ST(0));
12505     }
12506   }
12507   XSRETURN(1);
12508 }
12509
12510 void
12511 pathify_fromperl(pTHX_ CV *cv)
12512 {
12513   dXSARGS;
12514   char *pathified;
12515   STRLEN n_a;
12516   int utf8_fl;
12517
12518   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12519   utf8_fl = SvUTF8(ST(0));
12520   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12521   ST(0) = sv_newmortal();
12522   if (pathified != NULL) {
12523     sv_usepvn(ST(0),pathified,strlen(pathified));
12524     if (utf8_fl) {
12525         SvUTF8_on(ST(0));
12526     }
12527   }
12528   XSRETURN(1);
12529 }
12530
12531 void
12532 vmspath_fromperl(pTHX_ CV *cv)
12533 {
12534   dXSARGS;
12535   char *vmspath;
12536   STRLEN n_a;
12537   int utf8_fl;
12538
12539   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12540   utf8_fl = SvUTF8(ST(0));
12541   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12542   ST(0) = sv_newmortal();
12543   if (vmspath != NULL) {
12544     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12545     if (utf8_fl) {
12546         SvUTF8_on(ST(0));
12547     }
12548   }
12549   XSRETURN(1);
12550 }
12551
12552 void
12553 unixpath_fromperl(pTHX_ CV *cv)
12554 {
12555   dXSARGS;
12556   char *unixpath;
12557   STRLEN n_a;
12558   int utf8_fl;
12559
12560   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12561   utf8_fl = SvUTF8(ST(0));
12562   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12563   ST(0) = sv_newmortal();
12564   if (unixpath != NULL) {
12565     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12566     if (utf8_fl) {
12567         SvUTF8_on(ST(0));
12568     }
12569   }
12570   XSRETURN(1);
12571 }
12572
12573 void
12574 candelete_fromperl(pTHX_ CV *cv)
12575 {
12576   dXSARGS;
12577   char *fspec, *fsp;
12578   SV *mysv;
12579   IO *io;
12580   STRLEN n_a;
12581
12582   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12583
12584   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12585   Newx(fspec, VMS_MAXRSS, char);
12586   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12587   if (SvTYPE(mysv) == SVt_PVGV) {
12588     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12589       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12590       ST(0) = &PL_sv_no;
12591       Safefree(fspec);
12592       XSRETURN(1);
12593     }
12594     fsp = fspec;
12595   }
12596   else {
12597     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12598       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12599       ST(0) = &PL_sv_no;
12600       Safefree(fspec);
12601       XSRETURN(1);
12602     }
12603   }
12604
12605   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12606   Safefree(fspec);
12607   XSRETURN(1);
12608 }
12609
12610 void
12611 rmscopy_fromperl(pTHX_ CV *cv)
12612 {
12613   dXSARGS;
12614   char *inspec, *outspec, *inp, *outp;
12615   int date_flag;
12616   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
12617                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12618   unsigned long int sts;
12619   SV *mysv;
12620   IO *io;
12621   STRLEN n_a;
12622
12623   if (items < 2 || items > 3)
12624     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12625
12626   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12627   Newx(inspec, VMS_MAXRSS, char);
12628   if (SvTYPE(mysv) == SVt_PVGV) {
12629     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12630       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12631       ST(0) = &PL_sv_no;
12632       Safefree(inspec);
12633       XSRETURN(1);
12634     }
12635     inp = inspec;
12636   }
12637   else {
12638     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12639       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12640       ST(0) = &PL_sv_no;
12641       Safefree(inspec);
12642       XSRETURN(1);
12643     }
12644   }
12645   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12646   Newx(outspec, VMS_MAXRSS, char);
12647   if (SvTYPE(mysv) == SVt_PVGV) {
12648     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12649       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12650       ST(0) = &PL_sv_no;
12651       Safefree(inspec);
12652       Safefree(outspec);
12653       XSRETURN(1);
12654     }
12655     outp = outspec;
12656   }
12657   else {
12658     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12659       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12660       ST(0) = &PL_sv_no;
12661       Safefree(inspec);
12662       Safefree(outspec);
12663       XSRETURN(1);
12664     }
12665   }
12666   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12667
12668   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
12669   Safefree(inspec);
12670   Safefree(outspec);
12671   XSRETURN(1);
12672 }
12673
12674 /* The mod2fname is limited to shorter filenames by design, so it should
12675  * not be modified to support longer EFS pathnames
12676  */
12677 void
12678 mod2fname(pTHX_ CV *cv)
12679 {
12680   dXSARGS;
12681   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12682        workbuff[NAM$C_MAXRSS*1 + 1];
12683   int total_namelen = 3, counter, num_entries;
12684   /* ODS-5 ups this, but we want to be consistent, so... */
12685   int max_name_len = 39;
12686   AV *in_array = (AV *)SvRV(ST(0));
12687
12688   num_entries = av_len(in_array);
12689
12690   /* All the names start with PL_. */
12691   strcpy(ultimate_name, "PL_");
12692
12693   /* Clean up our working buffer */
12694   Zero(work_name, sizeof(work_name), char);
12695
12696   /* Run through the entries and build up a working name */
12697   for(counter = 0; counter <= num_entries; counter++) {
12698     /* If it's not the first name then tack on a __ */
12699     if (counter) {
12700       strcat(work_name, "__");
12701     }
12702     strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
12703   }
12704
12705   /* Check to see if we actually have to bother...*/
12706   if (strlen(work_name) + 3 <= max_name_len) {
12707     strcat(ultimate_name, work_name);
12708   } else {
12709     /* It's too darned big, so we need to go strip. We use the same */
12710     /* algorithm as xsubpp does. First, strip out doubled __ */
12711     char *source, *dest, last;
12712     dest = workbuff;
12713     last = 0;
12714     for (source = work_name; *source; source++) {
12715       if (last == *source && last == '_') {
12716         continue;
12717       }
12718       *dest++ = *source;
12719       last = *source;
12720     }
12721     /* Go put it back */
12722     strcpy(work_name, workbuff);
12723     /* Is it still too big? */
12724     if (strlen(work_name) + 3 > max_name_len) {
12725       /* Strip duplicate letters */
12726       last = 0;
12727       dest = workbuff;
12728       for (source = work_name; *source; source++) {
12729         if (last == toupper(*source)) {
12730         continue;
12731         }
12732         *dest++ = *source;
12733         last = toupper(*source);
12734       }
12735       strcpy(work_name, workbuff);
12736     }
12737
12738     /* Is it *still* too big? */
12739     if (strlen(work_name) + 3 > max_name_len) {
12740       /* Too bad, we truncate */
12741       work_name[max_name_len - 2] = 0;
12742     }
12743     strcat(ultimate_name, work_name);
12744   }
12745
12746   /* Okay, return it */
12747   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12748   XSRETURN(1);
12749 }
12750
12751 void
12752 hushexit_fromperl(pTHX_ CV *cv)
12753 {
12754     dXSARGS;
12755
12756     if (items > 0) {
12757         VMSISH_HUSHED = SvTRUE(ST(0));
12758     }
12759     ST(0) = boolSV(VMSISH_HUSHED);
12760     XSRETURN(1);
12761 }
12762
12763
12764 PerlIO *
12765 Perl_vms_start_glob
12766    (pTHX_ SV *tmpglob,
12767     IO *io)
12768 {
12769     PerlIO *fp;
12770     struct vs_str_st *rslt;
12771     char *vmsspec;
12772     char *rstr;
12773     char *begin, *cp;
12774     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12775     PerlIO *tmpfp;
12776     STRLEN i;
12777     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12778     struct dsc$descriptor_vs rsdsc;
12779     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12780     unsigned long hasver = 0, isunix = 0;
12781     unsigned long int lff_flags = 0;
12782     int rms_sts;
12783
12784     if (!SvOK(tmpglob)) {
12785         SETERRNO(ENOENT,RMS$_FNF);
12786         return NULL;
12787     }
12788
12789 #ifdef VMS_LONGNAME_SUPPORT
12790     lff_flags = LIB$M_FIL_LONG_NAMES;
12791 #endif
12792     /* The Newx macro will not allow me to assign a smaller array
12793      * to the rslt pointer, so we will assign it to the begin char pointer
12794      * and then copy the value into the rslt pointer.
12795      */
12796     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12797     rslt = (struct vs_str_st *)begin;
12798     rslt->length = 0;
12799     rstr = &rslt->str[0];
12800     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12801     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12802     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12803     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12804
12805     Newx(vmsspec, VMS_MAXRSS, char);
12806
12807         /* We could find out if there's an explicit dev/dir or version
12808            by peeking into lib$find_file's internal context at
12809            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12810            but that's unsupported, so I don't want to do it now and
12811            have it bite someone in the future. */
12812         /* Fix-me: vms_split_path() is the only way to do this, the
12813            existing method will fail with many legal EFS or UNIX specifications
12814          */
12815
12816     cp = SvPV(tmpglob,i);
12817
12818     for (; i; i--) {
12819         if (cp[i] == ';') hasver = 1;
12820         if (cp[i] == '.') {
12821             if (sts) hasver = 1;
12822             else sts = 1;
12823         }
12824         if (cp[i] == '/') {
12825             hasdir = isunix = 1;
12826             break;
12827         }
12828         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12829             hasdir = 1;
12830             break;
12831         }
12832     }
12833     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12834         int found = 0;
12835         Stat_t st;
12836         int stat_sts;
12837         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12838         if (!stat_sts && S_ISDIR(st.st_mode)) {
12839             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12840             ok = (wilddsc.dsc$a_pointer != NULL);
12841             /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12842             hasdir = 1;
12843         }
12844         else {
12845             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12846             ok = (wilddsc.dsc$a_pointer != NULL);
12847         }
12848         if (ok)
12849             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12850
12851         /* If not extended character set, replace ? with % */
12852         /* With extended character set, ? is a wildcard single character */
12853         if (!decc_efs_case_preserve) {
12854             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12855                 if (*cp == '?') *cp = '%';
12856         }
12857         sts = SS$_NORMAL;
12858         while (ok && $VMS_STATUS_SUCCESS(sts)) {
12859          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12860          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12861
12862             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12863                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
12864             if (!$VMS_STATUS_SUCCESS(sts))
12865                 break;
12866
12867             found++;
12868
12869             /* with varying string, 1st word of buffer contains result length */
12870             rstr[rslt->length] = '\0';
12871
12872              /* Find where all the components are */
12873              v_sts = vms_split_path
12874                        (rstr,
12875                         &v_spec,
12876                         &v_len,
12877                         &r_spec,
12878                         &r_len,
12879                         &d_spec,
12880                         &d_len,
12881                         &n_spec,
12882                         &n_len,
12883                         &e_spec,
12884                         &e_len,
12885                         &vs_spec,
12886                         &vs_len);
12887
12888             /* If no version on input, truncate the version on output */
12889             if (!hasver && (vs_len > 0)) {
12890                 *vs_spec = '\0';
12891                 vs_len = 0;
12892
12893                 /* No version & a null extension on UNIX handling */
12894                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12895                     e_len = 0;
12896                     *e_spec = '\0';
12897                 }
12898             }
12899
12900             if (!decc_efs_case_preserve) {
12901                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12902             }
12903
12904             if (hasdir) {
12905                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12906                 begin = rstr;
12907             }
12908             else {
12909                 /* Start with the name */
12910                 begin = n_spec;
12911             }
12912             strcat(begin,"\n");
12913             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12914         }
12915         if (cxt) (void)lib$find_file_end(&cxt);
12916
12917         if (!found) {
12918             /* Be POSIXish: return the input pattern when no matches */
12919             strcpy(rstr,SvPVX(tmpglob));
12920             strcat(rstr,"\n");
12921             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
12922         }
12923
12924         if (ok && sts != RMS$_NMF &&
12925             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12926         if (!ok) {
12927             if (!(sts & 1)) {
12928                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12929             }
12930             PerlIO_close(tmpfp);
12931             fp = NULL;
12932         }
12933         else {
12934             PerlIO_rewind(tmpfp);
12935             IoTYPE(io) = IoTYPE_RDONLY;
12936             IoIFP(io) = fp = tmpfp;
12937             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
12938         }
12939     }
12940     Safefree(vmsspec);
12941     Safefree(rslt);
12942     return fp;
12943 }
12944
12945
12946 static char *
12947 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
12948                    int *utf8_fl);
12949
12950 void
12951 unixrealpath_fromperl(pTHX_ CV *cv)
12952 {
12953     dXSARGS;
12954     char *fspec, *rslt_spec, *rslt;
12955     STRLEN n_a;
12956
12957     if (!items || items != 1)
12958         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
12959
12960     fspec = SvPV(ST(0),n_a);
12961     if (!fspec || !*fspec) XSRETURN_UNDEF;
12962
12963     Newx(rslt_spec, VMS_MAXRSS + 1, char);
12964     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12965
12966     ST(0) = sv_newmortal();
12967     if (rslt != NULL)
12968         sv_usepvn(ST(0),rslt,strlen(rslt));
12969     else
12970         Safefree(rslt_spec);
12971         XSRETURN(1);
12972 }
12973
12974 static char *
12975 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
12976                    int *utf8_fl);
12977
12978 void
12979 vmsrealpath_fromperl(pTHX_ CV *cv)
12980 {
12981     dXSARGS;
12982     char *fspec, *rslt_spec, *rslt;
12983     STRLEN n_a;
12984
12985     if (!items || items != 1)
12986         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
12987
12988     fspec = SvPV(ST(0),n_a);
12989     if (!fspec || !*fspec) XSRETURN_UNDEF;
12990
12991     Newx(rslt_spec, VMS_MAXRSS + 1, char);
12992     rslt = do_vms_realname(fspec, rslt_spec, NULL);
12993
12994     ST(0) = sv_newmortal();
12995     if (rslt != NULL)
12996         sv_usepvn(ST(0),rslt,strlen(rslt));
12997     else
12998         Safefree(rslt_spec);
12999         XSRETURN(1);
13000 }
13001
13002 #ifdef HAS_SYMLINK
13003 /*
13004  * A thin wrapper around decc$symlink to make sure we follow the
13005  * standard and do not create a symlink with a zero-length name.
13006  *
13007  * Also in ODS-2 mode, existing tests assume that the link target
13008  * will be converted to UNIX format.
13009  */
13010 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13011 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
13012   if (!link_name || !*link_name) {
13013     SETERRNO(ENOENT, SS$_NOSUCHFILE);
13014     return -1;
13015   }
13016
13017   if (decc_efs_charset) {
13018       return symlink(contents, link_name);
13019   } else {
13020       int sts;
13021       char * utarget;
13022
13023       /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
13024       /* because in order to work, the symlink target must be in UNIX format */
13025
13026       /* As symbolic links can hold things other than files, we will only do */
13027       /* the conversion in in ODS-2 mode */
13028
13029       Newx(utarget, VMS_MAXRSS + 1, char);
13030       if (do_tounixspec(contents, utarget, 0, NULL) == NULL) {
13031
13032           /* This should not fail, as an untranslatable filename */
13033           /* should be passed through */
13034           utarget = (char *)contents;
13035       }
13036       sts = symlink(utarget, link_name);
13037       Safefree(utarget);
13038       return sts;
13039   }
13040
13041 }
13042 /*}}}*/
13043
13044 #endif /* HAS_SYMLINK */
13045
13046 int do_vms_case_tolerant(void);
13047
13048 void
13049 case_tolerant_process_fromperl(pTHX_ CV *cv)
13050 {
13051   dXSARGS;
13052   ST(0) = boolSV(do_vms_case_tolerant());
13053   XSRETURN(1);
13054 }
13055
13056 #ifdef USE_ITHREADS
13057
13058 void
13059 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13060                           struct interp_intern *dst)
13061 {
13062     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13063
13064     memcpy(dst,src,sizeof(struct interp_intern));
13065 }
13066
13067 #endif
13068
13069 void
13070 Perl_sys_intern_clear(pTHX)
13071 {
13072 }
13073
13074 void
13075 Perl_sys_intern_init(pTHX)
13076 {
13077     unsigned int ix = RAND_MAX;
13078     double x;
13079
13080     VMSISH_HUSHED = 0;
13081
13082     /* fix me later to track running under GNV */
13083     /* this allows some limited testing */
13084     MY_POSIX_EXIT = decc_filename_unix_report;
13085
13086     x = (float)ix;
13087     MY_INV_RAND_MAX = 1./x;
13088 }
13089
13090 void
13091 init_os_extras(void)
13092 {
13093   dTHX;
13094   char* file = __FILE__;
13095   if (decc_disable_to_vms_logname_translation) {
13096     no_translate_barewords = TRUE;
13097   } else {
13098     no_translate_barewords = FALSE;
13099   }
13100
13101   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13102   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13103   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13104   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13105   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13106   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13107   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13108   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13109   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13110   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13111   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13112   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13113   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13114   newXSproto("VMS::Filespec::case_tolerant_process",
13115       case_tolerant_process_fromperl,file,"");
13116
13117   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13118
13119   return;
13120 }
13121
13122 #if __CRTL_VER == 80200000
13123 /* This missed getting in to the DECC SDK for 8.2 */
13124 char *realpath(const char *file_name, char * resolved_name, ...);
13125 #endif
13126
13127 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13128 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13129  * The perl fallback routine to provide realpath() is not as efficient
13130  * on OpenVMS.
13131  */
13132
13133 /* Hack, use old stat() as fastest way of getting ino_t and device */
13134 int decc$stat(const char *name, void * statbuf);
13135
13136
13137 /* Realpath is fragile.  In 8.3 it does not work if the feature
13138  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13139  * links are implemented in RMS, not the CRTL. It also can fail if the
13140  * user does not have read/execute access to some of the directories.
13141  * So in order for Do What I Mean mode to work, if realpath() fails,
13142  * fall back to looking up the filename by the device name and FID.
13143  */
13144
13145 int vms_fid_to_name(char * outname, int outlen, const char * name)
13146 {
13147 struct statbuf_t {
13148     char           * st_dev;
13149     unsigned short st_ino[3];
13150     unsigned short padw;
13151     unsigned long  padl[30];  /* plenty of room */
13152 } statbuf;
13153 int sts;
13154 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13155 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13156
13157     sts = decc$stat(name, &statbuf);
13158     if (sts == 0) {
13159
13160         dvidsc.dsc$a_pointer=statbuf.st_dev;
13161        dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13162
13163         specdsc.dsc$a_pointer = outname;
13164         specdsc.dsc$w_length = outlen-1;
13165
13166        sts = lib$fid_to_name
13167             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13168        if ($VMS_STATUS_SUCCESS(sts)) {
13169             outname[specdsc.dsc$w_length] = 0;
13170             return 0;
13171         }
13172     }
13173     return sts;
13174 }
13175
13176
13177
13178 static char *
13179 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13180                    int *utf8_fl)
13181 {
13182     char * rslt = NULL;
13183
13184 #ifdef HAS_SYMLINK
13185     if (decc_posix_compliant_pathnames > 0 ) {
13186         /* realpath currently only works if posix compliant pathnames are
13187          * enabled.  It may start working when they are not, but in that
13188          * case we still want the fallback behavior for backwards compatibility
13189          */
13190         rslt = realpath(filespec, outbuf);
13191     }
13192 #endif
13193
13194     if (rslt == NULL) {
13195         char * vms_spec;
13196         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13197         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13198         int file_len;
13199
13200         /* Fall back to fid_to_name */
13201
13202         Newx(vms_spec, VMS_MAXRSS + 1, char);
13203
13204         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
13205         if (sts == 0) {
13206
13207
13208             /* Now need to trim the version off */
13209             sts = vms_split_path
13210                   (vms_spec,
13211                    &v_spec,
13212                    &v_len,
13213                    &r_spec,
13214                    &r_len,
13215                    &d_spec,
13216                    &d_len,
13217                    &n_spec,
13218                    &n_len,
13219                    &e_spec,
13220                    &e_len,
13221                    &vs_spec,
13222                    &vs_len);
13223
13224
13225                 if (sts == 0) {
13226                     int haslower = 0;
13227                     const char *cp;
13228
13229                     /* Trim off the version */
13230                     int file_len = v_len + r_len + d_len + n_len + e_len;
13231                     vms_spec[file_len] = 0;
13232
13233                     /* The result is expected to be in UNIX format */
13234                     rslt = do_tounixspec(vms_spec, outbuf, 0, utf8_fl);
13235
13236                     /* Downcase if input had any lower case letters and
13237                      * case preservation is not in effect.
13238                      */
13239                     if (!decc_efs_case_preserve) {
13240                         for (cp = filespec; *cp; cp++)
13241                             if (islower(*cp)) { haslower = 1; break; }
13242
13243                         if (haslower) __mystrtolower(rslt);
13244                     }
13245                 }
13246         } else {
13247
13248             /* Now for some hacks to deal with backwards and forward */
13249             /* compatibilty */
13250             if (!decc_efs_charset) {
13251
13252                 /* 1. ODS-2 mode wants to do a syntax only translation */
13253                 rslt = do_rmsexpand(filespec, outbuf,
13254                                     0, NULL, 0, NULL, utf8_fl);
13255
13256             } else {
13257                 if (decc_filename_unix_report) {
13258                     char * dir_name;
13259                     char * vms_dir_name;
13260                     char * file_name;
13261
13262                     /* 2. ODS-5 / UNIX report mode should return a failure */
13263                     /*    if the parent directory also does not exist */
13264                     /*    Otherwise, get the real path for the parent */
13265                     /*    and add the child to it.
13266
13267                     /* basename / dirname only available for VMS 7.0+ */
13268                     /* So we may need to implement them as common routines */
13269
13270                     Newx(dir_name, VMS_MAXRSS + 1, char);
13271                     Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13272                     dir_name[0] = '\0';
13273                     file_name = NULL;
13274
13275                     /* First try a VMS parse */
13276                     sts = vms_split_path
13277                           (filespec,
13278                            &v_spec,
13279                            &v_len,
13280                            &r_spec,
13281                            &r_len,
13282                            &d_spec,
13283                            &d_len,
13284                            &n_spec,
13285                            &n_len,
13286                            &e_spec,
13287                            &e_len,
13288                            &vs_spec,
13289                            &vs_len);
13290
13291                     if (sts == 0) {
13292                         /* This is VMS */
13293
13294                         int dir_len = v_len + r_len + d_len + n_len;
13295                         if (dir_len > 0) {
13296                            strncpy(dir_name, filespec, dir_len);
13297                            dir_name[dir_len] = '\0';
13298                            file_name = (char *)&filespec[dir_len + 1];
13299                         }
13300                     } else {
13301                         /* This must be UNIX */
13302                         char * tchar;
13303
13304                         tchar = strrchr(filespec, '/');
13305
13306                         if (tchar != NULL) {
13307                             int dir_len = tchar - filespec;
13308                             strncpy(dir_name, filespec, dir_len);
13309                             dir_name[dir_len] = '\0';
13310                             file_name = (char *) &filespec[dir_len + 1];
13311                         }
13312                     }
13313
13314                     /* Dir name is defaulted */
13315                     if (dir_name[0] == 0) {
13316                         dir_name[0] = '.';
13317                         dir_name[1] = '\0';
13318                     }
13319
13320                     /* Need realpath for the directory */
13321                     sts = vms_fid_to_name(vms_dir_name,
13322                                           VMS_MAXRSS + 1,
13323                                           dir_name);
13324
13325                     if (sts == 0) {
13326                         /* Now need to pathify it.
13327                         char *tdir = do_pathify_dirspec(vms_dir_name,
13328                                                         outbuf, utf8_fl);
13329
13330                         /* And now add the original filespec to it */
13331                         if (file_name != NULL) {
13332                             strcat(outbuf, file_name);
13333                         }
13334                         return outbuf;
13335                     }
13336                     Safefree(vms_dir_name);
13337                     Safefree(dir_name);
13338                 }
13339             }
13340         }
13341         Safefree(vms_spec);
13342     }
13343     return rslt;
13344 }
13345
13346 static char *
13347 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13348                    int *utf8_fl)
13349 {
13350     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13351     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13352     int file_len;
13353
13354     /* Fall back to fid_to_name */
13355
13356     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
13357     if (sts != 0) {
13358         return NULL;
13359     }
13360     else {
13361
13362
13363         /* Now need to trim the version off */
13364         sts = vms_split_path
13365                   (outbuf,
13366                    &v_spec,
13367                    &v_len,
13368                    &r_spec,
13369                    &r_len,
13370                    &d_spec,
13371                    &d_len,
13372                    &n_spec,
13373                    &n_len,
13374                    &e_spec,
13375                    &e_len,
13376                    &vs_spec,
13377                    &vs_len);
13378
13379
13380         if (sts == 0) {
13381             int haslower = 0;
13382             const char *cp;
13383
13384             /* Trim off the version */
13385             int file_len = v_len + r_len + d_len + n_len + e_len;
13386             outbuf[file_len] = 0;
13387
13388             /* Downcase if input had any lower case letters and
13389              * case preservation is not in effect.
13390              */
13391             if (!decc_efs_case_preserve) {
13392                 for (cp = filespec; *cp; cp++)
13393                     if (islower(*cp)) { haslower = 1; break; }
13394
13395                 if (haslower) __mystrtolower(outbuf);
13396             }
13397         }
13398     }
13399     return outbuf;
13400 }
13401
13402
13403 /*}}}*/
13404 /* External entry points */
13405 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13406 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13407
13408 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13409 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13410
13411 /* case_tolerant */
13412
13413 /*{{{int do_vms_case_tolerant(void)*/
13414 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13415  * controlled by a process setting.
13416  */
13417 int do_vms_case_tolerant(void)
13418 {
13419     return vms_process_case_tolerant;
13420 }
13421 /*}}}*/
13422 /* External entry points */
13423 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13424 int Perl_vms_case_tolerant(void)
13425 { return do_vms_case_tolerant(); }
13426 #else
13427 int Perl_vms_case_tolerant(void)
13428 { return vms_process_case_tolerant; }
13429 #endif
13430
13431
13432  /* Start of DECC RTL Feature handling */
13433
13434 static int sys_trnlnm
13435    (const char * logname,
13436     char * value,
13437     int value_len)
13438 {
13439     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
13440     const unsigned long attr = LNM$M_CASE_BLIND;
13441     struct dsc$descriptor_s name_dsc;
13442     int status;
13443     unsigned short result;
13444     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
13445                                 {0, 0, 0, 0}};
13446
13447     name_dsc.dsc$w_length = strlen(logname);
13448     name_dsc.dsc$a_pointer = (char *)logname;
13449     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13450     name_dsc.dsc$b_class = DSC$K_CLASS_S;
13451
13452     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
13453
13454     if ($VMS_STATUS_SUCCESS(status)) {
13455
13456          /* Null terminate and return the string */
13457         /*--------------------------------------*/
13458         value[result] = 0;
13459     }
13460
13461     return status;
13462 }
13463
13464 static int sys_crelnm
13465    (const char * logname,
13466     const char * value)
13467 {
13468     int ret_val;
13469     const char * proc_table = "LNM$PROCESS_TABLE";
13470     struct dsc$descriptor_s proc_table_dsc;
13471     struct dsc$descriptor_s logname_dsc;
13472     struct itmlst_3 item_list[2];
13473
13474     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
13475     proc_table_dsc.dsc$w_length = strlen(proc_table);
13476     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13477     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
13478
13479     logname_dsc.dsc$a_pointer = (char *) logname;
13480     logname_dsc.dsc$w_length = strlen(logname);
13481     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13482     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
13483
13484     item_list[0].buflen = strlen(value);
13485     item_list[0].itmcode = LNM$_STRING;
13486     item_list[0].bufadr = (char *)value;
13487     item_list[0].retlen = NULL;
13488
13489     item_list[1].buflen = 0;
13490     item_list[1].itmcode = 0;
13491
13492     ret_val = sys$crelnm
13493                        (NULL,
13494                         (const struct dsc$descriptor_s *)&proc_table_dsc,
13495                         (const struct dsc$descriptor_s *)&logname_dsc,
13496                         NULL,
13497                         (const struct item_list_3 *) item_list);
13498
13499     return ret_val;
13500 }
13501
13502 /* C RTL Feature settings */
13503
13504 static int set_features
13505    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
13506     int (* cli_routine)(void),  /* Not documented */
13507     void *image_info)           /* Not documented */
13508 {
13509     int status;
13510     int s;
13511     int dflt;
13512     char* str;
13513     char val_str[10];
13514 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13515     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13516     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13517     unsigned long case_perm;
13518     unsigned long case_image;
13519 #endif
13520
13521     /* Allow an exception to bring Perl into the VMS debugger */
13522     vms_debug_on_exception = 0;
13523     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13524     if ($VMS_STATUS_SUCCESS(status)) {
13525        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13526          vms_debug_on_exception = 1;
13527        else
13528          vms_debug_on_exception = 0;
13529     }
13530
13531     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13532     vms_vtf7_filenames = 0;
13533     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13534     if ($VMS_STATUS_SUCCESS(status)) {
13535        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13536          vms_vtf7_filenames = 1;
13537        else
13538          vms_vtf7_filenames = 0;
13539     }
13540
13541
13542     /* unlink all versions on unlink() or rename() */
13543     vms_unlink_all_versions = 0;
13544     status = sys_trnlnm
13545         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13546     if ($VMS_STATUS_SUCCESS(status)) {
13547        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13548          vms_unlink_all_versions = 1;
13549        else
13550          vms_unlink_all_versions = 0;
13551     }
13552
13553     /* Dectect running under GNV Bash or other UNIX like shell */
13554 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13555     gnv_unix_shell = 0;
13556     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13557     if ($VMS_STATUS_SUCCESS(status)) {
13558        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13559          gnv_unix_shell = 1;
13560          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13561          set_feature_default("DECC$EFS_CHARSET", 1);
13562          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13563          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13564          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13565          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13566          vms_unlink_all_versions = 1;
13567        }
13568        else
13569          gnv_unix_shell = 0;
13570     }
13571 #endif
13572
13573     /* hacks to see if known bugs are still present for testing */
13574
13575     /* Readdir is returning filenames in VMS syntax always */
13576     decc_bug_readdir_efs1 = 1;
13577     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
13578     if ($VMS_STATUS_SUCCESS(status)) {
13579        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13580          decc_bug_readdir_efs1 = 1;
13581        else
13582          decc_bug_readdir_efs1 = 0;
13583     }
13584
13585     /* PCP mode requires creating /dev/null special device file */
13586     decc_bug_devnull = 0;
13587     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13588     if ($VMS_STATUS_SUCCESS(status)) {
13589        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13590           decc_bug_devnull = 1;
13591        else
13592           decc_bug_devnull = 0;
13593     }
13594
13595     /* fgetname returning a VMS name in UNIX mode */
13596     decc_bug_fgetname = 1;
13597     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
13598     if ($VMS_STATUS_SUCCESS(status)) {
13599       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13600         decc_bug_fgetname = 1;
13601       else
13602         decc_bug_fgetname = 0;
13603     }
13604
13605     /* UNIX directory names with no paths are broken in a lot of places */
13606     decc_dir_barename = 1;
13607     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13608     if ($VMS_STATUS_SUCCESS(status)) {
13609       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13610         decc_dir_barename = 1;
13611       else
13612         decc_dir_barename = 0;
13613     }
13614
13615 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13616     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13617     if (s >= 0) {
13618         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13619         if (decc_disable_to_vms_logname_translation < 0)
13620             decc_disable_to_vms_logname_translation = 0;
13621     }
13622
13623     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13624     if (s >= 0) {
13625         decc_efs_case_preserve = decc$feature_get_value(s, 1);
13626         if (decc_efs_case_preserve < 0)
13627             decc_efs_case_preserve = 0;
13628     }
13629
13630     s = decc$feature_get_index("DECC$EFS_CHARSET");
13631     if (s >= 0) {
13632         decc_efs_charset = decc$feature_get_value(s, 1);
13633         if (decc_efs_charset < 0)
13634             decc_efs_charset = 0;
13635     }
13636
13637     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13638     if (s >= 0) {
13639         decc_filename_unix_report = decc$feature_get_value(s, 1);
13640         if (decc_filename_unix_report > 0)
13641             decc_filename_unix_report = 1;
13642         else
13643             decc_filename_unix_report = 0;
13644     }
13645
13646     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
13647     if (s >= 0) {
13648         decc_filename_unix_only = decc$feature_get_value(s, 1);
13649         if (decc_filename_unix_only > 0) {
13650             decc_filename_unix_only = 1;
13651         }
13652         else {
13653             decc_filename_unix_only = 0;
13654         }
13655     }
13656
13657     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
13658     if (s >= 0) {
13659         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
13660         if (decc_filename_unix_no_version < 0)
13661             decc_filename_unix_no_version = 0;
13662     }
13663
13664     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
13665     if (s >= 0) {
13666         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
13667         if (decc_readdir_dropdotnotype < 0)
13668             decc_readdir_dropdotnotype = 0;
13669     }
13670
13671     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
13672     if ($VMS_STATUS_SUCCESS(status)) {
13673         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
13674         if (s >= 0) {
13675             dflt = decc$feature_get_value(s, 4);
13676             if (dflt > 0) {
13677                 decc_disable_posix_root = decc$feature_get_value(s, 1);
13678                 if (decc_disable_posix_root <= 0) {
13679                     decc$feature_set_value(s, 1, 1);
13680                     decc_disable_posix_root = 1;
13681                 }
13682             }
13683             else {
13684                 /* Traditionally Perl assumes this is off */
13685                 decc_disable_posix_root = 1;
13686                 decc$feature_set_value(s, 1, 1);
13687             }
13688         }
13689     }
13690
13691 #if __CRTL_VER >= 80200000
13692     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
13693     if (s >= 0) {
13694         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
13695         if (decc_posix_compliant_pathnames < 0)
13696             decc_posix_compliant_pathnames = 0;
13697         if (decc_posix_compliant_pathnames > 4)
13698             decc_posix_compliant_pathnames = 0;
13699     }
13700
13701 #endif
13702 #else
13703     status = sys_trnlnm
13704         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
13705     if ($VMS_STATUS_SUCCESS(status)) {
13706         val_str[0] = _toupper(val_str[0]);
13707         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13708            decc_disable_to_vms_logname_translation = 1;
13709         }
13710     }
13711
13712 #ifndef __VAX
13713     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
13714     if ($VMS_STATUS_SUCCESS(status)) {
13715         val_str[0] = _toupper(val_str[0]);
13716         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13717            decc_efs_case_preserve = 1;
13718         }
13719     }
13720 #endif
13721
13722     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
13723     if ($VMS_STATUS_SUCCESS(status)) {
13724         val_str[0] = _toupper(val_str[0]);
13725         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13726            decc_filename_unix_report = 1;
13727         }
13728     }
13729     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
13730     if ($VMS_STATUS_SUCCESS(status)) {
13731         val_str[0] = _toupper(val_str[0]);
13732         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13733            decc_filename_unix_only = 1;
13734            decc_filename_unix_report = 1;
13735         }
13736     }
13737     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
13738     if ($VMS_STATUS_SUCCESS(status)) {
13739         val_str[0] = _toupper(val_str[0]);
13740         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13741            decc_filename_unix_no_version = 1;
13742         }
13743     }
13744     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
13745     if ($VMS_STATUS_SUCCESS(status)) {
13746         val_str[0] = _toupper(val_str[0]);
13747         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13748            decc_readdir_dropdotnotype = 1;
13749         }
13750     }
13751 #endif
13752
13753 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
13754
13755      /* Report true case tolerance */
13756     /*----------------------------*/
13757     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
13758     if (!$VMS_STATUS_SUCCESS(status))
13759         case_perm = PPROP$K_CASE_BLIND;
13760     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
13761     if (!$VMS_STATUS_SUCCESS(status))
13762         case_image = PPROP$K_CASE_BLIND;
13763     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
13764         (case_image == PPROP$K_CASE_SENSITIVE))
13765         vms_process_case_tolerant = 0;
13766
13767 #endif
13768
13769
13770     /* CRTL can be initialized past this point, but not before. */
13771 /*    DECC$CRTL_INIT(); */
13772
13773     return SS$_NORMAL;
13774 }
13775
13776 #ifdef __DECC
13777 #pragma nostandard
13778 #pragma extern_model save
13779 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
13780         const __align (LONGWORD) int spare[8] = {0};
13781
13782 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
13783 #if __DECC_VER >= 60560002
13784 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
13785 #else
13786 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
13787 #endif
13788 #endif /* __DECC */
13789
13790 const long vms_cc_features = (const long)set_features;
13791
13792 /*
13793 ** Force a reference to LIB$INITIALIZE to ensure it
13794 ** exists in the image.
13795 */
13796 int lib$initialize(void);
13797 #ifdef __DECC
13798 #pragma extern_model strict_refdef
13799 #endif
13800     int lib_init_ref = (int) lib$initialize;
13801
13802 #ifdef __DECC
13803 #pragma extern_model restore
13804 #pragma standard
13805 #endif
13806
13807 /*  End of vms.c */