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       if (*rest) {
9896         for (cp2 = vmsspec + strlen(vmsspec);
9897              *rest && cp2 - vmsspec < sizeof vmsspec;
9898              rest++, cp2++) *cp2 = *rest;
9899         *cp2 = '\0';
9900       }
9901     }
9902   }
9903   /* Intuit whether verb (first word of cmd) is a DCL command:
9904    *   - if first nonspace char is '@', it's a DCL indirection
9905    * otherwise
9906    *   - if verb contains a filespec separator, it's not a DCL command
9907    *   - if it doesn't, caller tells us whether to default to a DCL
9908    *     command, or to a local image unless told it's DCL (by leading '$')
9909    */
9910   if (*s == '@') {
9911       isdcl = 1;
9912       if (suggest_quote) *suggest_quote = 1;
9913   } else {
9914     register char *filespec = strpbrk(s,":<[.;");
9915     rest = wordbreak = strpbrk(s," \"\t/");
9916     if (!wordbreak) wordbreak = s + strlen(s);
9917     if (*s == '$') check_img = 0;
9918     if (filespec && (filespec < wordbreak)) isdcl = 0;
9919     else isdcl = !check_img;
9920   }
9921
9922   if (!isdcl) {
9923     int rsts;
9924     imgdsc.dsc$a_pointer = s;
9925     imgdsc.dsc$w_length = wordbreak - s;
9926     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9927     if (!(retsts&1)) {
9928         _ckvmssts(lib$find_file_end(&cxt));
9929         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9930       if (!(retsts & 1) && *s == '$') {
9931         _ckvmssts(lib$find_file_end(&cxt));
9932         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9933         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9934         if (!(retsts&1)) {
9935           _ckvmssts(lib$find_file_end(&cxt));
9936           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9937         }
9938       }
9939     }
9940     _ckvmssts(lib$find_file_end(&cxt));
9941
9942     if (retsts & 1) {
9943       FILE *fp;
9944       s = resspec;
9945       while (*s && !isspace(*s)) s++;
9946       *s = '\0';
9947
9948       /* check that it's really not DCL with no file extension */
9949       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9950       if (fp) {
9951         char b[256] = {0,0,0,0};
9952         read(fileno(fp), b, 256);
9953         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9954         if (isdcl) {
9955           int shebang_len;
9956
9957           /* Check for script */
9958           shebang_len = 0;
9959           if ((b[0] == '#') && (b[1] == '!'))
9960              shebang_len = 2;
9961 #ifdef ALTERNATE_SHEBANG
9962           else {
9963             shebang_len = strlen(ALTERNATE_SHEBANG);
9964             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9965               char * perlstr;
9966                 perlstr = strstr("perl",b);
9967                 if (perlstr == NULL)
9968                   shebang_len = 0;
9969             }
9970             else
9971               shebang_len = 0;
9972           }
9973 #endif
9974
9975           if (shebang_len > 0) {
9976           int i;
9977           int j;
9978           char tmpspec[NAM$C_MAXRSS + 1];
9979
9980             i = shebang_len;
9981              /* Image is following after white space */
9982             /*--------------------------------------*/
9983             while (isprint(b[i]) && isspace(b[i]))
9984                 i++;
9985
9986             j = 0;
9987             while (isprint(b[i]) && !isspace(b[i])) {
9988                 tmpspec[j++] = b[i++];
9989                 if (j >= NAM$C_MAXRSS)
9990                    break;
9991             }
9992             tmpspec[j] = '\0';
9993
9994              /* There may be some default parameters to the image */
9995             /*---------------------------------------------------*/
9996             j = 0;
9997             while (isprint(b[i])) {
9998                 image_argv[j++] = b[i++];
9999                 if (j >= NAM$C_MAXRSS)
10000                    break;
10001             }
10002             while ((j > 0) && !isprint(image_argv[j-1]))
10003                 j--;
10004             image_argv[j] = 0;
10005
10006             /* It will need to be converted to VMS format and validated */
10007             if (tmpspec[0] != '\0') {
10008               char * iname;
10009
10010                /* Try to find the exact program requested to be run */
10011               /*---------------------------------------------------*/
10012               iname = do_rmsexpand
10013                  (tmpspec, image_name, 0, ".exe",
10014                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
10015               if (iname != NULL) {
10016                 if (cando_by_name_int
10017                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10018                   /* MCR prefix needed */
10019                   isdcl = 0;
10020                 }
10021                 else {
10022                    /* Try again with a null type */
10023                   /*----------------------------*/
10024                   iname = do_rmsexpand
10025                     (tmpspec, image_name, 0, ".",
10026                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
10027                   if (iname != NULL) {
10028                     if (cando_by_name_int
10029                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10030                       /* MCR prefix needed */
10031                       isdcl = 0;
10032                     }
10033                   }
10034                 }
10035
10036                  /* Did we find the image to run the script? */
10037                 /*------------------------------------------*/
10038                 if (isdcl) {
10039                   char *tchr;
10040
10041                    /* Assume DCL or foreign command exists */
10042                   /*--------------------------------------*/
10043                   tchr = strrchr(tmpspec, '/');
10044                   if (tchr != NULL) {
10045                     tchr++;
10046                   }
10047                   else {
10048                     tchr = tmpspec;
10049                   }
10050                   strcpy(image_name, tchr);
10051                 }
10052               }
10053             }
10054           }
10055         }
10056         fclose(fp);
10057       }
10058       if (check_img && isdcl) return RMS$_FNF;
10059
10060       if (cando_by_name(S_IXUSR,0,resspec)) {
10061         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10062         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10063         if (!isdcl) {
10064             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10065             if (image_name[0] != 0) {
10066                 strcat(vmscmd->dsc$a_pointer, image_name);
10067                 strcat(vmscmd->dsc$a_pointer, " ");
10068             }
10069         } else if (image_name[0] != 0) {
10070             strcpy(vmscmd->dsc$a_pointer, image_name);
10071             strcat(vmscmd->dsc$a_pointer, " ");
10072         } else {
10073             strcpy(vmscmd->dsc$a_pointer,"@");
10074         }
10075         if (suggest_quote) *suggest_quote = 1;
10076
10077         /* If there is an image name, use original command */
10078         if (image_name[0] == 0)
10079             strcat(vmscmd->dsc$a_pointer,resspec);
10080         else {
10081             rest = cmd;
10082             while (*rest && isspace(*rest)) rest++;
10083         }
10084
10085         if (image_argv[0] != 0) {
10086           strcat(vmscmd->dsc$a_pointer,image_argv);
10087           strcat(vmscmd->dsc$a_pointer, " ");
10088         }
10089         if (rest) {
10090            int rest_len;
10091            int vmscmd_len;
10092
10093            rest_len = strlen(rest);
10094            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10095            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10096               strcat(vmscmd->dsc$a_pointer,rest);
10097            else
10098              retsts = CLI$_BUFOVF;
10099         }
10100         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10101         PerlMem_free(cmd);
10102         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10103       }
10104       else
10105         retsts = RMS$_PRV;
10106     }
10107   }
10108   /* It's either a DCL command or we couldn't find a suitable image */
10109   vmscmd->dsc$w_length = strlen(cmd);
10110
10111   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10112   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10113   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10114
10115   PerlMem_free(cmd);
10116
10117   /* check if it's a symbol (for quoting purposes) */
10118   if (suggest_quote && !*suggest_quote) {
10119     int iss;
10120     char equiv[LNM$C_NAMLENGTH];
10121     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10122     eqvdsc.dsc$a_pointer = equiv;
10123
10124     iss = lib$get_symbol(vmscmd,&eqvdsc);
10125     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10126   }
10127   if (!(retsts & 1)) {
10128     /* just hand off status values likely to be due to user error */
10129     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10130         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10131        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10132     else { _ckvmssts(retsts); }
10133   }
10134
10135   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10136
10137 }  /* end of setup_cmddsc() */
10138
10139
10140 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10141 bool
10142 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10143 {
10144 bool exec_sts;
10145 char * cmd;
10146
10147   if (sp > mark) {
10148     if (vfork_called) {           /* this follows a vfork - act Unixish */
10149       vfork_called--;
10150       if (vfork_called < 0) {
10151         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10152         vfork_called = 0;
10153       }
10154       else return do_aexec(really,mark,sp);
10155     }
10156                                            /* no vfork - act VMSish */
10157     cmd = setup_argstr(aTHX_ really,mark,sp);
10158     exec_sts = vms_do_exec(cmd);
10159     Safefree(cmd);  /* Clean up from setup_argstr() */
10160     return exec_sts;
10161   }
10162
10163   return FALSE;
10164 }  /* end of vms_do_aexec() */
10165 /*}}}*/
10166
10167 /* {{{bool vms_do_exec(char *cmd) */
10168 bool
10169 Perl_vms_do_exec(pTHX_ const char *cmd)
10170 {
10171   struct dsc$descriptor_s *vmscmd;
10172
10173   if (vfork_called) {             /* this follows a vfork - act Unixish */
10174     vfork_called--;
10175     if (vfork_called < 0) {
10176       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10177       vfork_called = 0;
10178     }
10179     else return do_exec(cmd);
10180   }
10181
10182   {                               /* no vfork - act VMSish */
10183     unsigned long int retsts;
10184
10185     TAINT_ENV();
10186     TAINT_PROPER("exec");
10187     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10188       retsts = lib$do_command(vmscmd);
10189
10190     switch (retsts) {
10191       case RMS$_FNF: case RMS$_DNF:
10192         set_errno(ENOENT); break;
10193       case RMS$_DIR:
10194         set_errno(ENOTDIR); break;
10195       case RMS$_DEV:
10196         set_errno(ENODEV); break;
10197       case RMS$_PRV:
10198         set_errno(EACCES); break;
10199       case RMS$_SYN:
10200         set_errno(EINVAL); break;
10201       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10202         set_errno(E2BIG); break;
10203       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10204         _ckvmssts(retsts); /* fall through */
10205       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10206         set_errno(EVMSERR);
10207     }
10208     set_vaxc_errno(retsts);
10209     if (ckWARN(WARN_EXEC)) {
10210       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10211              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10212     }
10213     vms_execfree(vmscmd);
10214   }
10215
10216   return FALSE;
10217
10218 }  /* end of vms_do_exec() */
10219 /*}}}*/
10220
10221 int do_spawn2(pTHX_ const char *, int);
10222
10223 int
10224 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10225 {
10226 unsigned long int sts;
10227 char * cmd;
10228 int flags = 0;
10229
10230   if (sp > mark) {
10231
10232     /* We'll copy the (undocumented?) Win32 behavior and allow a
10233      * numeric first argument.  But the only value we'll support
10234      * through do_aspawn is a value of 1, which means spawn without
10235      * waiting for completion -- other values are ignored.
10236      */
10237     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10238         ++mark;
10239         flags = SvIVx(*mark);
10240     }
10241
10242     if (flags && flags == 1)     /* the Win32 P_NOWAIT value */
10243         flags = CLI$M_NOWAIT;
10244     else
10245         flags = 0;
10246
10247     cmd = setup_argstr(aTHX_ really, mark, sp);
10248     sts = do_spawn2(aTHX_ cmd, flags);
10249     /* pp_sys will clean up cmd */
10250     return sts;
10251   }
10252   return SS$_ABORT;
10253 }  /* end of do_aspawn() */
10254 /*}}}*/
10255
10256
10257 /* {{{int do_spawn(char* cmd) */
10258 int
10259 Perl_do_spawn(pTHX_ char* cmd)
10260 {
10261     PERL_ARGS_ASSERT_DO_SPAWN;
10262
10263     return do_spawn2(aTHX_ cmd, 0);
10264 }
10265 /*}}}*/
10266
10267 /* {{{int do_spawn_nowait(char* cmd) */
10268 int
10269 Perl_do_spawn_nowait(pTHX_ char* cmd)
10270 {
10271     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10272
10273     return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10274 }
10275 /*}}}*/
10276
10277 /* {{{int do_spawn2(char *cmd) */
10278 int
10279 do_spawn2(pTHX_ const char *cmd, int flags)
10280 {
10281   unsigned long int sts, substs;
10282
10283   /* The caller of this routine expects to Safefree(PL_Cmd) */
10284   Newx(PL_Cmd,10,char);
10285
10286   TAINT_ENV();
10287   TAINT_PROPER("spawn");
10288   if (!cmd || !*cmd) {
10289     sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10290     if (!(sts & 1)) {
10291       switch (sts) {
10292         case RMS$_FNF:  case RMS$_DNF:
10293           set_errno(ENOENT); break;
10294         case RMS$_DIR:
10295           set_errno(ENOTDIR); break;
10296         case RMS$_DEV:
10297           set_errno(ENODEV); break;
10298         case RMS$_PRV:
10299           set_errno(EACCES); break;
10300         case RMS$_SYN:
10301           set_errno(EINVAL); break;
10302         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10303           set_errno(E2BIG); break;
10304         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10305           _ckvmssts(sts); /* fall through */
10306         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10307           set_errno(EVMSERR);
10308       }
10309       set_vaxc_errno(sts);
10310       if (ckWARN(WARN_EXEC)) {
10311         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10312                     Strerror(errno));
10313       }
10314     }
10315     sts = substs;
10316   }
10317   else {
10318     char mode[3];
10319     PerlIO * fp;
10320     if (flags & CLI$M_NOWAIT)
10321         strcpy(mode, "n");
10322     else
10323         strcpy(mode, "nW");
10324
10325     fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10326     if (fp != NULL)
10327       my_pclose(fp);
10328     /* sts will be the pid in the nowait case */
10329   }
10330   return sts;
10331 }  /* end of do_spawn2() */
10332 /*}}}*/
10333
10334
10335 static unsigned int *sockflags, sockflagsize;
10336
10337 /*
10338  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10339  * routines found in some versions of the CRTL can't deal with sockets.
10340  * We don't shim the other file open routines since a socket isn't
10341  * likely to be opened by a name.
10342  */
10343 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10344 FILE *my_fdopen(int fd, const char *mode)
10345 {
10346   FILE *fp = fdopen(fd, mode);
10347
10348   if (fp) {
10349     unsigned int fdoff = fd / sizeof(unsigned int);
10350     Stat_t sbuf; /* native stat; we don't need flex_stat */
10351     if (!sockflagsize || fdoff > sockflagsize) {
10352       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
10353       else           Newx  (sockflags,fdoff+2,unsigned int);
10354       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10355       sockflagsize = fdoff + 2;
10356     }
10357     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
10358       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10359   }
10360   return fp;
10361
10362 }
10363 /*}}}*/
10364
10365
10366 /*
10367  * Clear the corresponding bit when the (possibly) socket stream is closed.
10368  * There still a small hole: we miss an implicit close which might occur
10369  * via freopen().  >> Todo
10370  */
10371 /*{{{ int my_fclose(FILE *fp)*/
10372 int my_fclose(FILE *fp) {
10373   if (fp) {
10374     unsigned int fd = fileno(fp);
10375     unsigned int fdoff = fd / sizeof(unsigned int);
10376
10377     if (sockflagsize && fdoff <= sockflagsize)
10378       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10379   }
10380   return fclose(fp);
10381 }
10382 /*}}}*/
10383
10384
10385 /*
10386  * A simple fwrite replacement which outputs itmsz*nitm chars without
10387  * introducing record boundaries every itmsz chars.
10388  * We are using fputs, which depends on a terminating null.  We may
10389  * well be writing binary data, so we need to accommodate not only
10390  * data with nulls sprinkled in the middle but also data with no null
10391  * byte at the end.
10392  */
10393 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10394 int
10395 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
10396 {
10397   register char *cp, *end, *cpd, *data;
10398   register unsigned int fd = fileno(dest);
10399   register unsigned int fdoff = fd / sizeof(unsigned int);
10400   int retval;
10401   int bufsize = itmsz * nitm + 1;
10402
10403   if (fdoff < sockflagsize &&
10404       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10405     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10406     return nitm;
10407   }
10408
10409   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
10410   memcpy( data, src, itmsz*nitm );
10411   data[itmsz*nitm] = '\0';
10412
10413   end = data + itmsz * nitm;
10414   retval = (int) nitm; /* on success return # items written */
10415
10416   cpd = data;
10417   while (cpd <= end) {
10418     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10419     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
10420     if (cp < end)
10421       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10422     cpd = cp + 1;
10423   }
10424
10425   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
10426   return retval;
10427
10428 }  /* end of my_fwrite() */
10429 /*}}}*/
10430
10431 /*{{{ int my_flush(FILE *fp)*/
10432 int
10433 Perl_my_flush(pTHX_ FILE *fp)
10434 {
10435     int res;
10436     if ((res = fflush(fp)) == 0 && fp) {
10437 #ifdef VMS_DO_SOCKETS
10438         Stat_t s;
10439         if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
10440 #endif
10441             res = fsync(fileno(fp));
10442     }
10443 /*
10444  * If the flush succeeded but set end-of-file, we need to clear
10445  * the error because our caller may check ferror().  BTW, this
10446  * probably means we just flushed an empty file.
10447  */
10448     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10449
10450     return res;
10451 }
10452 /*}}}*/
10453
10454 /*
10455  * Here are replacements for the following Unix routines in the VMS environment:
10456  *      getpwuid    Get information for a particular UIC or UID
10457  *      getpwnam    Get information for a named user
10458  *      getpwent    Get information for each user in the rights database
10459  *      setpwent    Reset search to the start of the rights database
10460  *      endpwent    Finish searching for users in the rights database
10461  *
10462  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10463  * (defined in pwd.h), which contains the following fields:-
10464  *      struct passwd {
10465  *              char        *pw_name;    Username (in lower case)
10466  *              char        *pw_passwd;  Hashed password
10467  *              unsigned int pw_uid;     UIC
10468  *              unsigned int pw_gid;     UIC group  number
10469  *              char        *pw_unixdir; Default device/directory (VMS-style)
10470  *              char        *pw_gecos;   Owner name
10471  *              char        *pw_dir;     Default device/directory (Unix-style)
10472  *              char        *pw_shell;   Default CLI name (eg. DCL)
10473  *      };
10474  * If the specified user does not exist, getpwuid and getpwnam return NULL.
10475  *
10476  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10477  * not the UIC member number (eg. what's returned by getuid()),
10478  * getpwuid() can accept either as input (if uid is specified, the caller's
10479  * UIC group is used), though it won't recognise gid=0.
10480  *
10481  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10482  * information about other users in your group or in other groups, respectively.
10483  * If the required privilege is not available, then these routines fill only
10484  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10485  * string).
10486  *
10487  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10488  */
10489
10490 /* sizes of various UAF record fields */
10491 #define UAI$S_USERNAME 12
10492 #define UAI$S_IDENT    31
10493 #define UAI$S_OWNER    31
10494 #define UAI$S_DEFDEV   31
10495 #define UAI$S_DEFDIR   63
10496 #define UAI$S_DEFCLI   31
10497 #define UAI$S_PWD       8
10498
10499 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
10500                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10501                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
10502
10503 static char __empty[]= "";
10504 static struct passwd __passwd_empty=
10505     {(char *) __empty, (char *) __empty, 0, 0,
10506      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10507 static int contxt= 0;
10508 static struct passwd __pwdcache;
10509 static char __pw_namecache[UAI$S_IDENT+1];
10510
10511 /*
10512  * This routine does most of the work extracting the user information.
10513  */
10514 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
10515 {
10516     static struct {
10517         unsigned char length;
10518         char pw_gecos[UAI$S_OWNER+1];
10519     } owner;
10520     static union uicdef uic;
10521     static struct {
10522         unsigned char length;
10523         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
10524     } defdev;
10525     static struct {
10526         unsigned char length;
10527         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
10528     } defdir;
10529     static struct {
10530         unsigned char length;
10531         char pw_shell[UAI$S_DEFCLI+1];
10532     } defcli;
10533     static char pw_passwd[UAI$S_PWD+1];
10534
10535     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
10536     struct dsc$descriptor_s name_desc;
10537     unsigned long int sts;
10538
10539     static struct itmlst_3 itmlst[]= {
10540         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
10541         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
10542         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
10543         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
10544         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
10545         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
10546         {0,                0,           NULL,    NULL}};
10547
10548     name_desc.dsc$w_length=  strlen(name);
10549     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10550     name_desc.dsc$b_class=   DSC$K_CLASS_S;
10551     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
10552
10553 /*  Note that sys$getuai returns many fields as counted strings. */
10554     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
10555     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
10556       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
10557     }
10558     else { _ckvmssts(sts); }
10559     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
10560
10561     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
10562     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
10563     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
10564     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
10565     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
10566     owner.pw_gecos[lowner]=            '\0';
10567     defdev.pw_dir[ldefdev+ldefdir]= '\0';
10568     defcli.pw_shell[ldefcli]=          '\0';
10569     if (valid_uic(uic)) {
10570         pwd->pw_uid= uic.uic$l_uic;
10571         pwd->pw_gid= uic.uic$v_group;
10572     }
10573     else
10574       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
10575     pwd->pw_passwd=  pw_passwd;
10576     pwd->pw_gecos=   owner.pw_gecos;
10577     pwd->pw_dir=     defdev.pw_dir;
10578     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
10579     pwd->pw_shell=   defcli.pw_shell;
10580     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
10581         int ldir;
10582         ldir= strlen(pwd->pw_unixdir) - 1;
10583         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
10584     }
10585     else
10586         strcpy(pwd->pw_unixdir, pwd->pw_dir);
10587     if (!decc_efs_case_preserve)
10588         __mystrtolower(pwd->pw_unixdir);
10589     return 1;
10590 }
10591
10592 /*
10593  * Get information for a named user.
10594 */
10595 /*{{{struct passwd *getpwnam(char *name)*/
10596 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
10597 {
10598     struct dsc$descriptor_s name_desc;
10599     union uicdef uic;
10600     unsigned long int status, sts;
10601
10602     __pwdcache = __passwd_empty;
10603     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
10604       /* We still may be able to determine pw_uid and pw_gid */
10605       name_desc.dsc$w_length=  strlen(name);
10606       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
10607       name_desc.dsc$b_class=   DSC$K_CLASS_S;
10608       name_desc.dsc$a_pointer= (char *) name;
10609       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
10610         __pwdcache.pw_uid= uic.uic$l_uic;
10611         __pwdcache.pw_gid= uic.uic$v_group;
10612       }
10613       else {
10614         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
10615           set_vaxc_errno(sts);
10616           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
10617           return NULL;
10618         }
10619         else { _ckvmssts(sts); }
10620       }
10621     }
10622     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
10623     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
10624     __pwdcache.pw_name= __pw_namecache;
10625     return &__pwdcache;
10626 }  /* end of my_getpwnam() */
10627 /*}}}*/
10628
10629 /*
10630  * Get information for a particular UIC or UID.
10631  * Called by my_getpwent with uid=-1 to list all users.
10632 */
10633 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
10634 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
10635 {
10636     const $DESCRIPTOR(name_desc,__pw_namecache);
10637     unsigned short lname;
10638     union uicdef uic;
10639     unsigned long int status;
10640
10641     if (uid == (unsigned int) -1) {
10642       do {
10643         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
10644         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
10645           set_vaxc_errno(status);
10646           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10647           my_endpwent();
10648           return NULL;
10649         }
10650         else { _ckvmssts(status); }
10651       } while (!valid_uic (uic));
10652     }
10653     else {
10654       uic.uic$l_uic= uid;
10655       if (!uic.uic$v_group)
10656         uic.uic$v_group= PerlProc_getgid();
10657       if (valid_uic(uic))
10658         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
10659       else status = SS$_IVIDENT;
10660       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
10661           status == RMS$_PRV) {
10662         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10663         return NULL;
10664       }
10665       else { _ckvmssts(status); }
10666     }
10667     __pw_namecache[lname]= '\0';
10668     __mystrtolower(__pw_namecache);
10669
10670     __pwdcache = __passwd_empty;
10671     __pwdcache.pw_name = __pw_namecache;
10672
10673 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10674     The identifier's value is usually the UIC, but it doesn't have to be,
10675     so if we can, we let fillpasswd update this. */
10676     __pwdcache.pw_uid =  uic.uic$l_uic;
10677     __pwdcache.pw_gid =  uic.uic$v_group;
10678
10679     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10680     return &__pwdcache;
10681
10682 }  /* end of my_getpwuid() */
10683 /*}}}*/
10684
10685 /*
10686  * Get information for next user.
10687 */
10688 /*{{{struct passwd *my_getpwent()*/
10689 struct passwd *Perl_my_getpwent(pTHX)
10690 {
10691     return (my_getpwuid((unsigned int) -1));
10692 }
10693 /*}}}*/
10694
10695 /*
10696  * Finish searching rights database for users.
10697 */
10698 /*{{{void my_endpwent()*/
10699 void Perl_my_endpwent(pTHX)
10700 {
10701     if (contxt) {
10702       _ckvmssts(sys$finish_rdb(&contxt));
10703       contxt= 0;
10704     }
10705 }
10706 /*}}}*/
10707
10708 #ifdef HOMEGROWN_POSIX_SIGNALS
10709   /* Signal handling routines, pulled into the core from POSIX.xs.
10710    *
10711    * We need these for threads, so they've been rolled into the core,
10712    * rather than left in POSIX.xs.
10713    *
10714    * (DRS, Oct 23, 1997)
10715    */
10716
10717   /* sigset_t is atomic under VMS, so these routines are easy */
10718 /*{{{int my_sigemptyset(sigset_t *) */
10719 int my_sigemptyset(sigset_t *set) {
10720     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10721     *set = 0; return 0;
10722 }
10723 /*}}}*/
10724
10725
10726 /*{{{int my_sigfillset(sigset_t *)*/
10727 int my_sigfillset(sigset_t *set) {
10728     int i;
10729     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10730     for (i = 0; i < NSIG; i++) *set |= (1 << i);
10731     return 0;
10732 }
10733 /*}}}*/
10734
10735
10736 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10737 int my_sigaddset(sigset_t *set, int sig) {
10738     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10739     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10740     *set |= (1 << (sig - 1));
10741     return 0;
10742 }
10743 /*}}}*/
10744
10745
10746 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10747 int my_sigdelset(sigset_t *set, int sig) {
10748     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10749     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10750     *set &= ~(1 << (sig - 1));
10751     return 0;
10752 }
10753 /*}}}*/
10754
10755
10756 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10757 int my_sigismember(sigset_t *set, int sig) {
10758     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10759     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10760     return *set & (1 << (sig - 1));
10761 }
10762 /*}}}*/
10763
10764
10765 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10766 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10767     sigset_t tempmask;
10768
10769     /* If set and oset are both null, then things are badly wrong. Bail out. */
10770     if ((oset == NULL) && (set == NULL)) {
10771       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10772       return -1;
10773     }
10774
10775     /* If set's null, then we're just handling a fetch. */
10776     if (set == NULL) {
10777         tempmask = sigblock(0);
10778     }
10779     else {
10780       switch (how) {
10781       case SIG_SETMASK:
10782         tempmask = sigsetmask(*set);
10783         break;
10784       case SIG_BLOCK:
10785         tempmask = sigblock(*set);
10786         break;
10787       case SIG_UNBLOCK:
10788         tempmask = sigblock(0);
10789         sigsetmask(*oset & ~tempmask);
10790         break;
10791       default:
10792         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10793         return -1;
10794       }
10795     }
10796
10797     /* Did they pass us an oset? If so, stick our holding mask into it */
10798     if (oset)
10799       *oset = tempmask;
10800
10801     return 0;
10802 }
10803 /*}}}*/
10804 #endif  /* HOMEGROWN_POSIX_SIGNALS */
10805
10806
10807 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10808  * my_utime(), and flex_stat(), all of which operate on UTC unless
10809  * VMSISH_TIMES is true.
10810  */
10811 /* method used to handle UTC conversions:
10812  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
10813  */
10814 static int gmtime_emulation_type;
10815 /* number of secs to add to UTC POSIX-style time to get local time */
10816 static long int utc_offset_secs;
10817
10818 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10819  * in vmsish.h.  #undef them here so we can call the CRTL routines
10820  * directly.
10821  */
10822 #undef gmtime
10823 #undef localtime
10824 #undef time
10825
10826
10827 /*
10828  * DEC C previous to 6.0 corrupts the behavior of the /prefix
10829  * qualifier with the extern prefix pragma.  This provisional
10830  * hack circumvents this prefix pragma problem in previous
10831  * precompilers.
10832  */
10833 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10834 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10835 #    pragma __extern_prefix save
10836 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
10837 #    define gmtime decc$__utctz_gmtime
10838 #    define localtime decc$__utctz_localtime
10839 #    define time decc$__utc_time
10840 #    pragma __extern_prefix restore
10841
10842      struct tm *gmtime(), *localtime();
10843
10844 #  endif
10845 #endif
10846
10847
10848 static time_t toutc_dst(time_t loc) {
10849   struct tm *rsltmp;
10850
10851   if ((rsltmp = localtime(&loc)) == NULL) return -1;
10852   loc -= utc_offset_secs;
10853   if (rsltmp->tm_isdst) loc -= 3600;
10854   return loc;
10855 }
10856 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10857        ((gmtime_emulation_type || my_time(NULL)), \
10858        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10859        ((secs) - utc_offset_secs))))
10860
10861 static time_t toloc_dst(time_t utc) {
10862   struct tm *rsltmp;
10863
10864   utc += utc_offset_secs;
10865   if ((rsltmp = localtime(&utc)) == NULL) return -1;
10866   if (rsltmp->tm_isdst) utc += 3600;
10867   return utc;
10868 }
10869 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10870        ((gmtime_emulation_type || my_time(NULL)), \
10871        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10872        ((secs) + utc_offset_secs))))
10873
10874 #ifndef RTL_USES_UTC
10875 /*
10876
10877     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
10878         DST starts on 1st sun of april      at 02:00  std time
10879             ends on last sun of october     at 02:00  dst time
10880     see the UCX management command reference, SET CONFIG TIMEZONE
10881     for formatting info.
10882
10883     No, it's not as general as it should be, but then again, NOTHING
10884     will handle UK times in a sensible way.
10885 */
10886
10887
10888 /*
10889     parse the DST start/end info:
10890     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10891 */
10892
10893 static char *
10894 tz_parse_startend(char *s, struct tm *w, int *past)
10895 {
10896     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10897     int ly, dozjd, d, m, n, hour, min, sec, j, k;
10898     time_t g;
10899
10900     if (!s)    return 0;
10901     if (!w) return 0;
10902     if (!past) return 0;
10903
10904     ly = 0;
10905     if (w->tm_year % 4        == 0) ly = 1;
10906     if (w->tm_year % 100      == 0) ly = 0;
10907     if (w->tm_year+1900 % 400 == 0) ly = 1;
10908     if (ly) dinm[1]++;
10909
10910     dozjd = isdigit(*s);
10911     if (*s == 'J' || *s == 'j' || dozjd) {
10912         if (!dozjd && !isdigit(*++s)) return 0;
10913         d = *s++ - '0';
10914         if (isdigit(*s)) {
10915             d = d*10 + *s++ - '0';
10916             if (isdigit(*s)) {
10917                 d = d*10 + *s++ - '0';
10918             }
10919         }
10920         if (d == 0) return 0;
10921         if (d > 366) return 0;
10922         d--;
10923         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
10924         g = d * 86400;
10925         dozjd = 1;
10926     } else if (*s == 'M' || *s == 'm') {
10927         if (!isdigit(*++s)) return 0;
10928         m = *s++ - '0';
10929         if (isdigit(*s)) m = 10*m + *s++ - '0';
10930         if (*s != '.') return 0;
10931         if (!isdigit(*++s)) return 0;
10932         n = *s++ - '0';
10933         if (n < 1 || n > 5) return 0;
10934         if (*s != '.') return 0;
10935         if (!isdigit(*++s)) return 0;
10936         d = *s++ - '0';
10937         if (d > 6) return 0;
10938     }
10939
10940     if (*s == '/') {
10941         if (!isdigit(*++s)) return 0;
10942         hour = *s++ - '0';
10943         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10944         if (*s == ':') {
10945             if (!isdigit(*++s)) return 0;
10946             min = *s++ - '0';
10947             if (isdigit(*s)) min = 10*min + *s++ - '0';
10948             if (*s == ':') {
10949                 if (!isdigit(*++s)) return 0;
10950                 sec = *s++ - '0';
10951                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10952             }
10953         }
10954     } else {
10955         hour = 2;
10956         min = 0;
10957         sec = 0;
10958     }
10959
10960     if (dozjd) {
10961         if (w->tm_yday < d) goto before;
10962         if (w->tm_yday > d) goto after;
10963     } else {
10964         if (w->tm_mon+1 < m) goto before;
10965         if (w->tm_mon+1 > m) goto after;
10966
10967         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
10968         k = d - j; /* mday of first d */
10969         if (k <= 0) k += 7;
10970         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
10971         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10972         if (w->tm_mday < k) goto before;
10973         if (w->tm_mday > k) goto after;
10974     }
10975
10976     if (w->tm_hour < hour) goto before;
10977     if (w->tm_hour > hour) goto after;
10978     if (w->tm_min  < min)  goto before;
10979     if (w->tm_min  > min)  goto after;
10980     if (w->tm_sec  < sec)  goto before;
10981     goto after;
10982
10983 before:
10984     *past = 0;
10985     return s;
10986 after:
10987     *past = 1;
10988     return s;
10989 }
10990
10991
10992
10993
10994 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
10995
10996 static char *
10997 tz_parse_offset(char *s, int *offset)
10998 {
10999     int hour = 0, min = 0, sec = 0;
11000     int neg = 0;
11001     if (!s) return 0;
11002     if (!offset) return 0;
11003
11004     if (*s == '-') {neg++; s++;}
11005     if (*s == '+') s++;
11006     if (!isdigit(*s)) return 0;
11007     hour = *s++ - '0';
11008     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11009     if (hour > 24) return 0;
11010     if (*s == ':') {
11011         if (!isdigit(*++s)) return 0;
11012         min = *s++ - '0';
11013         if (isdigit(*s)) min = min*10 + (*s++ - '0');
11014         if (min > 59) return 0;
11015         if (*s == ':') {
11016             if (!isdigit(*++s)) return 0;
11017             sec = *s++ - '0';
11018             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11019             if (sec > 59) return 0;
11020         }
11021     }
11022
11023     *offset = (hour*60+min)*60 + sec;
11024     if (neg) *offset = -*offset;
11025     return s;
11026 }
11027
11028 /*
11029     input time is w, whatever type of time the CRTL localtime() uses.
11030     sets dst, the zone, and the gmtoff (seconds)
11031
11032     caches the value of TZ and UCX$TZ env variables; note that
11033     my_setenv looks for these and sets a flag if they're changed
11034     for efficiency.
11035
11036     We have to watch out for the "australian" case (dst starts in
11037     october, ends in april)...flagged by "reverse" and checked by
11038     scanning through the months of the previous year.
11039
11040 */
11041
11042 static int
11043 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11044 {
11045     time_t when;
11046     struct tm *w2;
11047     char *s,*s2;
11048     char *dstzone, *tz, *s_start, *s_end;
11049     int std_off, dst_off, isdst;
11050     int y, dststart, dstend;
11051     static char envtz[1025];  /* longer than any logical, symbol, ... */
11052     static char ucxtz[1025];
11053     static char reversed = 0;
11054
11055     if (!w) return 0;
11056
11057     if (tz_updated) {
11058         tz_updated = 0;
11059         reversed = -1;  /* flag need to check  */
11060         envtz[0] = ucxtz[0] = '\0';
11061         tz = my_getenv("TZ",0);
11062         if (tz) strcpy(envtz, tz);
11063         tz = my_getenv("UCX$TZ",0);
11064         if (tz) strcpy(ucxtz, tz);
11065         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
11066     }
11067     tz = envtz;
11068     if (!*tz) tz = ucxtz;
11069
11070     s = tz;
11071     while (isalpha(*s)) s++;
11072     s = tz_parse_offset(s, &std_off);
11073     if (!s) return 0;
11074     if (!*s) {                  /* no DST, hurray we're done! */
11075         isdst = 0;
11076         goto done;
11077     }
11078
11079     dstzone = s;
11080     while (isalpha(*s)) s++;
11081     s2 = tz_parse_offset(s, &dst_off);
11082     if (s2) {
11083         s = s2;
11084     } else {
11085         dst_off = std_off - 3600;
11086     }
11087
11088     if (!*s) {      /* default dst start/end?? */
11089         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
11090             s = strchr(ucxtz,',');
11091         }
11092         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
11093     }
11094     if (*s != ',') return 0;
11095
11096     when = *w;
11097     when = _toutc(when);      /* convert to utc */
11098     when = when - std_off;    /* convert to pseudolocal time*/
11099
11100     w2 = localtime(&when);
11101     y = w2->tm_year;
11102     s_start = s+1;
11103     s = tz_parse_startend(s_start,w2,&dststart);
11104     if (!s) return 0;
11105     if (*s != ',') return 0;
11106
11107     when = *w;
11108     when = _toutc(when);      /* convert to utc */
11109     when = when - dst_off;    /* convert to pseudolocal time*/
11110     w2 = localtime(&when);
11111     if (w2->tm_year != y) {   /* spans a year, just check one time */
11112         when += dst_off - std_off;
11113         w2 = localtime(&when);
11114     }
11115     s_end = s+1;
11116     s = tz_parse_startend(s_end,w2,&dstend);
11117     if (!s) return 0;
11118
11119     if (reversed == -1) {  /* need to check if start later than end */
11120         int j, ds, de;
11121
11122         when = *w;
11123         if (when < 2*365*86400) {
11124             when += 2*365*86400;
11125         } else {
11126             when -= 365*86400;
11127         }
11128         w2 =localtime(&when);
11129         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
11130
11131         for (j = 0; j < 12; j++) {
11132             w2 =localtime(&when);
11133             tz_parse_startend(s_start,w2,&ds);
11134             tz_parse_startend(s_end,w2,&de);
11135             if (ds != de) break;
11136             when += 30*86400;
11137         }
11138         reversed = 0;
11139         if (de && !ds) reversed = 1;
11140     }
11141
11142     isdst = dststart && !dstend;
11143     if (reversed) isdst = dststart  || !dstend;
11144
11145 done:
11146     if (dst)    *dst = isdst;
11147     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11148     if (isdst)  tz = dstzone;
11149     if (zone) {
11150         while(isalpha(*tz))  *zone++ = *tz++;
11151         *zone = '\0';
11152     }
11153     return 1;
11154 }
11155
11156 #endif /* !RTL_USES_UTC */
11157
11158 /* my_time(), my_localtime(), my_gmtime()
11159  * By default traffic in UTC time values, using CRTL gmtime() or
11160  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11161  * Note: We need to use these functions even when the CRTL has working
11162  * UTC support, since they also handle C<use vmsish qw(times);>
11163  *
11164  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
11165  * Modified by Charles Bailey <bailey@newman.upenn.edu>
11166  */
11167
11168 /*{{{time_t my_time(time_t *timep)*/
11169 time_t Perl_my_time(pTHX_ time_t *timep)
11170 {
11171   time_t when;
11172   struct tm *tm_p;
11173
11174   if (gmtime_emulation_type == 0) {
11175     int dstnow;
11176     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
11177                               /* results of calls to gmtime() and localtime() */
11178                               /* for same &base */
11179
11180     gmtime_emulation_type++;
11181     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11182       char off[LNM$C_NAMLENGTH+1];;
11183
11184       gmtime_emulation_type++;
11185       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11186         gmtime_emulation_type++;
11187         utc_offset_secs = 0;
11188         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11189       }
11190       else { utc_offset_secs = atol(off); }
11191     }
11192     else { /* We've got a working gmtime() */
11193       struct tm gmt, local;
11194
11195       gmt = *tm_p;
11196       tm_p = localtime(&base);
11197       local = *tm_p;
11198       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
11199       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11200       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
11201       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
11202     }
11203   }
11204
11205   when = time(NULL);
11206 # ifdef VMSISH_TIME
11207 # ifdef RTL_USES_UTC
11208   if (VMSISH_TIME) when = _toloc(when);
11209 # else
11210   if (!VMSISH_TIME) when = _toutc(when);
11211 # endif
11212 # endif
11213   if (timep != NULL) *timep = when;
11214   return when;
11215
11216 }  /* end of my_time() */
11217 /*}}}*/
11218
11219
11220 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11221 struct tm *
11222 Perl_my_gmtime(pTHX_ const time_t *timep)
11223 {
11224   char *p;
11225   time_t when;
11226   struct tm *rsltmp;
11227
11228   if (timep == NULL) {
11229     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11230     return NULL;
11231   }
11232   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11233
11234   when = *timep;
11235 # ifdef VMSISH_TIME
11236   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11237 #  endif
11238 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
11239   return gmtime(&when);
11240 # else
11241   /* CRTL localtime() wants local time as input, so does no tz correction */
11242   rsltmp = localtime(&when);
11243   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
11244   return rsltmp;
11245 #endif
11246 }  /* end of my_gmtime() */
11247 /*}}}*/
11248
11249
11250 /*{{{struct tm *my_localtime(const time_t *timep)*/
11251 struct tm *
11252 Perl_my_localtime(pTHX_ const time_t *timep)
11253 {
11254   time_t when, whenutc;
11255   struct tm *rsltmp;
11256   int dst, offset;
11257
11258   if (timep == NULL) {
11259     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11260     return NULL;
11261   }
11262   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
11263   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11264
11265   when = *timep;
11266 # ifdef RTL_USES_UTC
11267 # ifdef VMSISH_TIME
11268   if (VMSISH_TIME) when = _toutc(when);
11269 # endif
11270   /* CRTL localtime() wants UTC as input, does tz correction itself */
11271   return localtime(&when);
11272
11273 # else /* !RTL_USES_UTC */
11274   whenutc = when;
11275 # ifdef VMSISH_TIME
11276   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
11277   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
11278 # endif
11279   dst = -1;
11280 #ifndef RTL_USES_UTC
11281   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
11282       when = whenutc - offset;                   /* pseudolocal time*/
11283   }
11284 # endif
11285   /* CRTL localtime() wants local time as input, so does no tz correction */
11286   rsltmp = localtime(&when);
11287   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11288   return rsltmp;
11289 # endif
11290
11291 } /*  end of my_localtime() */
11292 /*}}}*/
11293
11294 /* Reset definitions for later calls */
11295 #define gmtime(t)    my_gmtime(t)
11296 #define localtime(t) my_localtime(t)
11297 #define time(t)      my_time(t)
11298
11299
11300 /* my_utime - update modification/access time of a file
11301  *
11302  * VMS 7.3 and later implementation
11303  * Only the UTC translation is home-grown. The rest is handled by the
11304  * CRTL utime(), which will take into account the relevant feature
11305  * logicals and ODS-5 volume characteristics for true access times.
11306  *
11307  * pre VMS 7.3 implementation:
11308  * The calling sequence is identical to POSIX utime(), but under
11309  * VMS with ODS-2, only the modification time is changed; ODS-2 does
11310  * not maintain access times.  Restrictions differ from the POSIX
11311  * definition in that the time can be changed as long as the
11312  * caller has permission to execute the necessary IO$_MODIFY $QIO;
11313  * no separate checks are made to insure that the caller is the
11314  * owner of the file or has special privs enabled.
11315  * Code here is based on Joe Meadows' FILE utility.
11316  *
11317  */
11318
11319 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11320  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
11321  * in 100 ns intervals.
11322  */
11323 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11324
11325 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11326 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11327 {
11328 #if __CRTL_VER >= 70300000
11329   struct utimbuf utc_utimes, *utc_utimesp;
11330
11331   if (utimes != NULL) {
11332     utc_utimes.actime = utimes->actime;
11333     utc_utimes.modtime = utimes->modtime;
11334 # ifdef VMSISH_TIME
11335     /* If input was local; convert to UTC for sys svc */
11336     if (VMSISH_TIME) {
11337       utc_utimes.actime = _toutc(utimes->actime);
11338       utc_utimes.modtime = _toutc(utimes->modtime);
11339     }
11340 # endif
11341     utc_utimesp = &utc_utimes;
11342   }
11343   else {
11344     utc_utimesp = NULL;
11345   }
11346
11347   return utime(file, utc_utimesp);
11348
11349 #else /* __CRTL_VER < 70300000 */
11350
11351   register int i;
11352   int sts;
11353   long int bintime[2], len = 2, lowbit, unixtime,
11354            secscale = 10000000; /* seconds --> 100 ns intervals */
11355   unsigned long int chan, iosb[2], retsts;
11356   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11357   struct FAB myfab = cc$rms_fab;
11358   struct NAM mynam = cc$rms_nam;
11359 #if defined (__DECC) && defined (__VAX)
11360   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11361    * at least through VMS V6.1, which causes a type-conversion warning.
11362    */
11363 #  pragma message save
11364 #  pragma message disable cvtdiftypes
11365 #endif
11366   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11367   struct fibdef myfib;
11368 #if defined (__DECC) && defined (__VAX)
11369   /* This should be right after the declaration of myatr, but due
11370    * to a bug in VAX DEC C, this takes effect a statement early.
11371    */
11372 #  pragma message restore
11373 #endif
11374   /* cast ok for read only parameter */
11375   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11376                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11377                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11378
11379   if (file == NULL || *file == '\0') {
11380     SETERRNO(ENOENT, LIB$_INVARG);
11381     return -1;
11382   }
11383
11384   /* Convert to VMS format ensuring that it will fit in 255 characters */
11385   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
11386       SETERRNO(ENOENT, LIB$_INVARG);
11387       return -1;
11388   }
11389   if (utimes != NULL) {
11390     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
11391      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11392      * Since time_t is unsigned long int, and lib$emul takes a signed long int
11393      * as input, we force the sign bit to be clear by shifting unixtime right
11394      * one bit, then multiplying by an extra factor of 2 in lib$emul().
11395      */
11396     lowbit = (utimes->modtime & 1) ? secscale : 0;
11397     unixtime = (long int) utimes->modtime;
11398 #   ifdef VMSISH_TIME
11399     /* If input was UTC; convert to local for sys svc */
11400     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11401 #   endif
11402     unixtime >>= 1;  secscale <<= 1;
11403     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11404     if (!(retsts & 1)) {
11405       SETERRNO(EVMSERR, retsts);
11406       return -1;
11407     }
11408     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11409     if (!(retsts & 1)) {
11410       SETERRNO(EVMSERR, retsts);
11411       return -1;
11412     }
11413   }
11414   else {
11415     /* Just get the current time in VMS format directly */
11416     retsts = sys$gettim(bintime);
11417     if (!(retsts & 1)) {
11418       SETERRNO(EVMSERR, retsts);
11419       return -1;
11420     }
11421   }
11422
11423   myfab.fab$l_fna = vmsspec;
11424   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11425   myfab.fab$l_nam = &mynam;
11426   mynam.nam$l_esa = esa;
11427   mynam.nam$b_ess = (unsigned char) sizeof esa;
11428   mynam.nam$l_rsa = rsa;
11429   mynam.nam$b_rss = (unsigned char) sizeof rsa;
11430   if (decc_efs_case_preserve)
11431       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11432
11433   /* Look for the file to be affected, letting RMS parse the file
11434    * specification for us as well.  I have set errno using only
11435    * values documented in the utime() man page for VMS POSIX.
11436    */
11437   retsts = sys$parse(&myfab,0,0);
11438   if (!(retsts & 1)) {
11439     set_vaxc_errno(retsts);
11440     if      (retsts == RMS$_PRV) set_errno(EACCES);
11441     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11442     else                         set_errno(EVMSERR);
11443     return -1;
11444   }
11445   retsts = sys$search(&myfab,0,0);
11446   if (!(retsts & 1)) {
11447     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11448     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11449     set_vaxc_errno(retsts);
11450     if      (retsts == RMS$_PRV) set_errno(EACCES);
11451     else if (retsts == RMS$_FNF) set_errno(ENOENT);
11452     else                         set_errno(EVMSERR);
11453     return -1;
11454   }
11455
11456   devdsc.dsc$w_length = mynam.nam$b_dev;
11457   /* cast ok for read only parameter */
11458   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11459
11460   retsts = sys$assign(&devdsc,&chan,0,0);
11461   if (!(retsts & 1)) {
11462     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11463     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11464     set_vaxc_errno(retsts);
11465     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
11466     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
11467     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
11468     else                               set_errno(EVMSERR);
11469     return -1;
11470   }
11471
11472   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11473   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11474
11475   memset((void *) &myfib, 0, sizeof myfib);
11476 #if defined(__DECC) || defined(__DECCXX)
11477   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11478   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11479   /* This prevents the revision time of the file being reset to the current
11480    * time as a result of our IO$_MODIFY $QIO. */
11481   myfib.fib$l_acctl = FIB$M_NORECORD;
11482 #else
11483   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11484   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11485   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11486 #endif
11487   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11488   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
11489   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
11490   _ckvmssts(sys$dassgn(chan));
11491   if (retsts & 1) retsts = iosb[0];
11492   if (!(retsts & 1)) {
11493     set_vaxc_errno(retsts);
11494     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11495     else                      set_errno(EVMSERR);
11496     return -1;
11497   }
11498
11499   return 0;
11500
11501 #endif /* #if __CRTL_VER >= 70300000 */
11502
11503 }  /* end of my_utime() */
11504 /*}}}*/
11505
11506 /*
11507  * flex_stat, flex_lstat, flex_fstat
11508  * basic stat, but gets it right when asked to stat
11509  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11510  */
11511
11512 #ifndef _USE_STD_STAT
11513 /* encode_dev packs a VMS device name string into an integer to allow
11514  * simple comparisons. This can be used, for example, to check whether two
11515  * files are located on the same device, by comparing their encoded device
11516  * names. Even a string comparison would not do, because stat() reuses the
11517  * device name buffer for each call; so without encode_dev, it would be
11518  * necessary to save the buffer and use strcmp (this would mean a number of
11519  * changes to the standard Perl code, to say nothing of what a Perl script
11520  * would have to do.
11521  *
11522  * The device lock id, if it exists, should be unique (unless perhaps compared
11523  * with lock ids transferred from other nodes). We have a lock id if the disk is
11524  * mounted cluster-wide, which is when we tend to get long (host-qualified)
11525  * device names. Thus we use the lock id in preference, and only if that isn't
11526  * available, do we try to pack the device name into an integer (flagged by
11527  * the sign bit (LOCKID_MASK) being set).
11528  *
11529  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11530  * name and its encoded form, but it seems very unlikely that we will find
11531  * two files on different disks that share the same encoded device names,
11532  * and even more remote that they will share the same file id (if the test
11533  * is to check for the same file).
11534  *
11535  * A better method might be to use sys$device_scan on the first call, and to
11536  * search for the device, returning an index into the cached array.
11537  * The number returned would be more intelligible.
11538  * This is probably not worth it, and anyway would take quite a bit longer
11539  * on the first call.
11540  */
11541 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
11542 static mydev_t encode_dev (pTHX_ const char *dev)
11543 {
11544   int i;
11545   unsigned long int f;
11546   mydev_t enc;
11547   char c;
11548   const char *q;
11549
11550   if (!dev || !dev[0]) return 0;
11551
11552 #if LOCKID_MASK
11553   {
11554     struct dsc$descriptor_s dev_desc;
11555     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11556
11557     /* For cluster-mounted disks, the disk lock identifier is unique, so we
11558        can try that first. */
11559     dev_desc.dsc$w_length =  strlen (dev);
11560     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
11561     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
11562     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
11563     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11564     if (!$VMS_STATUS_SUCCESS(status)) {
11565       switch (status) {
11566         case SS$_NOSUCHDEV:
11567           SETERRNO(ENODEV, status);
11568           return 0;
11569         default:
11570           _ckvmssts(status);
11571       }
11572     }
11573     if (lockid) return (lockid & ~LOCKID_MASK);
11574   }
11575 #endif
11576
11577   /* Otherwise we try to encode the device name */
11578   enc = 0;
11579   f = 1;
11580   i = 0;
11581   for (q = dev + strlen(dev); q--; q >= dev) {
11582     if (*q == ':')
11583         break;
11584     if (isdigit (*q))
11585       c= (*q) - '0';
11586     else if (isalpha (toupper (*q)))
11587       c= toupper (*q) - 'A' + (char)10;
11588     else
11589       continue; /* Skip '$'s */
11590     i++;
11591     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
11592     if (i>1) f *= 36;
11593     enc += f * (unsigned long int) c;
11594   }
11595   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
11596
11597 }  /* end of encode_dev() */
11598 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11599         device_no = encode_dev(aTHX_ devname)
11600 #else
11601 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11602         device_no = new_dev_no
11603 #endif
11604
11605 static int
11606 is_null_device(name)
11607     const char *name;
11608 {
11609   if (decc_bug_devnull != 0) {
11610     if (strncmp("/dev/null", name, 9) == 0)
11611       return 1;
11612   }
11613     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11614        The underscore prefix, controller letter, and unit number are
11615        independently optional; for our purposes, the colon punctuation
11616        is not.  The colon can be trailed by optional directory and/or
11617        filename, but two consecutive colons indicates a nodename rather
11618        than a device.  [pr]  */
11619   if (*name == '_') ++name;
11620   if (tolower(*name++) != 'n') return 0;
11621   if (tolower(*name++) != 'l') return 0;
11622   if (tolower(*name) == 'a') ++name;
11623   if (*name == '0') ++name;
11624   return (*name++ == ':') && (*name != ':');
11625 }
11626
11627
11628 static I32
11629 Perl_cando_by_name_int
11630    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11631 {
11632   char usrname[L_cuserid];
11633   struct dsc$descriptor_s usrdsc =
11634          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11635   char *vmsname = NULL, *fileified = NULL;
11636   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11637   unsigned short int retlen, trnlnm_iter_count;
11638   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11639   union prvdef curprv;
11640   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11641          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11642          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11643   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11644          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11645          {0,0,0,0}};
11646   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11647          {0,0,0,0}};
11648   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11649   Stat_t st;
11650   static int profile_context = -1;
11651
11652   if (!fname || !*fname) return FALSE;
11653
11654   /* Make sure we expand logical names, since sys$check_access doesn't */
11655   fileified = PerlMem_malloc(VMS_MAXRSS);
11656   if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
11657   if (!strpbrk(fname,"/]>:")) {
11658       strcpy(fileified,fname);
11659       trnlnm_iter_count = 0;
11660       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11661         trnlnm_iter_count++;
11662         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11663       }
11664       fname = fileified;
11665   }
11666
11667   vmsname = PerlMem_malloc(VMS_MAXRSS);
11668   if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11669   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11670     /* Don't know if already in VMS format, so make sure */
11671     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11672       PerlMem_free(fileified);
11673       PerlMem_free(vmsname);
11674       return FALSE;
11675     }
11676   }
11677   else {
11678     strcpy(vmsname,fname);
11679   }
11680
11681   /* sys$check_access needs a file spec, not a directory spec.
11682    * Don't use flex_stat here, as that depends on thread context
11683    * having been initialized, and we may get here during startup.
11684    */
11685
11686   retlen = namdsc.dsc$w_length = strlen(vmsname);
11687   if (vmsname[retlen-1] == ']'
11688       || vmsname[retlen-1] == '>'
11689       || vmsname[retlen-1] == ':'
11690       || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11691
11692       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11693         PerlMem_free(fileified);
11694         PerlMem_free(vmsname);
11695         return FALSE;
11696       }
11697       fname = fileified;
11698   }
11699   else {
11700       fname = vmsname;
11701   }
11702
11703   retlen = namdsc.dsc$w_length = strlen(fname);
11704   namdsc.dsc$a_pointer = (char *)fname;
11705
11706   switch (bit) {
11707     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11708       access = ARM$M_EXECUTE;
11709       flags = CHP$M_READ;
11710       break;
11711     case S_IRUSR: case S_IRGRP: case S_IROTH:
11712       access = ARM$M_READ;
11713       flags = CHP$M_READ | CHP$M_USEREADALL;
11714       break;
11715     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11716       access = ARM$M_WRITE;
11717       flags = CHP$M_READ | CHP$M_WRITE;
11718       break;
11719     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11720       access = ARM$M_DELETE;
11721       flags = CHP$M_READ | CHP$M_WRITE;
11722       break;
11723     default:
11724       if (fileified != NULL)
11725         PerlMem_free(fileified);
11726       if (vmsname != NULL)
11727         PerlMem_free(vmsname);
11728       return FALSE;
11729   }
11730
11731   /* Before we call $check_access, create a user profile with the current
11732    * process privs since otherwise it just uses the default privs from the
11733    * UAF and might give false positives or negatives.  This only works on
11734    * VMS versions v6.0 and later since that's when sys$create_user_profile
11735    * became available.
11736    */
11737
11738   /* get current process privs and username */
11739   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11740   _ckvmssts(iosb[0]);
11741
11742 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11743
11744   /* find out the space required for the profile */
11745   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11746                                     &usrprodsc.dsc$w_length,&profile_context));
11747
11748   /* allocate space for the profile and get it filled in */
11749   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11750   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11751   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11752                                     &usrprodsc.dsc$w_length,&profile_context));
11753
11754   /* use the profile to check access to the file; free profile & analyze results */
11755   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11756   PerlMem_free(usrprodsc.dsc$a_pointer);
11757   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11758
11759 #else
11760
11761   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11762
11763 #endif
11764
11765   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11766       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11767       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11768     set_vaxc_errno(retsts);
11769     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11770     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11771     else set_errno(ENOENT);
11772     if (fileified != NULL)
11773       PerlMem_free(fileified);
11774     if (vmsname != NULL)
11775       PerlMem_free(vmsname);
11776     return FALSE;
11777   }
11778   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11779     if (fileified != NULL)
11780       PerlMem_free(fileified);
11781     if (vmsname != NULL)
11782       PerlMem_free(vmsname);
11783     return TRUE;
11784   }
11785   _ckvmssts(retsts);
11786
11787   if (fileified != NULL)
11788     PerlMem_free(fileified);
11789   if (vmsname != NULL)
11790     PerlMem_free(vmsname);
11791   return FALSE;  /* Should never get here */
11792
11793 }
11794
11795 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
11796 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11797  * subset of the applicable information.
11798  */
11799 bool
11800 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11801 {
11802   return cando_by_name_int
11803         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11804 }  /* end of cando() */
11805 /*}}}*/
11806
11807
11808 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11809 I32
11810 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11811 {
11812    return cando_by_name_int(bit, effective, fname, 0);
11813
11814 }  /* end of cando_by_name() */
11815 /*}}}*/
11816
11817
11818 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11819 int
11820 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11821 {
11822   if (!fstat(fd,(stat_t *) statbufp)) {
11823     char *cptr;
11824     char *vms_filename;
11825     vms_filename = PerlMem_malloc(VMS_MAXRSS);
11826     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11827
11828     /* Save name for cando by name in VMS format */
11829     cptr = getname(fd, vms_filename, 1);
11830
11831     /* This should not happen, but just in case */
11832     if (cptr == NULL) {
11833         statbufp->st_devnam[0] = 0;
11834     }
11835     else {
11836         /* Make sure that the saved name fits in 255 characters */
11837         cptr = do_rmsexpand
11838                        (vms_filename,
11839                         statbufp->st_devnam,
11840                         0,
11841                         NULL,
11842                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11843                         NULL,
11844                         NULL);
11845         if (cptr == NULL)
11846             statbufp->st_devnam[0] = 0;
11847     }
11848     PerlMem_free(vms_filename);
11849
11850     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11851     VMS_DEVICE_ENCODE
11852         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11853
11854 #   ifdef RTL_USES_UTC
11855 #   ifdef VMSISH_TIME
11856     if (VMSISH_TIME) {
11857       statbufp->st_mtime = _toloc(statbufp->st_mtime);
11858       statbufp->st_atime = _toloc(statbufp->st_atime);
11859       statbufp->st_ctime = _toloc(statbufp->st_ctime);
11860     }
11861 #   endif
11862 #   else
11863 #   ifdef VMSISH_TIME
11864     if (!VMSISH_TIME) { /* Return UTC instead of local time */
11865 #   else
11866     if (1) {
11867 #   endif
11868       statbufp->st_mtime = _toutc(statbufp->st_mtime);
11869       statbufp->st_atime = _toutc(statbufp->st_atime);
11870       statbufp->st_ctime = _toutc(statbufp->st_ctime);
11871     }
11872 #endif
11873     return 0;
11874   }
11875   return -1;
11876
11877 }  /* end of flex_fstat() */
11878 /*}}}*/
11879
11880 #if !defined(__VAX) && __CRTL_VER >= 80200000
11881 #ifdef lstat
11882 #undef lstat
11883 #endif
11884 #else
11885 #ifdef lstat
11886 #undef lstat
11887 #endif
11888 #define lstat(_x, _y) stat(_x, _y)
11889 #endif
11890
11891 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11892
11893 static int
11894 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11895 {
11896     char fileified[VMS_MAXRSS];
11897     char temp_fspec[VMS_MAXRSS];
11898     char *save_spec;
11899     int retval = -1;
11900     int saved_errno, saved_vaxc_errno;
11901
11902     if (!fspec) return retval;
11903     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11904     strcpy(temp_fspec, fspec);
11905
11906     if (decc_bug_devnull != 0) {
11907       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11908         memset(statbufp,0,sizeof *statbufp);
11909         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11910         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11911         statbufp->st_uid = 0x00010001;
11912         statbufp->st_gid = 0x0001;
11913         time((time_t *)&statbufp->st_mtime);
11914         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11915         return 0;
11916       }
11917     }
11918
11919     /* Try for a directory name first.  If fspec contains a filename without
11920      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11921      * and sea:[wine.dark]water. exist, we prefer the directory here.
11922      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11923      * not sea:[wine.dark]., if the latter exists.  If the intended target is
11924      * the file with null type, specify this by calling flex_stat() with
11925      * a '.' at the end of fspec.
11926      *
11927      * If we are in Posix filespec mode, accept the filename as is.
11928      */
11929
11930
11931 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11932   /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11933    * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11934    */
11935   if (!decc_efs_charset)
11936     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11937 #endif
11938
11939 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11940   if (decc_posix_compliant_pathnames == 0) {
11941 #endif
11942     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11943       if (lstat_flag == 0)
11944         retval = stat(fileified,(stat_t *) statbufp);
11945       else
11946         retval = lstat(fileified,(stat_t *) statbufp);
11947       save_spec = fileified;
11948     }
11949     if (retval) {
11950       if (lstat_flag == 0)
11951         retval = stat(temp_fspec,(stat_t *) statbufp);
11952       else
11953         retval = lstat(temp_fspec,(stat_t *) statbufp);
11954       save_spec = temp_fspec;
11955     }
11956 /*
11957  * In debugging, on 8.3 Alpha, I found a case where stat was returning a
11958  * file not found error for a directory named foo:[bar.t] or /foo/bar/t
11959  * and lstat was working correctly for the same file.
11960  * The only syntax that was working for stat was "foo:[bar]t.dir".
11961  *
11962  * Other directories with the same syntax worked fine.
11963  * So work around the problem when it shows up here.
11964  */
11965     if (retval) {
11966         int save_errno = errno;
11967         if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
11968             if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
11969                 retval = stat(fileified, (stat_t *) statbufp);
11970                 save_spec = fileified;
11971             }
11972         }
11973         /* Restore the errno value if third stat does not succeed */
11974         if (retval != 0)
11975             errno = save_errno;
11976     }
11977 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11978   } else {
11979     if (lstat_flag == 0)
11980       retval = stat(temp_fspec,(stat_t *) statbufp);
11981     else
11982       retval = lstat(temp_fspec,(stat_t *) statbufp);
11983       save_spec = temp_fspec;
11984   }
11985 #endif
11986
11987 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11988   /* As you were... */
11989   if (!decc_efs_charset)
11990     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11991 #endif
11992
11993     if (!retval) {
11994     char * cptr;
11995     int rmsex_flags = PERL_RMSEXPAND_M_VMS;
11996
11997       /* If this is an lstat, do not follow the link */
11998       if (lstat_flag)
11999         rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12000
12001       cptr = do_rmsexpand
12002        (save_spec, statbufp->st_devnam, 0, NULL, rmsex_flags, NULL, NULL);
12003       if (cptr == NULL)
12004         statbufp->st_devnam[0] = 0;
12005
12006       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12007       VMS_DEVICE_ENCODE
12008         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12009 #     ifdef RTL_USES_UTC
12010 #     ifdef VMSISH_TIME
12011       if (VMSISH_TIME) {
12012         statbufp->st_mtime = _toloc(statbufp->st_mtime);
12013         statbufp->st_atime = _toloc(statbufp->st_atime);
12014         statbufp->st_ctime = _toloc(statbufp->st_ctime);
12015       }
12016 #     endif
12017 #     else
12018 #     ifdef VMSISH_TIME
12019       if (!VMSISH_TIME) { /* Return UTC instead of local time */
12020 #     else
12021       if (1) {
12022 #     endif
12023         statbufp->st_mtime = _toutc(statbufp->st_mtime);
12024         statbufp->st_atime = _toutc(statbufp->st_atime);
12025         statbufp->st_ctime = _toutc(statbufp->st_ctime);
12026       }
12027 #     endif
12028     }
12029     /* If we were successful, leave errno where we found it */
12030     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
12031     return retval;
12032
12033 }  /* end of flex_stat_int() */
12034
12035
12036 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12037 int
12038 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12039 {
12040    return flex_stat_int(fspec, statbufp, 0);
12041 }
12042 /*}}}*/
12043
12044 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12045 int
12046 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12047 {
12048    return flex_stat_int(fspec, statbufp, 1);
12049 }
12050 /*}}}*/
12051
12052
12053 /*{{{char *my_getlogin()*/
12054 /* VMS cuserid == Unix getlogin, except calling sequence */
12055 char *
12056 my_getlogin(void)
12057 {
12058     static char user[L_cuserid];
12059     return cuserid(user);
12060 }
12061 /*}}}*/
12062
12063
12064 /*  rmscopy - copy a file using VMS RMS routines
12065  *
12066  *  Copies contents and attributes of spec_in to spec_out, except owner
12067  *  and protection information.  Name and type of spec_in are used as
12068  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
12069  *  should try to propagate timestamps from the input file to the output file.
12070  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
12071  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
12072  *  propagated to the output file at creation iff the output file specification
12073  *  did not contain an explicit name or type, and the revision date is always
12074  *  updated at the end of the copy operation.  If it is greater than 0, then
12075  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12076  *  other than the revision date should be propagated, and bit 1 indicates
12077  *  that the revision date should be propagated.
12078  *
12079  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12080  *
12081  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12082  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
12083  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
12084  * as part of the Perl standard distribution under the terms of the
12085  * GNU General Public License or the Perl Artistic License.  Copies
12086  * of each may be found in the Perl standard distribution.
12087  */ /* FIXME */
12088 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12089 int
12090 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12091 {
12092     char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12093          *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12094     unsigned long int i, sts, sts2;
12095     int dna_len;
12096     struct FAB fab_in, fab_out;
12097     struct RAB rab_in, rab_out;
12098     rms_setup_nam(nam);
12099     rms_setup_nam(nam_out);
12100     struct XABDAT xabdat;
12101     struct XABFHC xabfhc;
12102     struct XABRDT xabrdt;
12103     struct XABSUM xabsum;
12104
12105     vmsin = PerlMem_malloc(VMS_MAXRSS);
12106     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
12107     vmsout = PerlMem_malloc(VMS_MAXRSS);
12108     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
12109     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
12110         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
12111       PerlMem_free(vmsin);
12112       PerlMem_free(vmsout);
12113       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12114       return 0;
12115     }
12116
12117     esa = PerlMem_malloc(VMS_MAXRSS);
12118     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
12119     esal = NULL;
12120 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12121     esal = PerlMem_malloc(VMS_MAXRSS);
12122     if (esal == NULL) _ckvmssts(SS$_INSFMEM);
12123 #endif
12124     fab_in = cc$rms_fab;
12125     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12126     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12127     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12128     fab_in.fab$l_fop = FAB$M_SQO;
12129     rms_bind_fab_nam(fab_in, nam);
12130     fab_in.fab$l_xab = (void *) &xabdat;
12131
12132     rsa = PerlMem_malloc(VMS_MAXRSS);
12133     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
12134     rsal = NULL;
12135 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12136     rsal = PerlMem_malloc(VMS_MAXRSS);
12137     if (rsal == NULL) _ckvmssts(SS$_INSFMEM);
12138 #endif
12139     rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12140     rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12141     rms_nam_esl(nam) = 0;
12142     rms_nam_rsl(nam) = 0;
12143     rms_nam_esll(nam) = 0;
12144     rms_nam_rsll(nam) = 0;
12145 #ifdef NAM$M_NO_SHORT_UPCASE
12146     if (decc_efs_case_preserve)
12147         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12148 #endif
12149
12150     xabdat = cc$rms_xabdat;        /* To get creation date */
12151     xabdat.xab$l_nxt = (void *) &xabfhc;
12152
12153     xabfhc = cc$rms_xabfhc;        /* To get record length */
12154     xabfhc.xab$l_nxt = (void *) &xabsum;
12155
12156     xabsum = cc$rms_xabsum;        /* To get key and area information */
12157
12158     if (!((sts = sys$open(&fab_in)) & 1)) {
12159       PerlMem_free(vmsin);
12160       PerlMem_free(vmsout);
12161       PerlMem_free(esa);
12162       if (esal != NULL)
12163         PerlMem_free(esal);
12164       PerlMem_free(rsa);
12165       if (rsal != NULL)
12166         PerlMem_free(rsal);
12167       set_vaxc_errno(sts);
12168       switch (sts) {
12169         case RMS$_FNF: case RMS$_DNF:
12170           set_errno(ENOENT); break;
12171         case RMS$_DIR:
12172           set_errno(ENOTDIR); break;
12173         case RMS$_DEV:
12174           set_errno(ENODEV); break;
12175         case RMS$_SYN:
12176           set_errno(EINVAL); break;
12177         case RMS$_PRV:
12178           set_errno(EACCES); break;
12179         default:
12180           set_errno(EVMSERR);
12181       }
12182       return 0;
12183     }
12184
12185     nam_out = nam;
12186     fab_out = fab_in;
12187     fab_out.fab$w_ifi = 0;
12188     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12189     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12190     fab_out.fab$l_fop = FAB$M_SQO;
12191     rms_bind_fab_nam(fab_out, nam_out);
12192     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12193     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12194     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12195     esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12196     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
12197     rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12198     if (rsa_out == NULL) _ckvmssts(SS$_INSFMEM);
12199     esal_out = NULL;
12200     rsal_out = NULL;
12201 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12202     esal_out = PerlMem_malloc(VMS_MAXRSS);
12203     if (esal_out == NULL) _ckvmssts(SS$_INSFMEM);
12204     rsal_out = PerlMem_malloc(VMS_MAXRSS);
12205     if (rsal_out == NULL) _ckvmssts(SS$_INSFMEM);
12206 #endif
12207     rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12208     rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12209
12210     if (preserve_dates == 0) {  /* Act like DCL COPY */
12211       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12212       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
12213       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12214         PerlMem_free(vmsin);
12215         PerlMem_free(vmsout);
12216         PerlMem_free(esa);
12217         if (esal != NULL)
12218             PerlMem_free(esal);
12219         PerlMem_free(rsa);
12220         if (rsal != NULL)
12221             PerlMem_free(rsal);
12222         PerlMem_free(esa_out);
12223         if (esal_out != NULL)
12224             PerlMem_free(esal_out);
12225         PerlMem_free(rsa_out);
12226         if (rsal_out != NULL)
12227             PerlMem_free(rsal_out);
12228         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12229         set_vaxc_errno(sts);
12230         return 0;
12231       }
12232       fab_out.fab$l_xab = (void *) &xabdat;
12233       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12234         preserve_dates = 1;
12235     }
12236     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
12237       preserve_dates =0;      /* bitmask from this point forward   */
12238
12239     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12240     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12241       PerlMem_free(vmsin);
12242       PerlMem_free(vmsout);
12243       PerlMem_free(esa);
12244       if (esal != NULL)
12245           PerlMem_free(esal);
12246       PerlMem_free(rsa);
12247       if (rsal != NULL)
12248           PerlMem_free(rsal);
12249       PerlMem_free(esa_out);
12250       if (esal_out != NULL)
12251           PerlMem_free(esal_out);
12252       PerlMem_free(rsa_out);
12253       if (rsal_out != NULL)
12254           PerlMem_free(rsal_out);
12255       set_vaxc_errno(sts);
12256       switch (sts) {
12257         case RMS$_DNF:
12258           set_errno(ENOENT); break;
12259         case RMS$_DIR:
12260           set_errno(ENOTDIR); break;
12261         case RMS$_DEV:
12262           set_errno(ENODEV); break;
12263         case RMS$_SYN:
12264           set_errno(EINVAL); break;
12265         case RMS$_PRV:
12266           set_errno(EACCES); break;
12267         default:
12268           set_errno(EVMSERR);
12269       }
12270       return 0;
12271     }
12272     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
12273     if (preserve_dates & 2) {
12274       /* sys$close() will process xabrdt, not xabdat */
12275       xabrdt = cc$rms_xabrdt;
12276 #ifndef __GNUC__
12277       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12278 #else
12279       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12280        * is unsigned long[2], while DECC & VAXC use a struct */
12281       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12282 #endif
12283       fab_out.fab$l_xab = (void *) &xabrdt;
12284     }
12285
12286     ubf = PerlMem_malloc(32256);
12287     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
12288     rab_in = cc$rms_rab;
12289     rab_in.rab$l_fab = &fab_in;
12290     rab_in.rab$l_rop = RAB$M_BIO;
12291     rab_in.rab$l_ubf = ubf;
12292     rab_in.rab$w_usz = 32256;
12293     if (!((sts = sys$connect(&rab_in)) & 1)) {
12294       sys$close(&fab_in); sys$close(&fab_out);
12295       PerlMem_free(vmsin);
12296       PerlMem_free(vmsout);
12297       PerlMem_free(ubf);
12298       PerlMem_free(esa);
12299       if (esal != NULL)
12300           PerlMem_free(esal);
12301       PerlMem_free(rsa);
12302       if (rsal != NULL)
12303           PerlMem_free(rsal);
12304       PerlMem_free(esa_out);
12305       if (esal_out != NULL)
12306           PerlMem_free(esal_out);
12307       PerlMem_free(rsa_out);
12308       if (rsal_out != NULL)
12309           PerlMem_free(rsal_out);
12310       set_errno(EVMSERR); set_vaxc_errno(sts);
12311       return 0;
12312     }
12313
12314     rab_out = cc$rms_rab;
12315     rab_out.rab$l_fab = &fab_out;
12316     rab_out.rab$l_rbf = ubf;
12317     if (!((sts = sys$connect(&rab_out)) & 1)) {
12318       sys$close(&fab_in); sys$close(&fab_out);
12319       PerlMem_free(vmsin);
12320       PerlMem_free(vmsout);
12321       PerlMem_free(ubf);
12322       PerlMem_free(esa);
12323       if (esal != NULL)
12324           PerlMem_free(esal);
12325       PerlMem_free(rsa);
12326       if (rsal != NULL)
12327           PerlMem_free(rsal);
12328       PerlMem_free(esa_out);
12329       if (esal_out != NULL)
12330           PerlMem_free(esal_out);
12331       PerlMem_free(rsa_out);
12332       if (rsal_out != NULL)
12333           PerlMem_free(rsal_out);
12334       set_errno(EVMSERR); set_vaxc_errno(sts);
12335       return 0;
12336     }
12337
12338     while ((sts = sys$read(&rab_in))) {  /* always true  */
12339       if (sts == RMS$_EOF) break;
12340       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12341       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12342         sys$close(&fab_in); sys$close(&fab_out);
12343         PerlMem_free(vmsin);
12344         PerlMem_free(vmsout);
12345         PerlMem_free(ubf);
12346         PerlMem_free(esa);
12347         if (esal != NULL)
12348             PerlMem_free(esal);
12349         PerlMem_free(rsa);
12350         if (rsal != NULL)
12351             PerlMem_free(rsal);
12352         PerlMem_free(esa_out);
12353         if (esal_out != NULL)
12354             PerlMem_free(esal_out);
12355         PerlMem_free(rsa_out);
12356         if (rsal_out != NULL)
12357             PerlMem_free(rsal_out);
12358         set_errno(EVMSERR); set_vaxc_errno(sts);
12359         return 0;
12360       }
12361     }
12362
12363
12364     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
12365     sys$close(&fab_in);  sys$close(&fab_out);
12366     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12367
12368     PerlMem_free(vmsin);
12369     PerlMem_free(vmsout);
12370     PerlMem_free(ubf);
12371     PerlMem_free(esa);
12372     if (esal != NULL)
12373         PerlMem_free(esal);
12374     PerlMem_free(rsa);
12375     if (rsal != NULL)
12376         PerlMem_free(rsal);
12377     PerlMem_free(esa_out);
12378     if (esal_out != NULL)
12379         PerlMem_free(esal_out);
12380     PerlMem_free(rsa_out);
12381     if (rsal_out != NULL)
12382         PerlMem_free(rsal_out);
12383
12384     if (!(sts & 1)) {
12385       set_errno(EVMSERR); set_vaxc_errno(sts);
12386       return 0;
12387     }
12388
12389     return 1;
12390
12391 }  /* end of rmscopy() */
12392 /*}}}*/
12393
12394
12395 /***  The following glue provides 'hooks' to make some of the routines
12396  * from this file available from Perl.  These routines are sufficiently
12397  * basic, and are required sufficiently early in the build process,
12398  * that's it's nice to have them available to miniperl as well as the
12399  * full Perl, so they're set up here instead of in an extension.  The
12400  * Perl code which handles importation of these names into a given
12401  * package lives in [.VMS]Filespec.pm in @INC.
12402  */
12403
12404 void
12405 rmsexpand_fromperl(pTHX_ CV *cv)
12406 {
12407   dXSARGS;
12408   char *fspec, *defspec = NULL, *rslt;
12409   STRLEN n_a;
12410   int fs_utf8, dfs_utf8;
12411
12412   fs_utf8 = 0;
12413   dfs_utf8 = 0;
12414   if (!items || items > 2)
12415     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12416   fspec = SvPV(ST(0),n_a);
12417   fs_utf8 = SvUTF8(ST(0));
12418   if (!fspec || !*fspec) XSRETURN_UNDEF;
12419   if (items == 2) {
12420     defspec = SvPV(ST(1),n_a);
12421     dfs_utf8 = SvUTF8(ST(1));
12422   }
12423   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12424   ST(0) = sv_newmortal();
12425   if (rslt != NULL) {
12426     sv_usepvn(ST(0),rslt,strlen(rslt));
12427     if (fs_utf8) {
12428         SvUTF8_on(ST(0));
12429     }
12430   }
12431   XSRETURN(1);
12432 }
12433
12434 void
12435 vmsify_fromperl(pTHX_ CV *cv)
12436 {
12437   dXSARGS;
12438   char *vmsified;
12439   STRLEN n_a;
12440   int utf8_fl;
12441
12442   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12443   utf8_fl = SvUTF8(ST(0));
12444   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12445   ST(0) = sv_newmortal();
12446   if (vmsified != NULL) {
12447     sv_usepvn(ST(0),vmsified,strlen(vmsified));
12448     if (utf8_fl) {
12449         SvUTF8_on(ST(0));
12450     }
12451   }
12452   XSRETURN(1);
12453 }
12454
12455 void
12456 unixify_fromperl(pTHX_ CV *cv)
12457 {
12458   dXSARGS;
12459   char *unixified;
12460   STRLEN n_a;
12461   int utf8_fl;
12462
12463   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12464   utf8_fl = SvUTF8(ST(0));
12465   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12466   ST(0) = sv_newmortal();
12467   if (unixified != NULL) {
12468     sv_usepvn(ST(0),unixified,strlen(unixified));
12469     if (utf8_fl) {
12470         SvUTF8_on(ST(0));
12471     }
12472   }
12473   XSRETURN(1);
12474 }
12475
12476 void
12477 fileify_fromperl(pTHX_ CV *cv)
12478 {
12479   dXSARGS;
12480   char *fileified;
12481   STRLEN n_a;
12482   int utf8_fl;
12483
12484   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12485   utf8_fl = SvUTF8(ST(0));
12486   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12487   ST(0) = sv_newmortal();
12488   if (fileified != NULL) {
12489     sv_usepvn(ST(0),fileified,strlen(fileified));
12490     if (utf8_fl) {
12491         SvUTF8_on(ST(0));
12492     }
12493   }
12494   XSRETURN(1);
12495 }
12496
12497 void
12498 pathify_fromperl(pTHX_ CV *cv)
12499 {
12500   dXSARGS;
12501   char *pathified;
12502   STRLEN n_a;
12503   int utf8_fl;
12504
12505   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12506   utf8_fl = SvUTF8(ST(0));
12507   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12508   ST(0) = sv_newmortal();
12509   if (pathified != NULL) {
12510     sv_usepvn(ST(0),pathified,strlen(pathified));
12511     if (utf8_fl) {
12512         SvUTF8_on(ST(0));
12513     }
12514   }
12515   XSRETURN(1);
12516 }
12517
12518 void
12519 vmspath_fromperl(pTHX_ CV *cv)
12520 {
12521   dXSARGS;
12522   char *vmspath;
12523   STRLEN n_a;
12524   int utf8_fl;
12525
12526   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12527   utf8_fl = SvUTF8(ST(0));
12528   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12529   ST(0) = sv_newmortal();
12530   if (vmspath != NULL) {
12531     sv_usepvn(ST(0),vmspath,strlen(vmspath));
12532     if (utf8_fl) {
12533         SvUTF8_on(ST(0));
12534     }
12535   }
12536   XSRETURN(1);
12537 }
12538
12539 void
12540 unixpath_fromperl(pTHX_ CV *cv)
12541 {
12542   dXSARGS;
12543   char *unixpath;
12544   STRLEN n_a;
12545   int utf8_fl;
12546
12547   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12548   utf8_fl = SvUTF8(ST(0));
12549   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12550   ST(0) = sv_newmortal();
12551   if (unixpath != NULL) {
12552     sv_usepvn(ST(0),unixpath,strlen(unixpath));
12553     if (utf8_fl) {
12554         SvUTF8_on(ST(0));
12555     }
12556   }
12557   XSRETURN(1);
12558 }
12559
12560 void
12561 candelete_fromperl(pTHX_ CV *cv)
12562 {
12563   dXSARGS;
12564   char *fspec, *fsp;
12565   SV *mysv;
12566   IO *io;
12567   STRLEN n_a;
12568
12569   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12570
12571   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12572   Newx(fspec, VMS_MAXRSS, char);
12573   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12574   if (SvTYPE(mysv) == SVt_PVGV) {
12575     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12576       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12577       ST(0) = &PL_sv_no;
12578       Safefree(fspec);
12579       XSRETURN(1);
12580     }
12581     fsp = fspec;
12582   }
12583   else {
12584     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12585       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12586       ST(0) = &PL_sv_no;
12587       Safefree(fspec);
12588       XSRETURN(1);
12589     }
12590   }
12591
12592   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12593   Safefree(fspec);
12594   XSRETURN(1);
12595 }
12596
12597 void
12598 rmscopy_fromperl(pTHX_ CV *cv)
12599 {
12600   dXSARGS;
12601   char *inspec, *outspec, *inp, *outp;
12602   int date_flag;
12603   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
12604                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12605   unsigned long int sts;
12606   SV *mysv;
12607   IO *io;
12608   STRLEN n_a;
12609
12610   if (items < 2 || items > 3)
12611     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12612
12613   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12614   Newx(inspec, VMS_MAXRSS, char);
12615   if (SvTYPE(mysv) == SVt_PVGV) {
12616     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12617       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12618       ST(0) = &PL_sv_no;
12619       Safefree(inspec);
12620       XSRETURN(1);
12621     }
12622     inp = inspec;
12623   }
12624   else {
12625     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12626       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12627       ST(0) = &PL_sv_no;
12628       Safefree(inspec);
12629       XSRETURN(1);
12630     }
12631   }
12632   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12633   Newx(outspec, VMS_MAXRSS, char);
12634   if (SvTYPE(mysv) == SVt_PVGV) {
12635     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12636       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12637       ST(0) = &PL_sv_no;
12638       Safefree(inspec);
12639       Safefree(outspec);
12640       XSRETURN(1);
12641     }
12642     outp = outspec;
12643   }
12644   else {
12645     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12646       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12647       ST(0) = &PL_sv_no;
12648       Safefree(inspec);
12649       Safefree(outspec);
12650       XSRETURN(1);
12651     }
12652   }
12653   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12654
12655   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
12656   Safefree(inspec);
12657   Safefree(outspec);
12658   XSRETURN(1);
12659 }
12660
12661 /* The mod2fname is limited to shorter filenames by design, so it should
12662  * not be modified to support longer EFS pathnames
12663  */
12664 void
12665 mod2fname(pTHX_ CV *cv)
12666 {
12667   dXSARGS;
12668   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12669        workbuff[NAM$C_MAXRSS*1 + 1];
12670   int total_namelen = 3, counter, num_entries;
12671   /* ODS-5 ups this, but we want to be consistent, so... */
12672   int max_name_len = 39;
12673   AV *in_array = (AV *)SvRV(ST(0));
12674
12675   num_entries = av_len(in_array);
12676
12677   /* All the names start with PL_. */
12678   strcpy(ultimate_name, "PL_");
12679
12680   /* Clean up our working buffer */
12681   Zero(work_name, sizeof(work_name), char);
12682
12683   /* Run through the entries and build up a working name */
12684   for(counter = 0; counter <= num_entries; counter++) {
12685     /* If it's not the first name then tack on a __ */
12686     if (counter) {
12687       strcat(work_name, "__");
12688     }
12689     strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
12690   }
12691
12692   /* Check to see if we actually have to bother...*/
12693   if (strlen(work_name) + 3 <= max_name_len) {
12694     strcat(ultimate_name, work_name);
12695   } else {
12696     /* It's too darned big, so we need to go strip. We use the same */
12697     /* algorithm as xsubpp does. First, strip out doubled __ */
12698     char *source, *dest, last;
12699     dest = workbuff;
12700     last = 0;
12701     for (source = work_name; *source; source++) {
12702       if (last == *source && last == '_') {
12703         continue;
12704       }
12705       *dest++ = *source;
12706       last = *source;
12707     }
12708     /* Go put it back */
12709     strcpy(work_name, workbuff);
12710     /* Is it still too big? */
12711     if (strlen(work_name) + 3 > max_name_len) {
12712       /* Strip duplicate letters */
12713       last = 0;
12714       dest = workbuff;
12715       for (source = work_name; *source; source++) {
12716         if (last == toupper(*source)) {
12717         continue;
12718         }
12719         *dest++ = *source;
12720         last = toupper(*source);
12721       }
12722       strcpy(work_name, workbuff);
12723     }
12724
12725     /* Is it *still* too big? */
12726     if (strlen(work_name) + 3 > max_name_len) {
12727       /* Too bad, we truncate */
12728       work_name[max_name_len - 2] = 0;
12729     }
12730     strcat(ultimate_name, work_name);
12731   }
12732
12733   /* Okay, return it */
12734   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12735   XSRETURN(1);
12736 }
12737
12738 void
12739 hushexit_fromperl(pTHX_ CV *cv)
12740 {
12741     dXSARGS;
12742
12743     if (items > 0) {
12744         VMSISH_HUSHED = SvTRUE(ST(0));
12745     }
12746     ST(0) = boolSV(VMSISH_HUSHED);
12747     XSRETURN(1);
12748 }
12749
12750
12751 PerlIO *
12752 Perl_vms_start_glob
12753    (pTHX_ SV *tmpglob,
12754     IO *io)
12755 {
12756     PerlIO *fp;
12757     struct vs_str_st *rslt;
12758     char *vmsspec;
12759     char *rstr;
12760     char *begin, *cp;
12761     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12762     PerlIO *tmpfp;
12763     STRLEN i;
12764     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12765     struct dsc$descriptor_vs rsdsc;
12766     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12767     unsigned long hasver = 0, isunix = 0;
12768     unsigned long int lff_flags = 0;
12769     int rms_sts;
12770
12771 #ifdef VMS_LONGNAME_SUPPORT
12772     lff_flags = LIB$M_FIL_LONG_NAMES;
12773 #endif
12774     /* The Newx macro will not allow me to assign a smaller array
12775      * to the rslt pointer, so we will assign it to the begin char pointer
12776      * and then copy the value into the rslt pointer.
12777      */
12778     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12779     rslt = (struct vs_str_st *)begin;
12780     rslt->length = 0;
12781     rstr = &rslt->str[0];
12782     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12783     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12784     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12785     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12786
12787     Newx(vmsspec, VMS_MAXRSS, char);
12788
12789         /* We could find out if there's an explicit dev/dir or version
12790            by peeking into lib$find_file's internal context at
12791            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12792            but that's unsupported, so I don't want to do it now and
12793            have it bite someone in the future. */
12794         /* Fix-me: vms_split_path() is the only way to do this, the
12795            existing method will fail with many legal EFS or UNIX specifications
12796          */
12797
12798     cp = SvPV(tmpglob,i);
12799
12800     for (; i; i--) {
12801         if (cp[i] == ';') hasver = 1;
12802         if (cp[i] == '.') {
12803             if (sts) hasver = 1;
12804             else sts = 1;
12805         }
12806         if (cp[i] == '/') {
12807             hasdir = isunix = 1;
12808             break;
12809         }
12810         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12811             hasdir = 1;
12812             break;
12813         }
12814     }
12815     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12816         int found = 0;
12817         Stat_t st;
12818         int stat_sts;
12819         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12820         if (!stat_sts && S_ISDIR(st.st_mode)) {
12821             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12822             ok = (wilddsc.dsc$a_pointer != NULL);
12823             /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12824             hasdir = 1;
12825         }
12826         else {
12827             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12828             ok = (wilddsc.dsc$a_pointer != NULL);
12829         }
12830         if (ok)
12831             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12832
12833         /* If not extended character set, replace ? with % */
12834         /* With extended character set, ? is a wildcard single character */
12835         if (!decc_efs_case_preserve) {
12836             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12837                 if (*cp == '?') *cp = '%';
12838         }
12839         sts = SS$_NORMAL;
12840         while (ok && $VMS_STATUS_SUCCESS(sts)) {
12841          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12842          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12843
12844             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12845                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
12846             if (!$VMS_STATUS_SUCCESS(sts))
12847                 break;
12848
12849             found++;
12850
12851             /* with varying string, 1st word of buffer contains result length */
12852             rstr[rslt->length] = '\0';
12853
12854              /* Find where all the components are */
12855              v_sts = vms_split_path
12856                        (rstr,
12857                         &v_spec,
12858                         &v_len,
12859                         &r_spec,
12860                         &r_len,
12861                         &d_spec,
12862                         &d_len,
12863                         &n_spec,
12864                         &n_len,
12865                         &e_spec,
12866                         &e_len,
12867                         &vs_spec,
12868                         &vs_len);
12869
12870             /* If no version on input, truncate the version on output */
12871             if (!hasver && (vs_len > 0)) {
12872                 *vs_spec = '\0';
12873                 vs_len = 0;
12874
12875                 /* No version & a null extension on UNIX handling */
12876                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12877                     e_len = 0;
12878                     *e_spec = '\0';
12879                 }
12880             }
12881
12882             if (!decc_efs_case_preserve) {
12883                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12884             }
12885
12886             if (hasdir) {
12887                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12888                 begin = rstr;
12889             }
12890             else {
12891                 /* Start with the name */
12892                 begin = n_spec;
12893             }
12894             strcat(begin,"\n");
12895             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12896         }
12897         if (cxt) (void)lib$find_file_end(&cxt);
12898
12899         if (!found) {
12900             /* Be POSIXish: return the input pattern when no matches */
12901             strcpy(rstr,SvPVX(tmpglob));
12902             strcat(rstr,"\n");
12903             ok = (PerlIO_puts(tmpfp,rstr) != EOF);
12904         }
12905
12906         if (ok && sts != RMS$_NMF &&
12907             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12908         if (!ok) {
12909             if (!(sts & 1)) {
12910                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12911             }
12912             PerlIO_close(tmpfp);
12913             fp = NULL;
12914         }
12915         else {
12916             PerlIO_rewind(tmpfp);
12917             IoTYPE(io) = IoTYPE_RDONLY;
12918             IoIFP(io) = fp = tmpfp;
12919             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
12920         }
12921     }
12922     Safefree(vmsspec);
12923     Safefree(rslt);
12924     return fp;
12925 }
12926
12927
12928 static char *
12929 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
12930                    int *utf8_fl);
12931
12932 void
12933 unixrealpath_fromperl(pTHX_ CV *cv)
12934 {
12935     dXSARGS;
12936     char *fspec, *rslt_spec, *rslt;
12937     STRLEN n_a;
12938
12939     if (!items || items != 1)
12940         Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
12941
12942     fspec = SvPV(ST(0),n_a);
12943     if (!fspec || !*fspec) XSRETURN_UNDEF;
12944
12945     Newx(rslt_spec, VMS_MAXRSS + 1, char);
12946     rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12947
12948     ST(0) = sv_newmortal();
12949     if (rslt != NULL)
12950         sv_usepvn(ST(0),rslt,strlen(rslt));
12951     else
12952         Safefree(rslt_spec);
12953         XSRETURN(1);
12954 }
12955
12956 static char *
12957 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
12958                    int *utf8_fl);
12959
12960 void
12961 vmsrealpath_fromperl(pTHX_ CV *cv)
12962 {
12963     dXSARGS;
12964     char *fspec, *rslt_spec, *rslt;
12965     STRLEN n_a;
12966
12967     if (!items || items != 1)
12968         Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
12969
12970     fspec = SvPV(ST(0),n_a);
12971     if (!fspec || !*fspec) XSRETURN_UNDEF;
12972
12973     Newx(rslt_spec, VMS_MAXRSS + 1, char);
12974     rslt = do_vms_realname(fspec, rslt_spec, NULL);
12975
12976     ST(0) = sv_newmortal();
12977     if (rslt != NULL)
12978         sv_usepvn(ST(0),rslt,strlen(rslt));
12979     else
12980         Safefree(rslt_spec);
12981         XSRETURN(1);
12982 }
12983
12984 #ifdef HAS_SYMLINK
12985 /*
12986  * A thin wrapper around decc$symlink to make sure we follow the
12987  * standard and do not create a symlink with a zero-length name.
12988  */
12989 /*{{{ int my_symlink(const char *path1, const char *path2)*/
12990 int my_symlink(const char *path1, const char *path2) {
12991   if (!path2 || !*path2) {
12992     SETERRNO(ENOENT, SS$_NOSUCHFILE);
12993     return -1;
12994   }
12995   return symlink(path1, path2);
12996 }
12997 /*}}}*/
12998
12999 #endif /* HAS_SYMLINK */
13000
13001 int do_vms_case_tolerant(void);
13002
13003 void
13004 case_tolerant_process_fromperl(pTHX_ CV *cv)
13005 {
13006   dXSARGS;
13007   ST(0) = boolSV(do_vms_case_tolerant());
13008   XSRETURN(1);
13009 }
13010
13011 #ifdef USE_ITHREADS
13012
13013 void
13014 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13015                           struct interp_intern *dst)
13016 {
13017     PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13018
13019     memcpy(dst,src,sizeof(struct interp_intern));
13020 }
13021
13022 #endif
13023
13024 void
13025 Perl_sys_intern_clear(pTHX)
13026 {
13027 }
13028
13029 void
13030 Perl_sys_intern_init(pTHX)
13031 {
13032     unsigned int ix = RAND_MAX;
13033     double x;
13034
13035     VMSISH_HUSHED = 0;
13036
13037     /* fix me later to track running under GNV */
13038     /* this allows some limited testing */
13039     MY_POSIX_EXIT = decc_filename_unix_report;
13040
13041     x = (float)ix;
13042     MY_INV_RAND_MAX = 1./x;
13043 }
13044
13045 void
13046 init_os_extras(void)
13047 {
13048   dTHX;
13049   char* file = __FILE__;
13050   if (decc_disable_to_vms_logname_translation) {
13051     no_translate_barewords = TRUE;
13052   } else {
13053     no_translate_barewords = FALSE;
13054   }
13055
13056   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13057   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13058   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13059   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13060   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13061   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13062   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13063   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13064   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13065   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13066   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13067   newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13068   newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13069   newXSproto("VMS::Filespec::case_tolerant_process",
13070       case_tolerant_process_fromperl,file,"");
13071
13072   store_pipelocs(aTHX);         /* will redo any earlier attempts */
13073
13074   return;
13075 }
13076
13077 #if __CRTL_VER == 80200000
13078 /* This missed getting in to the DECC SDK for 8.2 */
13079 char *realpath(const char *file_name, char * resolved_name, ...);
13080 #endif
13081
13082 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13083 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13084  * The perl fallback routine to provide realpath() is not as efficient
13085  * on OpenVMS.
13086  */
13087
13088 /* Hack, use old stat() as fastest way of getting ino_t and device */
13089 int decc$stat(const char *name, void * statbuf);
13090
13091
13092 /* Realpath is fragile.  In 8.3 it does not work if the feature
13093  * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13094  * links are implemented in RMS, not the CRTL. It also can fail if the
13095  * user does not have read/execute access to some of the directories.
13096  * So in order for Do What I Mean mode to work, if realpath() fails,
13097  * fall back to looking up the filename by the device name and FID.
13098  */
13099
13100 int vms_fid_to_name(char * outname, int outlen, const char * name)
13101 {
13102 struct statbuf_t {
13103     char           * st_dev;
13104     unsigned short st_ino[3];
13105     unsigned short padw;
13106     unsigned long  padl[30];  /* plenty of room */
13107 } statbuf;
13108 int sts;
13109 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13110 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13111
13112     sts = decc$stat(name, &statbuf);
13113     if (sts == 0) {
13114
13115         dvidsc.dsc$a_pointer=statbuf.st_dev;
13116        dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13117
13118         specdsc.dsc$a_pointer = outname;
13119         specdsc.dsc$w_length = outlen-1;
13120
13121        sts = lib$fid_to_name
13122             (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13123        if ($VMS_STATUS_SUCCESS(sts)) {
13124             outname[specdsc.dsc$w_length] = 0;
13125             return 0;
13126         }
13127     }
13128     return sts;
13129 }
13130
13131
13132
13133 static char *
13134 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13135                    int *utf8_fl)
13136 {
13137     char * rslt = NULL;
13138
13139 #ifdef HAS_SYMLINK
13140     if (decc_posix_compliant_pathnames > 0 ) {
13141         /* realpath currently only works if posix compliant pathnames are
13142          * enabled.  It may start working when they are not, but in that
13143          * case we still want the fallback behavior for backwards compatibility
13144          */
13145         rslt = realpath(filespec, outbuf);
13146     }
13147 #endif
13148
13149     if (rslt == NULL) {
13150         char * vms_spec;
13151         char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13152         int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13153         int file_len;
13154
13155         /* Fall back to fid_to_name */
13156
13157         Newx(vms_spec, VMS_MAXRSS + 1, char);
13158
13159         sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
13160         if (sts == 0) {
13161
13162
13163             /* Now need to trim the version off */
13164             sts = vms_split_path
13165                   (vms_spec,
13166                    &v_spec,
13167                    &v_len,
13168                    &r_spec,
13169                    &r_len,
13170                    &d_spec,
13171                    &d_len,
13172                    &n_spec,
13173                    &n_len,
13174                    &e_spec,
13175                    &e_len,
13176                    &vs_spec,
13177                    &vs_len);
13178
13179
13180                 if (sts == 0) {
13181                     int haslower = 0;
13182                     const char *cp;
13183
13184                     /* Trim off the version */
13185                     int file_len = v_len + r_len + d_len + n_len + e_len;
13186                     vms_spec[file_len] = 0;
13187
13188                     /* The result is expected to be in UNIX format */
13189                     rslt = do_tounixspec(vms_spec, outbuf, 0, utf8_fl);
13190
13191                     /* Downcase if input had any lower case letters and
13192                      * case preservation is not in effect.
13193                      */
13194                     if (!decc_efs_case_preserve) {
13195                         for (cp = filespec; *cp; cp++)
13196                             if (islower(*cp)) { haslower = 1; break; }
13197
13198                         if (haslower) __mystrtolower(rslt);
13199                     }
13200                 }
13201         }
13202
13203         Safefree(vms_spec);
13204     }
13205     return rslt;
13206 }
13207
13208 static char *
13209 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13210                    int *utf8_fl)
13211 {
13212     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13213     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13214     int file_len;
13215
13216     /* Fall back to fid_to_name */
13217
13218     sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
13219     if (sts != 0) {
13220         return NULL;
13221     }
13222     else {
13223
13224
13225         /* Now need to trim the version off */
13226         sts = vms_split_path
13227                   (outbuf,
13228                    &v_spec,
13229                    &v_len,
13230                    &r_spec,
13231                    &r_len,
13232                    &d_spec,
13233                    &d_len,
13234                    &n_spec,
13235                    &n_len,
13236                    &e_spec,
13237                    &e_len,
13238                    &vs_spec,
13239                    &vs_len);
13240
13241
13242         if (sts == 0) {
13243             int haslower = 0;
13244             const char *cp;
13245
13246             /* Trim off the version */
13247             int file_len = v_len + r_len + d_len + n_len + e_len;
13248             outbuf[file_len] = 0;
13249
13250             /* Downcase if input had any lower case letters and
13251              * case preservation is not in effect.
13252              */
13253             if (!decc_efs_case_preserve) {
13254                 for (cp = filespec; *cp; cp++)
13255                     if (islower(*cp)) { haslower = 1; break; }
13256
13257                 if (haslower) __mystrtolower(outbuf);
13258             }
13259         }
13260     }
13261     return outbuf;
13262 }
13263
13264
13265 /*}}}*/
13266 /* External entry points */
13267 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13268 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13269
13270 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13271 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13272
13273 /* case_tolerant */
13274
13275 /*{{{int do_vms_case_tolerant(void)*/
13276 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13277  * controlled by a process setting.
13278  */
13279 int do_vms_case_tolerant(void)
13280 {
13281     return vms_process_case_tolerant;
13282 }
13283 /*}}}*/
13284 /* External entry points */
13285 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13286 int Perl_vms_case_tolerant(void)
13287 { return do_vms_case_tolerant(); }
13288 #else
13289 int Perl_vms_case_tolerant(void)
13290 { return vms_process_case_tolerant; }
13291 #endif
13292
13293
13294  /* Start of DECC RTL Feature handling */
13295
13296 static int sys_trnlnm
13297    (const char * logname,
13298     char * value,
13299     int value_len)
13300 {
13301     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
13302     const unsigned long attr = LNM$M_CASE_BLIND;
13303     struct dsc$descriptor_s name_dsc;
13304     int status;
13305     unsigned short result;
13306     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
13307                                 {0, 0, 0, 0}};
13308
13309     name_dsc.dsc$w_length = strlen(logname);
13310     name_dsc.dsc$a_pointer = (char *)logname;
13311     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13312     name_dsc.dsc$b_class = DSC$K_CLASS_S;
13313
13314     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
13315
13316     if ($VMS_STATUS_SUCCESS(status)) {
13317
13318          /* Null terminate and return the string */
13319         /*--------------------------------------*/
13320         value[result] = 0;
13321     }
13322
13323     return status;
13324 }
13325
13326 static int sys_crelnm
13327    (const char * logname,
13328     const char * value)
13329 {
13330     int ret_val;
13331     const char * proc_table = "LNM$PROCESS_TABLE";
13332     struct dsc$descriptor_s proc_table_dsc;
13333     struct dsc$descriptor_s logname_dsc;
13334     struct itmlst_3 item_list[2];
13335
13336     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
13337     proc_table_dsc.dsc$w_length = strlen(proc_table);
13338     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13339     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
13340
13341     logname_dsc.dsc$a_pointer = (char *) logname;
13342     logname_dsc.dsc$w_length = strlen(logname);
13343     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13344     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
13345
13346     item_list[0].buflen = strlen(value);
13347     item_list[0].itmcode = LNM$_STRING;
13348     item_list[0].bufadr = (char *)value;
13349     item_list[0].retlen = NULL;
13350
13351     item_list[1].buflen = 0;
13352     item_list[1].itmcode = 0;
13353
13354     ret_val = sys$crelnm
13355                        (NULL,
13356                         (const struct dsc$descriptor_s *)&proc_table_dsc,
13357                         (const struct dsc$descriptor_s *)&logname_dsc,
13358                         NULL,
13359                         (const struct item_list_3 *) item_list);
13360
13361     return ret_val;
13362 }
13363
13364 /* C RTL Feature settings */
13365
13366 static int set_features
13367    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
13368     int (* cli_routine)(void),  /* Not documented */
13369     void *image_info)           /* Not documented */
13370 {
13371     int status;
13372     int s;
13373     int dflt;
13374     char* str;
13375     char val_str[10];
13376 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13377     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13378     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13379     unsigned long case_perm;
13380     unsigned long case_image;
13381 #endif
13382
13383     /* Allow an exception to bring Perl into the VMS debugger */
13384     vms_debug_on_exception = 0;
13385     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13386     if ($VMS_STATUS_SUCCESS(status)) {
13387        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13388          vms_debug_on_exception = 1;
13389        else
13390          vms_debug_on_exception = 0;
13391     }
13392
13393     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13394     vms_vtf7_filenames = 0;
13395     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13396     if ($VMS_STATUS_SUCCESS(status)) {
13397        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13398          vms_vtf7_filenames = 1;
13399        else
13400          vms_vtf7_filenames = 0;
13401     }
13402
13403
13404     /* unlink all versions on unlink() or rename() */
13405     vms_unlink_all_versions = 0;
13406     status = sys_trnlnm
13407         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13408     if ($VMS_STATUS_SUCCESS(status)) {
13409        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13410          vms_unlink_all_versions = 1;
13411        else
13412          vms_unlink_all_versions = 0;
13413     }
13414
13415     /* Dectect running under GNV Bash or other UNIX like shell */
13416 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13417     gnv_unix_shell = 0;
13418     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13419     if ($VMS_STATUS_SUCCESS(status)) {
13420        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13421          gnv_unix_shell = 1;
13422          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13423          set_feature_default("DECC$EFS_CHARSET", 1);
13424          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13425          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13426          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13427          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13428          vms_unlink_all_versions = 1;
13429        }
13430        else
13431          gnv_unix_shell = 0;
13432     }
13433 #endif
13434
13435     /* hacks to see if known bugs are still present for testing */
13436
13437     /* Readdir is returning filenames in VMS syntax always */
13438     decc_bug_readdir_efs1 = 1;
13439     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
13440     if ($VMS_STATUS_SUCCESS(status)) {
13441        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13442          decc_bug_readdir_efs1 = 1;
13443        else
13444          decc_bug_readdir_efs1 = 0;
13445     }
13446
13447     /* PCP mode requires creating /dev/null special device file */
13448     decc_bug_devnull = 0;
13449     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13450     if ($VMS_STATUS_SUCCESS(status)) {
13451        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13452           decc_bug_devnull = 1;
13453        else
13454           decc_bug_devnull = 0;
13455     }
13456
13457     /* fgetname returning a VMS name in UNIX mode */
13458     decc_bug_fgetname = 1;
13459     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
13460     if ($VMS_STATUS_SUCCESS(status)) {
13461       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13462         decc_bug_fgetname = 1;
13463       else
13464         decc_bug_fgetname = 0;
13465     }
13466
13467     /* UNIX directory names with no paths are broken in a lot of places */
13468     decc_dir_barename = 1;
13469     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13470     if ($VMS_STATUS_SUCCESS(status)) {
13471       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13472         decc_dir_barename = 1;
13473       else
13474         decc_dir_barename = 0;
13475     }
13476
13477 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13478     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13479     if (s >= 0) {
13480         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13481         if (decc_disable_to_vms_logname_translation < 0)
13482             decc_disable_to_vms_logname_translation = 0;
13483     }
13484
13485     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13486     if (s >= 0) {
13487         decc_efs_case_preserve = decc$feature_get_value(s, 1);
13488         if (decc_efs_case_preserve < 0)
13489             decc_efs_case_preserve = 0;
13490     }
13491
13492     s = decc$feature_get_index("DECC$EFS_CHARSET");
13493     if (s >= 0) {
13494         decc_efs_charset = decc$feature_get_value(s, 1);
13495         if (decc_efs_charset < 0)
13496             decc_efs_charset = 0;
13497     }
13498
13499     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13500     if (s >= 0) {
13501         decc_filename_unix_report = decc$feature_get_value(s, 1);
13502         if (decc_filename_unix_report > 0)
13503             decc_filename_unix_report = 1;
13504         else
13505             decc_filename_unix_report = 0;
13506     }
13507
13508     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
13509     if (s >= 0) {
13510         decc_filename_unix_only = decc$feature_get_value(s, 1);
13511         if (decc_filename_unix_only > 0) {
13512             decc_filename_unix_only = 1;
13513         }
13514         else {
13515             decc_filename_unix_only = 0;
13516         }
13517     }
13518
13519     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
13520     if (s >= 0) {
13521         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
13522         if (decc_filename_unix_no_version < 0)
13523             decc_filename_unix_no_version = 0;
13524     }
13525
13526     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
13527     if (s >= 0) {
13528         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
13529         if (decc_readdir_dropdotnotype < 0)
13530             decc_readdir_dropdotnotype = 0;
13531     }
13532
13533     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
13534     if ($VMS_STATUS_SUCCESS(status)) {
13535         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
13536         if (s >= 0) {
13537             dflt = decc$feature_get_value(s, 4);
13538             if (dflt > 0) {
13539                 decc_disable_posix_root = decc$feature_get_value(s, 1);
13540                 if (decc_disable_posix_root <= 0) {
13541                     decc$feature_set_value(s, 1, 1);
13542                     decc_disable_posix_root = 1;
13543                 }
13544             }
13545             else {
13546                 /* Traditionally Perl assumes this is off */
13547                 decc_disable_posix_root = 1;
13548                 decc$feature_set_value(s, 1, 1);
13549             }
13550         }
13551     }
13552
13553 #if __CRTL_VER >= 80200000
13554     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
13555     if (s >= 0) {
13556         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
13557         if (decc_posix_compliant_pathnames < 0)
13558             decc_posix_compliant_pathnames = 0;
13559         if (decc_posix_compliant_pathnames > 4)
13560             decc_posix_compliant_pathnames = 0;
13561     }
13562
13563 #endif
13564 #else
13565     status = sys_trnlnm
13566         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
13567     if ($VMS_STATUS_SUCCESS(status)) {
13568         val_str[0] = _toupper(val_str[0]);
13569         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13570            decc_disable_to_vms_logname_translation = 1;
13571         }
13572     }
13573
13574 #ifndef __VAX
13575     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
13576     if ($VMS_STATUS_SUCCESS(status)) {
13577         val_str[0] = _toupper(val_str[0]);
13578         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13579            decc_efs_case_preserve = 1;
13580         }
13581     }
13582 #endif
13583
13584     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
13585     if ($VMS_STATUS_SUCCESS(status)) {
13586         val_str[0] = _toupper(val_str[0]);
13587         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13588            decc_filename_unix_report = 1;
13589         }
13590     }
13591     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
13592     if ($VMS_STATUS_SUCCESS(status)) {
13593         val_str[0] = _toupper(val_str[0]);
13594         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13595            decc_filename_unix_only = 1;
13596            decc_filename_unix_report = 1;
13597         }
13598     }
13599     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
13600     if ($VMS_STATUS_SUCCESS(status)) {
13601         val_str[0] = _toupper(val_str[0]);
13602         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13603            decc_filename_unix_no_version = 1;
13604         }
13605     }
13606     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
13607     if ($VMS_STATUS_SUCCESS(status)) {
13608         val_str[0] = _toupper(val_str[0]);
13609         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13610            decc_readdir_dropdotnotype = 1;
13611         }
13612     }
13613 #endif
13614
13615 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13616
13617      /* Report true case tolerance */
13618     /*----------------------------*/
13619     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
13620     if (!$VMS_STATUS_SUCCESS(status))
13621         case_perm = PPROP$K_CASE_BLIND;
13622     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
13623     if (!$VMS_STATUS_SUCCESS(status))
13624         case_image = PPROP$K_CASE_BLIND;
13625     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
13626         (case_image == PPROP$K_CASE_SENSITIVE))
13627         vms_process_case_tolerant = 0;
13628
13629 #endif
13630
13631
13632     /* CRTL can be initialized past this point, but not before. */
13633 /*    DECC$CRTL_INIT(); */
13634
13635     return SS$_NORMAL;
13636 }
13637
13638 #ifdef __DECC
13639 #pragma nostandard
13640 #pragma extern_model save
13641 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
13642         const __align (LONGWORD) int spare[8] = {0};
13643
13644 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
13645 #if __DECC_VER >= 60560002
13646 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
13647 #else
13648 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
13649 #endif
13650 #endif /* __DECC */
13651
13652 const long vms_cc_features = (const long)set_features;
13653
13654 /*
13655 ** Force a reference to LIB$INITIALIZE to ensure it
13656 ** exists in the image.
13657 */
13658 int lib$initialize(void);
13659 #ifdef __DECC
13660 #pragma extern_model strict_refdef
13661 #endif
13662     int lib_init_ref = (int) lib$initialize;
13663
13664 #ifdef __DECC
13665 #pragma extern_model restore
13666 #pragma standard
13667 #endif
13668
13669 /*  End of vms.c */