vms/vms.c

   1 /* vms.c
   2  *
   3  * VMS-specific routines for perl5
   4  * Version: 5.7.0
   5  *
   6  * August 2005 Convert VMS status code to UNIX status codes
   7  * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
   8  *             and Perl_cando by Craig Berry
   9  * 29-Aug-2000 Charles Lane's piping improvements rolled in
  10  * 20-Aug-1999 revisions by Charles Bailey  bailey@newman.upenn.edu
  11  */
  12
  13 #include <acedef.h>
  14 #include <acldef.h>
  15 #include <armdef.h>
  16 #include <atrdef.h>
  17 #include <chpdef.h>
  18 #include <clidef.h>
  19 #include <climsgdef.h>
  20 #include <dcdef.h>
  21 #include <descrip.h>
  22 #include <devdef.h>
  23 #include <dvidef.h>
  24 #include <fibdef.h>
  25 #include <float.h>
  26 #include <fscndef.h>
  27 #include <iodef.h>
  28 #include <jpidef.h>
  29 #include <kgbdef.h>
  30 #include <libclidef.h>
  31 #include <libdef.h>
  32 #include <lib$routines.h>
  33 #include <lnmdef.h>
  34 #include <msgdef.h>
  35 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  36 #include <ppropdef.h>
  37 #endif
  38 #include <prvdef.h>
  39 #include <psldef.h>
  40 #include <rms.h>
  41 #include <shrdef.h>
  42 #include <ssdef.h>
  43 #include <starlet.h>
  44 #include <strdef.h>
  45 #include <str$routines.h>
  46 #include <syidef.h>
  47 #include <uaidef.h>
  48 #include <uicdef.h>
  49 #include <stsdef.h>
  50 #include <rmsdef.h>
  51 #include <smgdef.h>
  52 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
  53 #include <efndef.h>
  54 #define NO_EFN EFN$C_ENF
  55 #else
  56 #define NO_EFN 0;
  57 #endif
  58
  59 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  60 int   decc$feature_get_index(const char *name);
  61 char* decc$feature_get_name(int index);
  62 int   decc$feature_get_value(int index, int mode);
  63 int   decc$feature_set_value(int index, int mode, int value);
  64 #else
  65 #include <unixlib.h>
  66 #endif
  67
  68 #pragma member_alignment save
  69 #pragma nomember_alignment longword
  70 struct item_list_3 {
  71         unsigned short len;
  72         unsigned short code;
  73         void * bufadr;
  74         unsigned short * retadr;
  75 };
  76 #pragma member_alignment restore
  77
  78 /* More specific prototype than in starlet_c.h makes programming errors
  79    more visible.
  80  */
  81 #ifdef sys$getdviw
  82 #undef sys$getdviw
  83 int sys$getdviw
  84        (unsigned long efn,
  85         unsigned short chan,
  86         const struct dsc$descriptor_s * devnam,
  87         const struct item_list_3 * itmlst,
  88         void * iosb,
  89         void * (astadr)(unsigned long),
  90         void * astprm,
  91         void * nullarg);
  92 #endif
  93
  94 #ifdef lib$find_image_symbol
  95 #undef lib$find_image_symbol
  96 int lib$find_image_symbol
  97        (const struct dsc$descriptor_s * imgname,
  98         const struct dsc$descriptor_s * symname,
  99         void * symval,
 100         const struct dsc$descriptor_s * defspec,
 101         unsigned long flag);
 102
 103 #endif
 104
 105 #if __CRTL_VER >= 70300000 && !defined(__VAX)
 106
 107 static int set_feature_default(const char *name, int value)
 108 {
 109     int status;
 110     int index;
 111
 112     index = decc$feature_get_index(name);
 113
 114     status = decc$feature_set_value(index, 1, value);
 115     if (index == -1 || (status == -1)) {
 116       return -1;
 117     }
 118
 119     status = decc$feature_get_value(index, 1);
 120     if (status != value) {
 121       return -1;
 122     }
 123
 124 return 0;
 125 }
 126 #endif
 127
 128 /* Older versions of ssdef.h don't have these */
 129 #ifndef SS$_INVFILFOROP
 130 #  define SS$_INVFILFOROP 3930
 131 #endif
 132 #ifndef SS$_NOSUCHOBJECT
 133 #  define SS$_NOSUCHOBJECT 2696
 134 #endif
 135
 136 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 137 #define PERLIO_NOT_STDIO 0
 138
 139 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 140  * code below needs to get to the underlying CRTL routines. */
 141 #define DONT_MASK_RTL_CALLS
 142 #include "EXTERN.h"
 143 #include "perl.h"
 144 #include "XSUB.h"
 145 /* Anticipating future expansion in lexical warnings . . . */
 146 #ifndef WARN_INTERNAL
 147 #  define WARN_INTERNAL WARN_MISC
 148 #endif
 149
 150 #ifdef VMS_LONGNAME_SUPPORT
 151 #include <libfildef.h>
 152 #endif
 153
 154 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 155 #  define RTL_USES_UTC 1
 156 #endif
 157
 158 /* Routine to create a decterm for use with the Perl debugger */
 159 /* No headers, this information was found in the Programming Concepts Manual */
 160
 161 static int (*decw_term_port)
 162    (const struct dsc$descriptor_s * display,
 163     const struct dsc$descriptor_s * setup_file,
 164     const struct dsc$descriptor_s * customization,
 165     struct dsc$descriptor_s * result_device_name,
 166     unsigned short * result_device_name_length,
 167     void * controller,
 168     void * char_buffer,
 169     void * char_change_buffer) = 0;
 170
 171 /* gcc's header files don't #define direct access macros
 172  * corresponding to VAXC's variant structs */
 173 #ifdef __GNUC__
 174 #  define uic$v_format uic$r_uic_form.uic$v_format
 175 #  define uic$v_group uic$r_uic_form.uic$v_group
 176 #  define uic$v_member uic$r_uic_form.uic$v_member
 177 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 178 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 179 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 180 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 181 #endif
 182
 183 #if defined(NEED_AN_H_ERRNO)
 184 dEXT int h_errno;
 185 #endif
 186
 187 #ifdef __DECC
 188 #pragma message disable pragma
 189 #pragma member_alignment save
 190 #pragma nomember_alignment longword
 191 #pragma message save
 192 #pragma message disable misalgndmem
 193 #endif
 194 struct itmlst_3 {
 195   unsigned short int buflen;
 196   unsigned short int itmcode;
 197   void *bufadr;
 198   unsigned short int *retlen;
 199 };
 200
 201 struct filescan_itmlst_2 {
 202     unsigned short length;
 203     unsigned short itmcode;
 204     char * component;
 205 };
 206
 207 struct vs_str_st {
 208     unsigned short length;
 209     char str[65536];
 210 };
 211
 212 #ifdef __DECC
 213 #pragma message restore
 214 #pragma member_alignment restore
 215 #endif
 216
 217 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 218 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 219 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 220 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 221 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 222 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 223 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 224 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 225 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 226 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 227 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 228
 229 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 230 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 231 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 232 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 233
 234 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 235 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 236
 237 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 238  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 239  * the Perl facility.
 240  */
 241 #define PERL_LNM_MAX_ITER 10
 242
 243   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 244 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 245 #define MAX_DCL_SYMBOL          (8192)
 246 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 247 #else
 248 #define MAX_DCL_SYMBOL          (1024)
 249 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 250 #endif
 251
 252 static char *__mystrtolower(char *str)
 253 {
 254   if (str) for (; *str; ++str) *str= tolower(*str);
 255   return str;
 256 }
 257
 258 static struct dsc$descriptor_s fildevdsc =
 259   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 260 static struct dsc$descriptor_s crtlenvdsc =
 261   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 262 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 263 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 264 static struct dsc$descriptor_s **env_tables = defenv;
 265 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 266
 267 /* True if we shouldn't treat barewords as logicals during directory */
 268 /* munching */
 269 static int no_translate_barewords;
 270
 271 #ifndef RTL_USES_UTC
 272 static int tz_updated = 1;
 273 #endif
 274
 275 /* DECC Features that may need to affect how Perl interprets
 276  * displays filename information
 277  */
 278 static int decc_disable_to_vms_logname_translation = 1;
 279 static int decc_disable_posix_root = 1;
 280 int decc_efs_case_preserve = 0;
 281 static int decc_efs_charset = 0;
 282 static int decc_filename_unix_no_version = 0;
 283 static int decc_filename_unix_only = 0;
 284 int decc_filename_unix_report = 0;
 285 int decc_posix_compliant_pathnames = 0;
 286 int decc_readdir_dropdotnotype = 0;
 287 static int vms_process_case_tolerant = 1;
 288 int vms_vtf7_filenames = 0;
 289 int gnv_unix_shell = 0;
 290
 291 /* bug workarounds if needed */
 292 int decc_bug_readdir_efs1 = 0;
 293 int decc_bug_devnull = 1;
 294 int decc_bug_fgetname = 0;
 295 int decc_dir_barename = 0;
 296
 297 static int vms_debug_on_exception = 0;
 298
 299 /* Is this a UNIX file specification?
 300  *   No longer a simple check with EFS file specs
 301  *   For now, not a full check, but need to
 302  *   handle POSIX ^UP^ specifications
 303  *   Fixing to handle ^/ cases would require
 304  *   changes to many other conversion routines.
 305  */
 306
 307 static int is_unix_filespec(const char *path)
 308 {
 309 int ret_val;
 310 const char * pch1;
 311
 312     ret_val = 0;
 313     if (strncmp(path,"\"^UP^",5) != 0) {
 314         pch1 = strchr(path, '/');
 315         if (pch1 != NULL)
 316             ret_val = 1;
 317         else {
 318
 319             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 320             if (decc_filename_unix_report || decc_filename_unix_only) {
 321             if (strcmp(path,".") == 0)
 322                 ret_val = 1;
 323             }
 324         }
 325     }
 326     return ret_val;
 327 }
 328
 329 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 330  */
 331
 332 static void ucs2_to_vtf7
 333    (char *outspec,
 334     unsigned long ucs2_char,
 335     int * output_cnt)
 336 {
 337 unsigned char * ucs_ptr;
 338 int hex;
 339
 340     ucs_ptr = (unsigned char *)&ucs2_char;
 341
 342     outspec[0] = '^';
 343     outspec[1] = 'U';
 344     hex = (ucs_ptr[1] >> 4) & 0xf;
 345     if (hex < 0xA)
 346         outspec[2] = hex + '0';
 347     else
 348         outspec[2] = (hex - 9) + 'A';
 349     hex = ucs_ptr[1] & 0xF;
 350     if (hex < 0xA)
 351         outspec[3] = hex + '0';
 352     else {
 353         outspec[3] = (hex - 9) + 'A';
 354     }
 355     hex = (ucs_ptr[0] >> 4) & 0xf;
 356     if (hex < 0xA)
 357         outspec[4] = hex + '0';
 358     else
 359         outspec[4] = (hex - 9) + 'A';
 360     hex = ucs_ptr[1] & 0xF;
 361     if (hex < 0xA)
 362         outspec[5] = hex + '0';
 363     else {
 364         outspec[5] = (hex - 9) + 'A';
 365     }
 366     *output_cnt = 6;
 367 }
 368
 369
 370 /* This handles the conversion of a UNIX extended character set to a ^
 371  * escaped VMS character.
 372  * in a UNIX file specification.
 373  *
 374  * The output count variable contains the number of characters added
 375  * to the output string.
 376  *
 377  * The return value is the number of characters read from the input string
 378  */
 379 static int copy_expand_unix_filename_escape
 380   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 381 {
 382 int count;
 383 int scnt;
 384 int utf8_flag;
 385
 386     utf8_flag = 0;
 387     if (utf8_fl)
 388       utf8_flag = *utf8_fl;
 389
 390     count = 0;
 391     *output_cnt = 0;
 392     if (*inspec >= 0x80) {
 393         if (utf8_fl && vms_vtf7_filenames) {
 394         unsigned long ucs_char;
 395
 396             ucs_char = 0;
 397
 398             if ((*inspec & 0xE0) == 0xC0) {
 399                 /* 2 byte Unicode */
 400                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 401                 if (ucs_char >= 0x80) {
 402                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 403                     return 2;
 404                 }
 405             } else if ((*inspec & 0xF0) == 0xE0) {
 406                 /* 3 byte Unicode */
 407                 ucs_char = ((inspec[0] & 0xF) << 12) +
 408                    ((inspec[1] & 0x3f) << 6) +
 409                    (inspec[2] & 0x3f);
 410                 if (ucs_char >= 0x800) {
 411                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 412                     return 3;
 413                 }
 414
 415 #if 0 /* I do not see longer sequences supported by OpenVMS */
 416       /* Maybe some one can fix this later */
 417             } else if ((*inspec & 0xF8) == 0xF0) {
 418                 /* 4 byte Unicode */
 419                 /* UCS-4 to UCS-2 */
 420             } else if ((*inspec & 0xFC) == 0xF8) {
 421                 /* 5 byte Unicode */
 422                 /* UCS-4 to UCS-2 */
 423             } else if ((*inspec & 0xFE) == 0xFC) {
 424                 /* 6 byte Unicode */
 425                 /* UCS-4 to UCS-2 */
 426 #endif
 427             }
 428         }
 429
 430         /* High bit set, but not a Unicode character! */
 431
 432         /* Non printing DECMCS or ISO Latin-1 character? */
 433         if (*inspec <= 0x9F) {
 434         int hex;
 435             outspec[0] = '^';
 436             outspec++;
 437             hex = (*inspec >> 4) & 0xF;
 438             if (hex < 0xA)
 439                 outspec[1] = hex + '0';
 440             else {
 441                 outspec[1] = (hex - 9) + 'A';
 442             }
 443             hex = *inspec & 0xF;
 444             if (hex < 0xA)
 445                 outspec[2] = hex + '0';
 446             else {
 447                 outspec[2] = (hex - 9) + 'A';
 448             }
 449             *output_cnt = 3;
 450             return 1;
 451         } else if (*inspec == 0xA0) {
 452             outspec[0] = '^';
 453             outspec[1] = 'A';
 454             outspec[2] = '0';
 455             *output_cnt = 3;
 456             return 1;
 457         } else if (*inspec == 0xFF) {
 458             outspec[0] = '^';
 459             outspec[1] = 'F';
 460             outspec[2] = 'F';
 461             *output_cnt = 3;
 462             return 1;
 463         }
 464         *outspec = *inspec;
 465         *output_cnt = 1;
 466         return 1;
 467     }
 468
 469     /* Is this a macro that needs to be passed through?
 470      * Macros start with $( and an alpha character, followed
 471      * by a string of alpha numeric characters ending with a )
 472      * If this does not match, then encode it as ODS-5.
 473      */
 474     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 475     int tcnt;
 476
 477         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 478             tcnt = 3;
 479             outspec[0] = inspec[0];
 480             outspec[1] = inspec[1];
 481             outspec[2] = inspec[2];
 482
 483             while(isalnum(inspec[tcnt]) ||
 484                   (inspec[2] == '.') || (inspec[2] == '_')) {
 485                 outspec[tcnt] = inspec[tcnt];
 486                 tcnt++;
 487             }
 488             if (inspec[tcnt] == ')') {
 489                 outspec[tcnt] = inspec[tcnt];
 490                 tcnt++;
 491                 *output_cnt = tcnt;
 492                 return tcnt;
 493             }
 494         }
 495     }
 496
 497     switch (*inspec) {
 498     case 0x7f:
 499         outspec[0] = '^';
 500         outspec[1] = '7';
 501         outspec[2] = 'F';
 502         *output_cnt = 3;
 503         return 1;
 504         break;
 505     case '?':
 506         if (decc_efs_charset == 0)
 507           outspec[0] = '%';
 508         else
 509           outspec[0] = '?';
 510         *output_cnt = 1;
 511         return 1;
 512         break;
 513     case '.':
 514     case '~':
 515     case '!':
 516     case '#':
 517     case '&':
 518     case '\'':
 519     case '`':
 520     case '(':
 521     case ')':
 522     case '+':
 523     case '@':
 524     case '{':
 525     case '}':
 526     case ',':
 527     case ';':
 528     case '[':
 529     case ']':
 530     case '%':
 531     case '^':
 532         /* Don't escape again if following character is
 533          * already something we escape.
 534          */
 535         if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
 536             *outspec = *inspec;
 537             *output_cnt = 1;
 538             return 1;
 539             break;
 540         }
 541         /* But otherwise fall through and escape it. */
 542     case '=':
 543         /* Assume that this is to be escaped */
 544         outspec[0] = '^';
 545         outspec[1] = *inspec;
 546         *output_cnt = 2;
 547         return 1;
 548         break;
 549     case ' ': /* space */
 550         /* Assume that this is to be escaped */
 551         outspec[0] = '^';
 552         outspec[1] = '_';
 553         *output_cnt = 2;
 554         return 1;
 555         break;
 556     default:
 557         *outspec = *inspec;
 558         *output_cnt = 1;
 559         return 1;
 560         break;
 561     }
 562 }
 563
 564
 565 /* This handles the expansion of a '^' prefix to the proper character
 566  * in a UNIX file specification.
 567  *
 568  * The output count variable contains the number of characters added
 569  * to the output string.
 570  *
 571  * The return value is the number of characters read from the input
 572  * string
 573  */
 574 static int copy_expand_vms_filename_escape
 575   (char *outspec, const char *inspec, int *output_cnt)
 576 {
 577 int count;
 578 int scnt;
 579
 580     count = 0;
 581     *output_cnt = 0;
 582     if (*inspec == '^') {
 583         inspec++;
 584         switch (*inspec) {
 585         /* Spaces and non-trailing dots should just be passed through,
 586          * but eat the escape character.
 587          */
 588         case '.':
 589             *outspec = *inspec;
 590             count += 2;
 591             (*output_cnt)++;
 592             break;
 593         case '_': /* space */
 594             *outspec = ' ';
 595             count += 2;
 596             (*output_cnt)++;
 597             break;
 598         case '^':
 599             /* Hmm.  Better leave the escape escaped. */
 600             outspec[0] = '^';
 601             outspec[1] = '^';
 602             count += 2;
 603             (*output_cnt) += 2;
 604             break;
 605         case 'U': /* Unicode - FIX-ME this is wrong. */
 606             inspec++;
 607             count++;
 608             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 609             if (scnt == 4) {
 610                 unsigned int c1, c2;
 611                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 612                 outspec[0] == c1 & 0xff;
 613                 outspec[1] == c2 & 0xff;
 614                 if (scnt > 1) {
 615                     (*output_cnt) += 2;
 616                     count += 4;
 617                 }
 618             }
 619             else {
 620                 /* Error - do best we can to continue */
 621                 *outspec = 'U';
 622                 outspec++;
 623                 (*output_cnt++);
 624                 *outspec = *inspec;
 625                 count++;
 626                 (*output_cnt++);
 627             }
 628             break;
 629         default:
 630             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 631             if (scnt == 2) {
 632                 /* Hex encoded */
 633                 unsigned int c1;
 634                 scnt = sscanf(inspec, "%2x", &c1);
 635                 outspec[0] = c1 & 0xff;
 636                 if (scnt > 0) {
 637                     (*output_cnt++);
 638                     count += 2;
 639                 }
 640             }
 641             else {
 642                 *outspec = *inspec;
 643                 count++;
 644                 (*output_cnt++);
 645             }
 646         }
 647     }
 648     else {
 649         *outspec = *inspec;
 650         count++;
 651         (*output_cnt)++;
 652     }
 653     return count;
 654 }
 655
 656 #ifdef sys$filescan
 657 #undef sys$filescan
 658 int sys$filescan
 659    (const struct dsc$descriptor_s * srcstr,
 660     struct filescan_itmlst_2 * valuelist,
 661     unsigned long * fldflags,
 662     struct dsc$descriptor_s *auxout,
 663     unsigned short * retlen);
 664 #endif
 665
 666 /* vms_split_path - Verify that the input file specification is a
 667  * VMS format file specification, and provide pointers to the components of
 668  * it.  With EFS format filenames, this is virtually the only way to
 669  * parse a VMS path specification into components.
 670  *
 671  * If the sum of the components do not add up to the length of the
 672  * string, then the passed file specification is probably a UNIX style
 673  * path.
 674  */
 675 static int vms_split_path
 676    (const char * path,
 677     char * * volume,
 678     int * vol_len,
 679     char * * root,
 680     int * root_len,
 681     char * * dir,
 682     int * dir_len,
 683     char * * name,
 684     int * name_len,
 685     char * * ext,
 686     int * ext_len,
 687     char * * version,
 688     int * ver_len)
 689 {
 690 struct dsc$descriptor path_desc;
 691 int status;
 692 unsigned long flags;
 693 int ret_stat;
 694 struct filescan_itmlst_2 item_list[9];
 695 const int filespec = 0;
 696 const int nodespec = 1;
 697 const int devspec = 2;
 698 const int rootspec = 3;
 699 const int dirspec = 4;
 700 const int namespec = 5;
 701 const int typespec = 6;
 702 const int verspec = 7;
 703
 704     /* Assume the worst for an easy exit */
 705     ret_stat = -1;
 706     *volume = NULL;
 707     *vol_len = 0;
 708     *root = NULL;
 709     *root_len = 0;
 710     *dir = NULL;
 711     *dir_len;
 712     *name = NULL;
 713     *name_len = 0;
 714     *ext = NULL;
 715     *ext_len = 0;
 716     *version = NULL;
 717     *ver_len = 0;
 718
 719     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 720     path_desc.dsc$w_length = strlen(path);
 721     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 722     path_desc.dsc$b_class = DSC$K_CLASS_S;
 723
 724     /* Get the total length, if it is shorter than the string passed
 725      * then this was probably not a VMS formatted file specification
 726      */
 727     item_list[filespec].itmcode = FSCN$_FILESPEC;
 728     item_list[filespec].length = 0;
 729     item_list[filespec].component = NULL;
 730
 731     /* If the node is present, then it gets considered as part of the
 732      * volume name to hopefully make things simple.
 733      */
 734     item_list[nodespec].itmcode = FSCN$_NODE;
 735     item_list[nodespec].length = 0;
 736     item_list[nodespec].component = NULL;
 737
 738     item_list[devspec].itmcode = FSCN$_DEVICE;
 739     item_list[devspec].length = 0;
 740     item_list[devspec].component = NULL;
 741
 742     /* root is a special case,  adding it to either the directory or
 743      * the device components will probalby complicate things for the
 744      * callers of this routine, so leave it separate.
 745      */
 746     item_list[rootspec].itmcode = FSCN$_ROOT;
 747     item_list[rootspec].length = 0;
 748     item_list[rootspec].component = NULL;
 749
 750     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 751     item_list[dirspec].length = 0;
 752     item_list[dirspec].component = NULL;
 753
 754     item_list[namespec].itmcode = FSCN$_NAME;
 755     item_list[namespec].length = 0;
 756     item_list[namespec].component = NULL;
 757
 758     item_list[typespec].itmcode = FSCN$_TYPE;
 759     item_list[typespec].length = 0;
 760     item_list[typespec].component = NULL;
 761
 762     item_list[verspec].itmcode = FSCN$_VERSION;
 763     item_list[verspec].length = 0;
 764     item_list[verspec].component = NULL;
 765
 766     item_list[8].itmcode = 0;
 767     item_list[8].length = 0;
 768     item_list[8].component = NULL;
 769
 770     status = sys$filescan
 771        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 772         &flags, NULL, NULL);
 773     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 774
 775     /* If we parsed it successfully these two lengths should be the same */
 776     if (path_desc.dsc$w_length != item_list[filespec].length)
 777         return ret_stat;
 778
 779     /* If we got here, then it is a VMS file specification */
 780     ret_stat = 0;
 781
 782     /* set the volume name */
 783     if (item_list[nodespec].length > 0) {
 784         *volume = item_list[nodespec].component;
 785         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 786     }
 787     else {
 788         *volume = item_list[devspec].component;
 789         *vol_len = item_list[devspec].length;
 790     }
 791
 792     *root = item_list[rootspec].component;
 793     *root_len = item_list[rootspec].length;
 794
 795     *dir = item_list[dirspec].component;
 796     *dir_len = item_list[dirspec].length;
 797
 798     /* Now fun with versions and EFS file specifications
 799      * The parser can not tell the difference when a "." is a version
 800      * delimiter or a part of the file specification.
 801      */
 802     if ((decc_efs_charset) &&
 803         (item_list[verspec].length > 0) &&
 804         (item_list[verspec].component[0] == '.')) {
 805         *name = item_list[namespec].component;
 806         *name_len = item_list[namespec].length + item_list[typespec].length;
 807         *ext = item_list[verspec].component;
 808         *ext_len = item_list[verspec].length;
 809         *version = NULL;
 810         *ver_len = 0;
 811     }
 812     else {
 813         *name = item_list[namespec].component;
 814         *name_len = item_list[namespec].length;
 815         *ext = item_list[typespec].component;
 816         *ext_len = item_list[typespec].length;
 817         *version = item_list[verspec].component;
 818         *ver_len = item_list[verspec].length;
 819     }
 820     return ret_stat;
 821 }
 822
 823
 824 /* my_maxidx
 825  * Routine to retrieve the maximum equivalence index for an input
 826  * logical name.  Some calls to this routine have no knowledge if
 827  * the variable is a logical or not.  So on error we return a max
 828  * index of zero.
 829  */
 830 /*{{{int my_maxidx(const char *lnm) */
 831 static int
 832 my_maxidx(const char *lnm)
 833 {
 834     int status;
 835     int midx;
 836     int attr = LNM$M_CASE_BLIND;
 837     struct dsc$descriptor lnmdsc;
 838     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 839                                 {0, 0, 0, 0}};
 840
 841     lnmdsc.dsc$w_length = strlen(lnm);
 842     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 843     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 844     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 845
 846     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 847     if ((status & 1) == 0)
 848        midx = 0;
 849
 850     return (midx);
 851 }
 852 /*}}}*/
 853
 854 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 855 int
 856 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 857   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 858 {
 859     const char *cp1;
 860     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 861     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 862     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 863     int midx;
 864     unsigned char acmode;
 865     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 866                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 867     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 868                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 869                                  {0, 0, 0, 0}};
 870     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 871 #if defined(PERL_IMPLICIT_CONTEXT)
 872     pTHX = NULL;
 873     if (PL_curinterp) {
 874       aTHX = PERL_GET_INTERP;
 875     } else {
 876       aTHX = NULL;
 877     }
 878 #endif
 879
 880     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 881       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 882     }
 883     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 884       *cp2 = _toupper(*cp1);
 885       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 886         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 887         return 0;
 888       }
 889     }
 890     lnmdsc.dsc$w_length = cp1 - lnm;
 891     lnmdsc.dsc$a_pointer = uplnm;
 892     uplnm[lnmdsc.dsc$w_length] = '\0';
 893     secure = flags & PERL__TRNENV_SECURE;
 894     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 895     if (!tabvec || !*tabvec) tabvec = env_tables;
 896
 897     for (curtab = 0; tabvec[curtab]; curtab++) {
 898       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 899         if (!ivenv && !secure) {
 900           char *eq, *end;
 901           int i;
 902           if (!environ) {
 903             ivenv = 1;
 904             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 905             continue;
 906           }
 907           retsts = SS$_NOLOGNAM;
 908           for (i = 0; environ[i]; i++) {
 909             if ((eq = strchr(environ[i],'=')) &&
 910                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 911                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 912               eq++;
 913               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 914               if (!eqvlen) continue;
 915               retsts = SS$_NORMAL;
 916               break;
 917             }
 918           }
 919           if (retsts != SS$_NOLOGNAM) break;
 920         }
 921       }
 922       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 923                !str$case_blind_compare(&tmpdsc,&clisym)) {
 924         if (!ivsym && !secure) {
 925           unsigned short int deflen = LNM$C_NAMLENGTH;
 926           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 927           /* dynamic dsc to accomodate possible long value */
 928           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 929           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 930           if (retsts & 1) {
 931             if (eqvlen > MAX_DCL_SYMBOL) {
 932               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 933               eqvlen = MAX_DCL_SYMBOL;
 934               /* Special hack--we might be called before the interpreter's */
 935               /* fully initialized, in which case either thr or PL_curcop */
 936               /* might be bogus. We have to check, since ckWARN needs them */
 937               /* both to be valid if running threaded */
 938                 if (ckWARN(WARN_MISC)) {
 939                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 940                 }
 941             }
 942             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 943           }
 944           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 945           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 946           if (retsts == LIB$_NOSUCHSYM) continue;
 947           break;
 948         }
 949       }
 950       else if (!ivlnm) {
 951         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 952           midx = my_maxidx(lnm);
 953           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 954             lnmlst[1].bufadr = cp2;
 955             eqvlen = 0;
 956             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 957             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 958             if (retsts == SS$_NOLOGNAM) break;
 959             /* PPFs have a prefix */
 960             if (
 961 #if INTSIZE == 4
 962                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 963 #endif
 964                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 965                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 966                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 967                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 968                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 969               memmove(eqv,eqv+4,eqvlen-4);
 970               eqvlen -= 4;
 971             }
 972             cp2 += eqvlen;
 973             *cp2 = '\0';
 974           }
 975           if ((retsts == SS$_IVLOGNAM) ||
 976               (retsts == SS$_NOLOGNAM)) { continue; }
 977         }
 978         else {
 979           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 980           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 981           if (retsts == SS$_NOLOGNAM) continue;
 982           eqv[eqvlen] = '\0';
 983         }
 984         eqvlen = strlen(eqv);
 985         break;
 986       }
 987     }
 988     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 989     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 990              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 991              retsts == SS$_NOLOGNAM) {
 992       set_errno(EINVAL);  set_vaxc_errno(retsts);
 993     }
 994     else _ckvmssts(retsts);
 995     return 0;
 996 }  /* end of vmstrnenv */
 997 /*}}}*/
 998
 999 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1000 /* Define as a function so we can access statics. */
1001 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1002 {
1003   return vmstrnenv(lnm,eqv,idx,fildev,
1004 #ifdef SECURE_INTERNAL_GETENV
1005                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
1006 #else
1007                    0
1008 #endif
1009                                                                               );
1010 }
1011 /*}}}*/
1012
1013 /* my_getenv
1014  * Note: Uses Perl temp to store result so char * can be returned to
1015  * caller; this pointer will be invalidated at next Perl statement
1016  * transition.
1017  * We define this as a function rather than a macro in terms of my_getenv_len()
1018  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1019  * allocate SVs).
1020  */
1021 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1022 char *
1023 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1024 {
1025     const char *cp1;
1026     static char *__my_getenv_eqv = NULL;
1027     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1028     unsigned long int idx = 0;
1029     int trnsuccess, success, secure, saverr, savvmserr;
1030     int midx, flags;
1031     SV *tmpsv;
1032
1033     midx = my_maxidx(lnm) + 1;
1034
1035     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1036       /* Set up a temporary buffer for the return value; Perl will
1037        * clean it up at the next statement transition */
1038       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1039       if (!tmpsv) return NULL;
1040       eqv = SvPVX(tmpsv);
1041     }
1042     else {
1043       /* Assume no interpreter ==> single thread */
1044       if (__my_getenv_eqv != NULL) {
1045         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1046       }
1047       else {
1048         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1049       }
1050       eqv = __my_getenv_eqv;
1051     }
1052
1053     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1054     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1055       int len;
1056       getcwd(eqv,LNM$C_NAMLENGTH);
1057
1058       len = strlen(eqv);
1059
1060       /* Get rid of "000000/ in rooted filespecs */
1061       if (len > 7) {
1062         char * zeros;
1063         zeros = strstr(eqv, "/000000/");
1064         if (zeros != NULL) {
1065           int mlen;
1066           mlen = len - (zeros - eqv) - 7;
1067           memmove(zeros, &zeros[7], mlen);
1068           len = len - 7;
1069           eqv[len] = '\0';
1070         }
1071       }
1072       return eqv;
1073     }
1074     else {
1075       /* Impose security constraints only if tainting */
1076       if (sys) {
1077         /* Impose security constraints only if tainting */
1078         secure = PL_curinterp ? PL_tainting : will_taint;
1079         saverr = errno;  savvmserr = vaxc$errno;
1080       }
1081       else {
1082         secure = 0;
1083       }
1084
1085       flags =
1086 #ifdef SECURE_INTERNAL_GETENV
1087               secure ? PERL__TRNENV_SECURE : 0
1088 #else
1089               0
1090 #endif
1091       ;
1092
1093       /* For the getenv interface we combine all the equivalence names
1094        * of a search list logical into one value to acquire a maximum
1095        * value length of 255*128 (assuming %ENV is using logicals).
1096        */
1097       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1098
1099       /* If the name contains a semicolon-delimited index, parse it
1100        * off and make sure we only retrieve the equivalence name for
1101        * that index.  */
1102       if ((cp2 = strchr(lnm,';')) != NULL) {
1103         strcpy(uplnm,lnm);
1104         uplnm[cp2-lnm] = '\0';
1105         idx = strtoul(cp2+1,NULL,0);
1106         lnm = uplnm;
1107         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1108       }
1109
1110       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1111
1112       /* Discard NOLOGNAM on internal calls since we're often looking
1113        * for an optional name, and this "error" often shows up as the
1114        * (bogus) exit status for a die() call later on.  */
1115       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1116       return success ? eqv : Nullch;
1117     }
1118
1119 }  /* end of my_getenv() */
1120 /*}}}*/
1121
1122
1123 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1124 char *
1125 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1126 {
1127     const char *cp1;
1128     char *buf, *cp2;
1129     unsigned long idx = 0;
1130     int midx, flags;
1131     static char *__my_getenv_len_eqv = NULL;
1132     int secure, saverr, savvmserr;
1133     SV *tmpsv;
1134
1135     midx = my_maxidx(lnm) + 1;
1136
1137     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1138       /* Set up a temporary buffer for the return value; Perl will
1139        * clean it up at the next statement transition */
1140       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1141       if (!tmpsv) return NULL;
1142       buf = SvPVX(tmpsv);
1143     }
1144     else {
1145       /* Assume no interpreter ==> single thread */
1146       if (__my_getenv_len_eqv != NULL) {
1147         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1148       }
1149       else {
1150         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1151       }
1152       buf = __my_getenv_len_eqv;
1153     }
1154
1155     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1156     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1157     char * zeros;
1158
1159       getcwd(buf,LNM$C_NAMLENGTH);
1160       *len = strlen(buf);
1161
1162       /* Get rid of "000000/ in rooted filespecs */
1163       if (*len > 7) {
1164       zeros = strstr(buf, "/000000/");
1165       if (zeros != NULL) {
1166         int mlen;
1167         mlen = *len - (zeros - buf) - 7;
1168         memmove(zeros, &zeros[7], mlen);
1169         *len = *len - 7;
1170         buf[*len] = '\0';
1171         }
1172       }
1173       return buf;
1174     }
1175     else {
1176       if (sys) {
1177         /* Impose security constraints only if tainting */
1178         secure = PL_curinterp ? PL_tainting : will_taint;
1179         saverr = errno;  savvmserr = vaxc$errno;
1180       }
1181       else {
1182         secure = 0;
1183       }
1184
1185       flags =
1186 #ifdef SECURE_INTERNAL_GETENV
1187               secure ? PERL__TRNENV_SECURE : 0
1188 #else
1189               0
1190 #endif
1191       ;
1192
1193       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1194
1195       if ((cp2 = strchr(lnm,';')) != NULL) {
1196         strcpy(buf,lnm);
1197         buf[cp2-lnm] = '\0';
1198         idx = strtoul(cp2+1,NULL,0);
1199         lnm = buf;
1200         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1201       }
1202
1203       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1204
1205       /* Get rid of "000000/ in rooted filespecs */
1206       if (*len > 7) {
1207       char * zeros;
1208         zeros = strstr(buf, "/000000/");
1209         if (zeros != NULL) {
1210           int mlen;
1211           mlen = *len - (zeros - buf) - 7;
1212           memmove(zeros, &zeros[7], mlen);
1213           *len = *len - 7;
1214           buf[*len] = '\0';
1215         }
1216       }
1217
1218       /* Discard NOLOGNAM on internal calls since we're often looking
1219        * for an optional name, and this "error" often shows up as the
1220        * (bogus) exit status for a die() call later on.  */
1221       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1222       return *len ? buf : Nullch;
1223     }
1224
1225 }  /* end of my_getenv_len() */
1226 /*}}}*/
1227
1228 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1229
1230 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1231
1232 /*{{{ void prime_env_iter() */
1233 void
1234 prime_env_iter(void)
1235 /* Fill the %ENV associative array with all logical names we can
1236  * find, in preparation for iterating over it.
1237  */
1238 {
1239   static int primed = 0;
1240   HV *seenhv = NULL, *envhv;
1241   SV *sv = NULL;
1242   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1243   unsigned short int chan;
1244 #ifndef CLI$M_TRUSTED
1245 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1246 #endif
1247   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1248   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1249   long int i;
1250   bool have_sym = FALSE, have_lnm = FALSE;
1251   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1252   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1253   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1254   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1255   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1256 #if defined(PERL_IMPLICIT_CONTEXT)
1257   pTHX;
1258 #endif
1259 #if defined(USE_ITHREADS)
1260   static perl_mutex primenv_mutex;
1261   MUTEX_INIT(&primenv_mutex);
1262 #endif
1263
1264 #if defined(PERL_IMPLICIT_CONTEXT)
1265     /* We jump through these hoops because we can be called at */
1266     /* platform-specific initialization time, which is before anything is */
1267     /* set up--we can't even do a plain dTHX since that relies on the */
1268     /* interpreter structure to be initialized */
1269     if (PL_curinterp) {
1270       aTHX = PERL_GET_INTERP;
1271     } else {
1272       aTHX = NULL;
1273     }
1274 #endif
1275
1276   if (primed || !PL_envgv) return;
1277   MUTEX_LOCK(&primenv_mutex);
1278   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1279   envhv = GvHVn(PL_envgv);
1280   /* Perform a dummy fetch as an lval to insure that the hash table is
1281    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1282   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1283
1284   for (i = 0; env_tables[i]; i++) {
1285      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1286          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1287      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1288   }
1289   if (have_sym || have_lnm) {
1290     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1291     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1292     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1293     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1294   }
1295
1296   for (i--; i >= 0; i--) {
1297     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1298       char *start;
1299       int j;
1300       for (j = 0; environ[j]; j++) {
1301         if (!(start = strchr(environ[j],'='))) {
1302           if (ckWARN(WARN_INTERNAL))
1303             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1304         }
1305         else {
1306           start++;
1307           sv = newSVpv(start,0);
1308           SvTAINTED_on(sv);
1309           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1310         }
1311       }
1312       continue;
1313     }
1314     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1315              !str$case_blind_compare(&tmpdsc,&clisym)) {
1316       strcpy(cmd,"Show Symbol/Global *");
1317       cmddsc.dsc$w_length = 20;
1318       if (env_tables[i]->dsc$w_length == 12 &&
1319           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1320           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1321       flags = defflags | CLI$M_NOLOGNAM;
1322     }
1323     else {
1324       strcpy(cmd,"Show Logical *");
1325       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1326         strcat(cmd," /Table=");
1327         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1328         cmddsc.dsc$w_length = strlen(cmd);
1329       }
1330       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1331       flags = defflags | CLI$M_NOCLISYM;
1332     }
1333
1334     /* Create a new subprocess to execute each command, to exclude the
1335      * remote possibility that someone could subvert a mbx or file used
1336      * to write multiple commands to a single subprocess.
1337      */
1338     do {
1339       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1340                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1341       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1342       defflags &= ~CLI$M_TRUSTED;
1343     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1344     _ckvmssts(retsts);
1345     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1346     if (seenhv) SvREFCNT_dec(seenhv);
1347     seenhv = newHV();
1348     while (1) {
1349       char *cp1, *cp2, *key;
1350       unsigned long int sts, iosb[2], retlen, keylen;
1351       register U32 hash;
1352
1353       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1354       if (sts & 1) sts = iosb[0] & 0xffff;
1355       if (sts == SS$_ENDOFFILE) {
1356         int wakect = 0;
1357         while (substs == 0) { sys$hiber(); wakect++;}
1358         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1359         _ckvmssts(substs);
1360         break;
1361       }
1362       _ckvmssts(sts);
1363       retlen = iosb[0] >> 16;
1364       if (!retlen) continue;  /* blank line */
1365       buf[retlen] = '\0';
1366       if (iosb[1] != subpid) {
1367         if (iosb[1]) {
1368           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1369         }
1370         continue;
1371       }
1372       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1373         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1374
1375       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1376       if (*cp1 == '(' || /* Logical name table name */
1377           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1378       if (*cp1 == '"') cp1++;
1379       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1380       key = cp1;  keylen = cp2 - cp1;
1381       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1382       while (*cp2 && *cp2 != '=') cp2++;
1383       while (*cp2 && *cp2 == '=') cp2++;
1384       while (*cp2 && *cp2 == ' ') cp2++;
1385       if (*cp2 == '"') {  /* String translation; may embed "" */
1386         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1387         cp2++;  cp1--; /* Skip "" surrounding translation */
1388       }
1389       else {  /* Numeric translation */
1390         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1391         cp1--;  /* stop on last non-space char */
1392       }
1393       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1394         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1395         continue;
1396       }
1397       PERL_HASH(hash,key,keylen);
1398
1399       if (cp1 == cp2 && *cp2 == '.') {
1400         /* A single dot usually means an unprintable character, such as a null
1401          * to indicate a zero-length value.  Get the actual value to make sure.
1402          */
1403         char lnm[LNM$C_NAMLENGTH+1];
1404         char eqv[MAX_DCL_SYMBOL+1];
1405         int trnlen;
1406         strncpy(lnm, key, keylen);
1407         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1408         sv = newSVpvn(eqv, strlen(eqv));
1409       }
1410       else {
1411         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1412       }
1413
1414       SvTAINTED_on(sv);
1415       hv_store(envhv,key,keylen,sv,hash);
1416       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1417     }
1418     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1419       /* get the PPFs for this process, not the subprocess */
1420       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1421       char eqv[LNM$C_NAMLENGTH+1];
1422       int trnlen, i;
1423       for (i = 0; ppfs[i]; i++) {
1424         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1425         sv = newSVpv(eqv,trnlen);
1426         SvTAINTED_on(sv);
1427         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1428       }
1429     }
1430   }
1431   primed = 1;
1432   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1433   if (buf) Safefree(buf);
1434   if (seenhv) SvREFCNT_dec(seenhv);
1435   MUTEX_UNLOCK(&primenv_mutex);
1436   return;
1437
1438 }  /* end of prime_env_iter */
1439 /*}}}*/
1440
1441
1442 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1443 /* Define or delete an element in the same "environment" as
1444  * vmstrnenv().  If an element is to be deleted, it's removed from
1445  * the first place it's found.  If it's to be set, it's set in the
1446  * place designated by the first element of the table vector.
1447  * Like setenv() returns 0 for success, non-zero on error.
1448  */
1449 int
1450 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1451 {
1452     const char *cp1;
1453     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1454     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1455     int nseg = 0, j;
1456     unsigned long int retsts, usermode = PSL$C_USER;
1457     struct itmlst_3 *ile, *ilist;
1458     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1459                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1460                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1461     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1462     $DESCRIPTOR(local,"_LOCAL");
1463
1464     if (!lnm) {
1465         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1466         return SS$_IVLOGNAM;
1467     }
1468
1469     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1470       *cp2 = _toupper(*cp1);
1471       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1472         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1473         return SS$_IVLOGNAM;
1474       }
1475     }
1476     lnmdsc.dsc$w_length = cp1 - lnm;
1477     if (!tabvec || !*tabvec) tabvec = env_tables;
1478
1479     if (!eqv) {  /* we're deleting n element */
1480       for (curtab = 0; tabvec[curtab]; curtab++) {
1481         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1482         int i;
1483           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1484             if ((cp1 = strchr(environ[i],'=')) &&
1485                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1486                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1487 #ifdef HAS_SETENV
1488               return setenv(lnm,"",1) ? vaxc$errno : 0;
1489             }
1490           }
1491           ivenv = 1; retsts = SS$_NOLOGNAM;
1492 #else
1493               if (ckWARN(WARN_INTERNAL))
1494                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1495               ivenv = 1; retsts = SS$_NOSUCHPGM;
1496               break;
1497             }
1498           }
1499 #endif
1500         }
1501         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1502                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1503           unsigned int symtype;
1504           if (tabvec[curtab]->dsc$w_length == 12 &&
1505               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1506               !str$case_blind_compare(&tmpdsc,&local))
1507             symtype = LIB$K_CLI_LOCAL_SYM;
1508           else symtype = LIB$K_CLI_GLOBAL_SYM;
1509           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1510           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1511           if (retsts == LIB$_NOSUCHSYM) continue;
1512           break;
1513         }
1514         else if (!ivlnm) {
1515           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1516           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1517           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1518           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1519           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1520         }
1521       }
1522     }
1523     else {  /* we're defining a value */
1524       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1525 #ifdef HAS_SETENV
1526         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1527 #else
1528         if (ckWARN(WARN_INTERNAL))
1529           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1530         retsts = SS$_NOSUCHPGM;
1531 #endif
1532       }
1533       else {
1534         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1535         eqvdsc.dsc$w_length  = strlen(eqv);
1536         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1537             !str$case_blind_compare(&tmpdsc,&clisym)) {
1538           unsigned int symtype;
1539           if (tabvec[0]->dsc$w_length == 12 &&
1540               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1541                !str$case_blind_compare(&tmpdsc,&local))
1542             symtype = LIB$K_CLI_LOCAL_SYM;
1543           else symtype = LIB$K_CLI_GLOBAL_SYM;
1544           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1545         }
1546         else {
1547           if (!*eqv) eqvdsc.dsc$w_length = 1;
1548           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1549
1550             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1551             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1552               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1553                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1554               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1555               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1556             }
1557
1558             Newx(ilist,nseg+1,struct itmlst_3);
1559             ile = ilist;
1560             if (!ile) {
1561               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1562               return SS$_INSFMEM;
1563             }
1564             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1565
1566             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1567               ile->itmcode = LNM$_STRING;
1568               ile->bufadr = c;
1569               if ((j+1) == nseg) {
1570                 ile->buflen = strlen(c);
1571                 /* in case we are truncating one that's too long */
1572                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1573               }
1574               else {
1575                 ile->buflen = LNM$C_NAMLENGTH;
1576               }
1577             }
1578
1579             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1580             Safefree (ilist);
1581           }
1582           else {
1583             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1584           }
1585         }
1586       }
1587     }
1588     if (!(retsts & 1)) {
1589       switch (retsts) {
1590         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1591         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1592           set_errno(EVMSERR); break;
1593         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1594         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1595           set_errno(EINVAL); break;
1596         case SS$_NOPRIV:
1597           set_errno(EACCES); break;
1598         default:
1599           _ckvmssts(retsts);
1600           set_errno(EVMSERR);
1601        }
1602        set_vaxc_errno(retsts);
1603        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1604     }
1605     else {
1606       /* We reset error values on success because Perl does an hv_fetch()
1607        * before each hv_store(), and if the thing we're setting didn't
1608        * previously exist, we've got a leftover error message.  (Of course,
1609        * this fails in the face of
1610        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1611        * in that the error reported in $! isn't spurious,
1612        * but it's right more often than not.)
1613        */
1614       set_errno(0); set_vaxc_errno(retsts);
1615       return 0;
1616     }
1617
1618 }  /* end of vmssetenv() */
1619 /*}}}*/
1620
1621 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1622 /* This has to be a function since there's a prototype for it in proto.h */
1623 void
1624 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1625 {
1626     if (lnm && *lnm) {
1627       int len = strlen(lnm);
1628       if  (len == 7) {
1629         char uplnm[8];
1630         int i;
1631         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1632         if (!strcmp(uplnm,"DEFAULT")) {
1633           if (eqv && *eqv) my_chdir(eqv);
1634           return;
1635         }
1636     }
1637 #ifndef RTL_USES_UTC
1638     if (len == 6 || len == 2) {
1639       char uplnm[7];
1640       int i;
1641       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1642       uplnm[len] = '\0';
1643       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1644       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1645     }
1646 #endif
1647   }
1648   (void) vmssetenv(lnm,eqv,NULL);
1649 }
1650 /*}}}*/
1651
1652 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1653 /*  vmssetuserlnm
1654  *  sets a user-mode logical in the process logical name table
1655  *  used for redirection of sys$error
1656  */
1657 void
1658 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1659 {
1660     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1661     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1662     unsigned long int iss, attr = LNM$M_CONFINE;
1663     unsigned char acmode = PSL$C_USER;
1664     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1665                                  {0, 0, 0, 0}};
1666     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1667     d_name.dsc$w_length = strlen(name);
1668
1669     lnmlst[0].buflen = strlen(eqv);
1670     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1671
1672     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1673     if (!(iss&1)) lib$signal(iss);
1674 }
1675 /*}}}*/
1676
1677
1678 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1679 /* my_crypt - VMS password hashing
1680  * my_crypt() provides an interface compatible with the Unix crypt()
1681  * C library function, and uses sys$hash_password() to perform VMS
1682  * password hashing.  The quadword hashed password value is returned
1683  * as a NUL-terminated 8 character string.  my_crypt() does not change
1684  * the case of its string arguments; in order to match the behavior
1685  * of LOGINOUT et al., alphabetic characters in both arguments must
1686  *  be upcased by the caller.
1687  *
1688  * - fix me to call ACM services when available
1689  */
1690 char *
1691 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1692 {
1693 #   ifndef UAI$C_PREFERRED_ALGORITHM
1694 #     define UAI$C_PREFERRED_ALGORITHM 127
1695 #   endif
1696     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1697     unsigned short int salt = 0;
1698     unsigned long int sts;
1699     struct const_dsc {
1700         unsigned short int dsc$w_length;
1701         unsigned char      dsc$b_type;
1702         unsigned char      dsc$b_class;
1703         const char *       dsc$a_pointer;
1704     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1705        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1706     struct itmlst_3 uailst[3] = {
1707         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1708         { sizeof salt, UAI$_SALT,    &salt, 0},
1709         { 0,           0,            NULL,  NULL}};
1710     static char hash[9];
1711
1712     usrdsc.dsc$w_length = strlen(usrname);
1713     usrdsc.dsc$a_pointer = usrname;
1714     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1715       switch (sts) {
1716         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1717           set_errno(EACCES);
1718           break;
1719         case RMS$_RNF:
1720           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1721           break;
1722         default:
1723           set_errno(EVMSERR);
1724       }
1725       set_vaxc_errno(sts);
1726       if (sts != RMS$_RNF) return NULL;
1727     }
1728
1729     txtdsc.dsc$w_length = strlen(textpasswd);
1730     txtdsc.dsc$a_pointer = textpasswd;
1731     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1732       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1733     }
1734
1735     return (char *) hash;
1736
1737 }  /* end of my_crypt() */
1738 /*}}}*/
1739
1740
1741 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1742 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1743 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1744
1745 /* fixup barenames that are directories for internal use.
1746  * There have been problems with the consistent handling of UNIX
1747  * style directory names when routines are presented with a name that
1748  * has no directory delimitors at all.  So this routine will eventually
1749  * fix the issue.
1750  */
1751 static char * fixup_bare_dirnames(const char * name)
1752 {
1753   if (decc_disable_to_vms_logname_translation) {
1754 /* fix me */
1755   }
1756   return NULL;
1757 }
1758
1759 /* mp_do_kill_file
1760  * A little hack to get around a bug in some implemenation of remove()
1761  * that do not know how to delete a directory
1762  *
1763  * Delete any file to which user has control access, regardless of whether
1764  * delete access is explicitly allowed.
1765  * Limitations: User must have write access to parent directory.
1766  *              Does not block signals or ASTs; if interrupted in midstream
1767  *              may leave file with an altered ACL.
1768  * HANDLE WITH CARE!
1769  */
1770 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1771 static int
1772 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1773 {
1774     char *vmsname, *rspec;
1775     char *remove_name;
1776     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1777     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1778     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1779     struct myacedef {
1780       unsigned char myace$b_length;
1781       unsigned char myace$b_type;
1782       unsigned short int myace$w_flags;
1783       unsigned long int myace$l_access;
1784       unsigned long int myace$l_ident;
1785     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1786                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1787       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1788      struct itmlst_3
1789        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1790                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1791        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1792        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1793        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1794        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1795
1796     /* Expand the input spec using RMS, since the CRTL remove() and
1797      * system services won't do this by themselves, so we may miss
1798      * a file "hiding" behind a logical name or search list. */
1799     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1800     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1801
1802     if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1803       PerlMem_free(vmsname);
1804       return -1;
1805     }
1806
1807     if (decc_posix_compliant_pathnames) {
1808       /* In POSIX mode, we prefer to remove the UNIX name */
1809       rspec = vmsname;
1810       remove_name = (char *)name;
1811     }
1812     else {
1813       rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1814       if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1815       if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1816         PerlMem_free(rspec);
1817         PerlMem_free(vmsname);
1818         return -1;
1819       }
1820       PerlMem_free(vmsname);
1821       remove_name = rspec;
1822     }
1823
1824 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1825     if (dirflag != 0) {
1826         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1827           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1828           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1829
1830           do_pathify_dirspec(name, remove_name, 0, NULL);
1831           if (!rmdir(remove_name)) {
1832
1833             PerlMem_free(remove_name);
1834             PerlMem_free(rspec);
1835             return 0;   /* Can we just get rid of it? */
1836           }
1837         }
1838         else {
1839           if (!rmdir(remove_name)) {
1840             PerlMem_free(rspec);
1841             return 0;   /* Can we just get rid of it? */
1842           }
1843         }
1844     }
1845     else
1846 #endif
1847       if (!remove(remove_name)) {
1848         PerlMem_free(rspec);
1849         return 0;   /* Can we just get rid of it? */
1850       }
1851
1852     /* If not, can changing protections help? */
1853     if (vaxc$errno != RMS$_PRV) {
1854       PerlMem_free(rspec);
1855       return -1;
1856     }
1857
1858     /* No, so we get our own UIC to use as a rights identifier,
1859      * and the insert an ACE at the head of the ACL which allows us
1860      * to delete the file.
1861      */
1862     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1863     fildsc.dsc$w_length = strlen(rspec);
1864     fildsc.dsc$a_pointer = rspec;
1865     cxt = 0;
1866     newace.myace$l_ident = oldace.myace$l_ident;
1867     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1868       switch (aclsts) {
1869         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1870           set_errno(ENOENT); break;
1871         case RMS$_DIR:
1872           set_errno(ENOTDIR); break;
1873         case RMS$_DEV:
1874           set_errno(ENODEV); break;
1875         case RMS$_SYN: case SS$_INVFILFOROP:
1876           set_errno(EINVAL); break;
1877         case RMS$_PRV:
1878           set_errno(EACCES); break;
1879         default:
1880           _ckvmssts(aclsts);
1881       }
1882       set_vaxc_errno(aclsts);
1883       PerlMem_free(rspec);
1884       return -1;
1885     }
1886     /* Grab any existing ACEs with this identifier in case we fail */
1887     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1888     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1889                     || fndsts == SS$_NOMOREACE ) {
1890       /* Add the new ACE . . . */
1891       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1892         goto yourroom;
1893
1894 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1895       if (dirflag != 0)
1896         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1897           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1898           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1899
1900           do_pathify_dirspec(name, remove_name, 0, NULL);
1901           rmsts = rmdir(remove_name);
1902           PerlMem_free(remove_name);
1903         }
1904         else {
1905         rmsts = rmdir(remove_name);
1906         }
1907       else
1908 #endif
1909         rmsts = remove(remove_name);
1910       if (rmsts) {
1911         /* We blew it - dir with files in it, no write priv for
1912          * parent directory, etc.  Put things back the way they were. */
1913         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1914           goto yourroom;
1915         if (fndsts & 1) {
1916           addlst[0].bufadr = &oldace;
1917           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1918             goto yourroom;
1919         }
1920       }
1921     }
1922
1923     yourroom:
1924     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1925     /* We just deleted it, so of course it's not there.  Some versions of
1926      * VMS seem to return success on the unlock operation anyhow (after all
1927      * the unlock is successful), but others don't.
1928      */
1929     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1930     if (aclsts & 1) aclsts = fndsts;
1931     if (!(aclsts & 1)) {
1932       set_errno(EVMSERR);
1933       set_vaxc_errno(aclsts);
1934       PerlMem_free(rspec);
1935       return -1;
1936     }
1937
1938     PerlMem_free(rspec);
1939     return rmsts;
1940
1941 }  /* end of kill_file() */
1942 /*}}}*/
1943
1944
1945 /*{{{int do_rmdir(char *name)*/
1946 int
1947 Perl_do_rmdir(pTHX_ const char *name)
1948 {
1949     char dirfile[NAM$C_MAXRSS+1];
1950     int retval;
1951     Stat_t st;
1952
1953     if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1954     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1955     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1956     return retval;
1957
1958 }  /* end of do_rmdir */
1959 /*}}}*/
1960
1961 /* kill_file
1962  * Delete any file to which user has control access, regardless of whether
1963  * delete access is explicitly allowed.
1964  * Limitations: User must have write access to parent directory.
1965  *              Does not block signals or ASTs; if interrupted in midstream
1966  *              may leave file with an altered ACL.
1967  * HANDLE WITH CARE!
1968  */
1969 /*{{{int kill_file(char *name)*/
1970 int
1971 Perl_kill_file(pTHX_ const char *name)
1972 {
1973     char rspec[NAM$C_MAXRSS+1];
1974     char *tspec;
1975     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1976     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1977     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1978     struct myacedef {
1979       unsigned char myace$b_length;
1980       unsigned char myace$b_type;
1981       unsigned short int myace$w_flags;
1982       unsigned long int myace$l_access;
1983       unsigned long int myace$l_ident;
1984     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1985                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1986       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1987      struct itmlst_3
1988        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1989                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1990        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1991        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1992        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1993        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1994
1995     /* Expand the input spec using RMS, since the CRTL remove() and
1996      * system services won't do this by themselves, so we may miss
1997      * a file "hiding" behind a logical name or search list. */
1998     tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1999     if (tspec == NULL) return -1;
2000     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
2001     /* If not, can changing protections help? */
2002     if (vaxc$errno != RMS$_PRV) return -1;
2003
2004     /* No, so we get our own UIC to use as a rights identifier,
2005      * and the insert an ACE at the head of the ACL which allows us
2006      * to delete the file.
2007      */
2008     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
2009     fildsc.dsc$w_length = strlen(rspec);
2010     fildsc.dsc$a_pointer = rspec;
2011     cxt = 0;
2012     newace.myace$l_ident = oldace.myace$l_ident;
2013     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
2014       switch (aclsts) {
2015         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
2016           set_errno(ENOENT); break;
2017         case RMS$_DIR:
2018           set_errno(ENOTDIR); break;
2019         case RMS$_DEV:
2020           set_errno(ENODEV); break;
2021         case RMS$_SYN: case SS$_INVFILFOROP:
2022           set_errno(EINVAL); break;
2023         case RMS$_PRV:
2024           set_errno(EACCES); break;
2025         default:
2026           _ckvmssts(aclsts);
2027       }
2028       set_vaxc_errno(aclsts);
2029       return -1;
2030     }
2031     /* Grab any existing ACEs with this identifier in case we fail */
2032     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2033     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2034                     || fndsts == SS$_NOMOREACE ) {
2035       /* Add the new ACE . . . */
2036       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2037         goto yourroom;
2038       if ((rmsts = remove(name))) {
2039         /* We blew it - dir with files in it, no write priv for
2040          * parent directory, etc.  Put things back the way they were. */
2041         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2042           goto yourroom;
2043         if (fndsts & 1) {
2044           addlst[0].bufadr = &oldace;
2045           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2046             goto yourroom;
2047         }
2048       }
2049     }
2050
2051     yourroom:
2052     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2053     /* We just deleted it, so of course it's not there.  Some versions of
2054      * VMS seem to return success on the unlock operation anyhow (after all
2055      * the unlock is successful), but others don't.
2056      */
2057     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2058     if (aclsts & 1) aclsts = fndsts;
2059     if (!(aclsts & 1)) {
2060       set_errno(EVMSERR);
2061       set_vaxc_errno(aclsts);
2062       return -1;
2063     }
2064
2065     return rmsts;
2066
2067 }  /* end of kill_file() */
2068 /*}}}*/
2069
2070
2071 /*{{{int my_mkdir(char *,Mode_t)*/
2072 int
2073 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2074 {
2075   STRLEN dirlen = strlen(dir);
2076
2077   /* zero length string sometimes gives ACCVIO */
2078   if (dirlen == 0) return -1;
2079
2080   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2081    * null file name/type.  However, it's commonplace under Unix,
2082    * so we'll allow it for a gain in portability.
2083    */
2084   if (dir[dirlen-1] == '/') {
2085     char *newdir = savepvn(dir,dirlen-1);
2086     int ret = mkdir(newdir,mode);
2087     Safefree(newdir);
2088     return ret;
2089   }
2090   else return mkdir(dir,mode);
2091 }  /* end of my_mkdir */
2092 /*}}}*/
2093
2094 /*{{{int my_chdir(char *)*/
2095 int
2096 Perl_my_chdir(pTHX_ const char *dir)
2097 {
2098   STRLEN dirlen = strlen(dir);
2099
2100   /* zero length string sometimes gives ACCVIO */
2101   if (dirlen == 0) return -1;
2102   const char *dir1;
2103
2104   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2105    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2106    * so that existing scripts do not need to be changed.
2107    */
2108   dir1 = dir;
2109   while ((dirlen > 0) && (*dir1 == ' ')) {
2110     dir1++;
2111     dirlen--;
2112   }
2113
2114   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2115    * that implies
2116    * null file name/type.  However, it's commonplace under Unix,
2117    * so we'll allow it for a gain in portability.
2118    *
2119    * - Preview- '/' will be valid soon on VMS
2120    */
2121   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2122     char *newdir = savepvn(dir1,dirlen-1);
2123     int ret = chdir(newdir);
2124     Safefree(newdir);
2125     return ret;
2126   }
2127   else return chdir(dir1);
2128 }  /* end of my_chdir */
2129 /*}}}*/
2130
2131
2132 /*{{{FILE *my_tmpfile()*/
2133 FILE *
2134 my_tmpfile(void)
2135 {
2136   FILE *fp;
2137   char *cp;
2138
2139   if ((fp = tmpfile())) return fp;
2140
2141   cp = PerlMem_malloc(L_tmpnam+24);
2142   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2143
2144   if (decc_filename_unix_only == 0)
2145     strcpy(cp,"Sys$Scratch:");
2146   else
2147     strcpy(cp,"/tmp/");
2148   tmpnam(cp+strlen(cp));
2149   strcat(cp,".Perltmp");
2150   fp = fopen(cp,"w+","fop=dlt");
2151   PerlMem_free(cp);
2152   return fp;
2153 }
2154 /*}}}*/
2155
2156
2157 #ifndef HOMEGROWN_POSIX_SIGNALS
2158 /*
2159  * The C RTL's sigaction fails to check for invalid signal numbers so we
2160  * help it out a bit.  The docs are correct, but the actual routine doesn't
2161  * do what the docs say it will.
2162  */
2163 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2164 int
2165 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2166                    struct sigaction* oact)
2167 {
2168   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2169         SETERRNO(EINVAL, SS$_INVARG);
2170         return -1;
2171   }
2172   return sigaction(sig, act, oact);
2173 }
2174 /*}}}*/
2175 #endif
2176
2177 #ifdef KILL_BY_SIGPRC
2178 #include <errnodef.h>
2179
2180 /* We implement our own kill() using the undocumented system service
2181    sys$sigprc for one of two reasons:
2182
2183    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2184    target process to do a sys$exit, which usually can't be handled
2185    gracefully...certainly not by Perl and the %SIG{} mechanism.
2186
2187    2.) If the kill() in the CRTL can't be called from a signal
2188    handler without disappearing into the ether, i.e., the signal
2189    it purportedly sends is never trapped. Still true as of VMS 7.3.
2190
2191    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2192    in the target process rather than calling sys$exit.
2193
2194    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2195    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2196    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2197    with condition codes C$_SIG0+nsig*8, catching the exception on the
2198    target process and resignaling with appropriate arguments.
2199
2200    But we don't have that VMS 7.0+ exception handler, so if you
2201    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2202
2203    Also note that SIGTERM is listed in the docs as being "unimplemented",
2204    yet always seems to be signaled with a VMS condition code of 4 (and
2205    correctly handled for that code).  So we hardwire it in.
2206
2207    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2208    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2209    than signalling with an unrecognized (and unhandled by CRTL) code.
2210 */
2211
2212 #define _MY_SIG_MAX 28
2213
2214 static unsigned int
2215 Perl_sig_to_vmscondition_int(int sig)
2216 {
2217     static unsigned int sig_code[_MY_SIG_MAX+1] =
2218     {
2219         0,                  /*  0 ZERO     */
2220         SS$_HANGUP,         /*  1 SIGHUP   */
2221         SS$_CONTROLC,       /*  2 SIGINT   */
2222         SS$_CONTROLY,       /*  3 SIGQUIT  */
2223         SS$_RADRMOD,        /*  4 SIGILL   */
2224         SS$_BREAK,          /*  5 SIGTRAP  */
2225         SS$_OPCCUS,         /*  6 SIGABRT  */
2226         SS$_COMPAT,         /*  7 SIGEMT   */
2227 #ifdef __VAX
2228         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2229 #else
2230         SS$_HPARITH,        /*  8 SIGFPE AXP */
2231 #endif
2232         SS$_ABORT,          /*  9 SIGKILL  */
2233         SS$_ACCVIO,         /* 10 SIGBUS   */
2234         SS$_ACCVIO,         /* 11 SIGSEGV  */
2235         SS$_BADPARAM,       /* 12 SIGSYS   */
2236         SS$_NOMBX,          /* 13 SIGPIPE  */
2237         SS$_ASTFLT,         /* 14 SIGALRM  */
2238         4,                  /* 15 SIGTERM  */
2239         0,                  /* 16 SIGUSR1  */
2240         0,                  /* 17 SIGUSR2  */
2241         0,                  /* 18 */
2242         0,                  /* 19 */
2243         0,                  /* 20 SIGCHLD  */
2244         0,                  /* 21 SIGCONT  */
2245         0,                  /* 22 SIGSTOP  */
2246         0,                  /* 23 SIGTSTP  */
2247         0,                  /* 24 SIGTTIN  */
2248         0,                  /* 25 SIGTTOU  */
2249         0,                  /* 26 */
2250         0,                  /* 27 */
2251         0                   /* 28 SIGWINCH  */
2252     };
2253
2254 #if __VMS_VER >= 60200000
2255     static int initted = 0;
2256     if (!initted) {
2257         initted = 1;
2258         sig_code[16] = C$_SIGUSR1;
2259         sig_code[17] = C$_SIGUSR2;
2260 #if __CRTL_VER >= 70000000
2261         sig_code[20] = C$_SIGCHLD;
2262 #endif
2263 #if __CRTL_VER >= 70300000
2264         sig_code[28] = C$_SIGWINCH;
2265 #endif
2266     }
2267 #endif
2268
2269     if (sig < _SIG_MIN) return 0;
2270     if (sig > _MY_SIG_MAX) return 0;
2271     return sig_code[sig];
2272 }
2273
2274 unsigned int
2275 Perl_sig_to_vmscondition(int sig)
2276 {
2277 #ifdef SS$_DEBUG
2278     if (vms_debug_on_exception != 0)
2279         lib$signal(SS$_DEBUG);
2280 #endif
2281     return Perl_sig_to_vmscondition_int(sig);
2282 }
2283
2284
2285 int
2286 Perl_my_kill(int pid, int sig)
2287 {
2288     dTHX;
2289     int iss;
2290     unsigned int code;
2291     int sys$sigprc(unsigned int *pidadr,
2292                      struct dsc$descriptor_s *prcname,
2293                      unsigned int code);
2294
2295      /* sig 0 means validate the PID */
2296     /*------------------------------*/
2297     if (sig == 0) {
2298         const unsigned long int jpicode = JPI$_PID;
2299         pid_t ret_pid;
2300         int status;
2301         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2302         if ($VMS_STATUS_SUCCESS(status))
2303            return 0;
2304         switch (status) {
2305         case SS$_NOSUCHNODE:
2306         case SS$_UNREACHABLE:
2307         case SS$_NONEXPR:
2308            errno = ESRCH;
2309            break;
2310         case SS$_NOPRIV:
2311            errno = EPERM;
2312            break;
2313         default:
2314            errno = EVMSERR;
2315         }
2316         vaxc$errno=status;
2317         return -1;
2318     }
2319
2320     code = Perl_sig_to_vmscondition_int(sig);
2321
2322     if (!code) {
2323         SETERRNO(EINVAL, SS$_BADPARAM);
2324         return -1;
2325     }
2326
2327     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2328      * signals are to be sent to multiple processes.
2329      *  pid = 0 - all processes in group except ones that the system exempts
2330      *  pid = -1 - all processes except ones that the system exempts
2331      *  pid = -n - all processes in group (abs(n)) except ...
2332      * For now, just report as not supported.
2333      */
2334
2335     if (pid <= 0) {
2336         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2337         return -1;
2338     }
2339
2340     iss = sys$sigprc((unsigned int *)&pid,0,code);
2341     if (iss&1) return 0;
2342
2343     switch (iss) {
2344       case SS$_NOPRIV:
2345         set_errno(EPERM);  break;
2346       case SS$_NONEXPR:
2347       case SS$_NOSUCHNODE:
2348       case SS$_UNREACHABLE:
2349         set_errno(ESRCH);  break;
2350       case SS$_INSFMEM:
2351         set_errno(ENOMEM); break;
2352       default:
2353         _ckvmssts(iss);
2354         set_errno(EVMSERR);
2355     }
2356     set_vaxc_errno(iss);
2357
2358     return -1;
2359 }
2360 #endif
2361
2362 /* Routine to convert a VMS status code to a UNIX status code.
2363 ** More tricky than it appears because of conflicting conventions with
2364 ** existing code.
2365 **
2366 ** VMS status codes are a bit mask, with the least significant bit set for
2367 ** success.
2368 **
2369 ** Special UNIX status of EVMSERR indicates that no translation is currently
2370 ** available, and programs should check the VMS status code.
2371 **
2372 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2373 ** decoding.
2374 */
2375
2376 #ifndef C_FACILITY_NO
2377 #define C_FACILITY_NO 0x350000
2378 #endif
2379 #ifndef DCL_IVVERB
2380 #define DCL_IVVERB 0x38090
2381 #endif
2382
2383 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2384 {
2385 int facility;
2386 int fac_sp;
2387 int msg_no;
2388 int msg_status;
2389 int unix_status;
2390
2391   /* Assume the best or the worst */
2392   if (vms_status & STS$M_SUCCESS)
2393     unix_status = 0;
2394   else
2395     unix_status = EVMSERR;
2396
2397   msg_status = vms_status & ~STS$M_CONTROL;
2398
2399   facility = vms_status & STS$M_FAC_NO;
2400   fac_sp = vms_status & STS$M_FAC_SP;
2401   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2402
2403   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2404     switch(msg_no) {
2405     case SS$_NORMAL:
2406         unix_status = 0;
2407         break;
2408     case SS$_ACCVIO:
2409         unix_status = EFAULT;
2410         break;
2411     case SS$_DEVOFFLINE:
2412         unix_status = EBUSY;
2413         break;
2414     case SS$_CLEARED:
2415         unix_status = ENOTCONN;
2416         break;
2417     case SS$_IVCHAN:
2418     case SS$_IVLOGNAM:
2419     case SS$_BADPARAM:
2420     case SS$_IVLOGTAB:
2421     case SS$_NOLOGNAM:
2422     case SS$_NOLOGTAB:
2423     case SS$_INVFILFOROP:
2424     case SS$_INVARG:
2425     case SS$_NOSUCHID:
2426     case SS$_IVIDENT:
2427         unix_status = EINVAL;
2428         break;
2429     case SS$_UNSUPPORTED:
2430         unix_status = ENOTSUP;
2431         break;
2432     case SS$_FILACCERR:
2433     case SS$_NOGRPPRV:
2434     case SS$_NOSYSPRV:
2435         unix_status = EACCES;
2436         break;
2437     case SS$_DEVICEFULL:
2438         unix_status = ENOSPC;
2439         break;
2440     case SS$_NOSUCHDEV:
2441         unix_status = ENODEV;
2442         break;
2443     case SS$_NOSUCHFILE:
2444     case SS$_NOSUCHOBJECT:
2445         unix_status = ENOENT;
2446         break;
2447     case SS$_ABORT:                                 /* Fatal case */
2448     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2449     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2450         unix_status = EINTR;
2451         break;
2452     case SS$_BUFFEROVF:
2453         unix_status = E2BIG;
2454         break;
2455     case SS$_INSFMEM:
2456         unix_status = ENOMEM;
2457         break;
2458     case SS$_NOPRIV:
2459         unix_status = EPERM;
2460         break;
2461     case SS$_NOSUCHNODE:
2462     case SS$_UNREACHABLE:
2463         unix_status = ESRCH;
2464         break;
2465     case SS$_NONEXPR:
2466         unix_status = ECHILD;
2467         break;
2468     default:
2469         if ((facility == 0) && (msg_no < 8)) {
2470           /* These are not real VMS status codes so assume that they are
2471           ** already UNIX status codes
2472           */
2473           unix_status = msg_no;
2474           break;
2475         }
2476     }
2477   }
2478   else {
2479     /* Translate a POSIX exit code to a UNIX exit code */
2480     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2481         unix_status = (msg_no & 0x07F8) >> 3;
2482     }
2483     else {
2484
2485          /* Documented traditional behavior for handling VMS child exits */
2486         /*--------------------------------------------------------------*/
2487         if (child_flag != 0) {
2488
2489              /* Success / Informational return 0 */
2490             /*----------------------------------*/
2491             if (msg_no & STS$K_SUCCESS)
2492                 return 0;
2493
2494              /* Warning returns 1 */
2495             /*-------------------*/
2496             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2497                 return 1;
2498
2499              /* Everything else pass through the severity bits */
2500             /*------------------------------------------------*/
2501             return (msg_no & STS$M_SEVERITY);
2502         }
2503
2504          /* Normal VMS status to ERRNO mapping attempt */
2505         /*--------------------------------------------*/
2506         switch(msg_status) {
2507         /* case RMS$_EOF: */ /* End of File */
2508         case RMS$_FNF:  /* File Not Found */
2509         case RMS$_DNF:  /* Dir Not Found */
2510                 unix_status = ENOENT;
2511                 break;
2512         case RMS$_RNF:  /* Record Not Found */
2513                 unix_status = ESRCH;
2514                 break;
2515         case RMS$_DIR:
2516                 unix_status = ENOTDIR;
2517                 break;
2518         case RMS$_DEV:
2519                 unix_status = ENODEV;
2520                 break;
2521         case RMS$_IFI:
2522         case RMS$_FAC:
2523         case RMS$_ISI:
2524                 unix_status = EBADF;
2525                 break;
2526         case RMS$_FEX:
2527                 unix_status = EEXIST;
2528                 break;
2529         case RMS$_SYN:
2530         case RMS$_FNM:
2531         case LIB$_INVSTRDES:
2532         case LIB$_INVARG:
2533         case LIB$_NOSUCHSYM:
2534         case LIB$_INVSYMNAM:
2535         case DCL_IVVERB:
2536                 unix_status = EINVAL;
2537                 break;
2538         case CLI$_BUFOVF:
2539         case RMS$_RTB:
2540         case CLI$_TKNOVF:
2541         case CLI$_RSLOVF:
2542                 unix_status = E2BIG;
2543                 break;
2544         case RMS$_PRV:  /* No privilege */
2545         case RMS$_ACC:  /* ACP file access failed */
2546         case RMS$_WLK:  /* Device write locked */
2547                 unix_status = EACCES;
2548                 break;
2549         /* case RMS$_NMF: */  /* No more files */
2550         }
2551     }
2552   }
2553
2554   return unix_status;
2555 }
2556
2557 /* Try to guess at what VMS error status should go with a UNIX errno
2558  * value.  This is hard to do as there could be many possible VMS
2559  * error statuses that caused the errno value to be set.
2560  */
2561
2562 int Perl_unix_status_to_vms(int unix_status)
2563 {
2564 int test_unix_status;
2565
2566      /* Trivial cases first */
2567     /*---------------------*/
2568     if (unix_status == EVMSERR)
2569         return vaxc$errno;
2570
2571      /* Is vaxc$errno sane? */
2572     /*---------------------*/
2573     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2574     if (test_unix_status == unix_status)
2575         return vaxc$errno;
2576
2577      /* If way out of range, must be VMS code already */
2578     /*-----------------------------------------------*/
2579     if (unix_status > EVMSERR)
2580         return unix_status;
2581
2582      /* If out of range, punt */
2583     /*-----------------------*/
2584     if (unix_status > __ERRNO_MAX)
2585         return SS$_ABORT;
2586
2587
2588      /* Ok, now we have to do it the hard way. */
2589     /*----------------------------------------*/
2590     switch(unix_status) {
2591     case 0:     return SS$_NORMAL;
2592     case EPERM: return SS$_NOPRIV;
2593     case ENOENT: return SS$_NOSUCHOBJECT;
2594     case ESRCH: return SS$_UNREACHABLE;
2595     case EINTR: return SS$_ABORT;
2596     /* case EIO: */
2597     /* case ENXIO:  */
2598     case E2BIG: return SS$_BUFFEROVF;
2599     /* case ENOEXEC */
2600     case EBADF: return RMS$_IFI;
2601     case ECHILD: return SS$_NONEXPR;
2602     /* case EAGAIN */
2603     case ENOMEM: return SS$_INSFMEM;
2604     case EACCES: return SS$_FILACCERR;
2605     case EFAULT: return SS$_ACCVIO;
2606     /* case ENOTBLK */
2607     case EBUSY: return SS$_DEVOFFLINE;
2608     case EEXIST: return RMS$_FEX;
2609     /* case EXDEV */
2610     case ENODEV: return SS$_NOSUCHDEV;
2611     case ENOTDIR: return RMS$_DIR;
2612     /* case EISDIR */
2613     case EINVAL: return SS$_INVARG;
2614     /* case ENFILE */
2615     /* case EMFILE */
2616     /* case ENOTTY */
2617     /* case ETXTBSY */
2618     /* case EFBIG */
2619     case ENOSPC: return SS$_DEVICEFULL;
2620     case ESPIPE: return LIB$_INVARG;
2621     /* case EROFS: */
2622     /* case EMLINK: */
2623     /* case EPIPE: */
2624     /* case EDOM */
2625     case ERANGE: return LIB$_INVARG;
2626     /* case EWOULDBLOCK */
2627     /* case EINPROGRESS */
2628     /* case EALREADY */
2629     /* case ENOTSOCK */
2630     /* case EDESTADDRREQ */
2631     /* case EMSGSIZE */
2632     /* case EPROTOTYPE */
2633     /* case ENOPROTOOPT */
2634     /* case EPROTONOSUPPORT */
2635     /* case ESOCKTNOSUPPORT */
2636     /* case EOPNOTSUPP */
2637     /* case EPFNOSUPPORT */
2638     /* case EAFNOSUPPORT */
2639     /* case EADDRINUSE */
2640     /* case EADDRNOTAVAIL */
2641     /* case ENETDOWN */
2642     /* case ENETUNREACH */
2643     /* case ENETRESET */
2644     /* case ECONNABORTED */
2645     /* case ECONNRESET */
2646     /* case ENOBUFS */
2647     /* case EISCONN */
2648     case ENOTCONN: return SS$_CLEARED;
2649     /* case ESHUTDOWN */
2650     /* case ETOOMANYREFS */
2651     /* case ETIMEDOUT */
2652     /* case ECONNREFUSED */
2653     /* case ELOOP */
2654     /* case ENAMETOOLONG */
2655     /* case EHOSTDOWN */
2656     /* case EHOSTUNREACH */
2657     /* case ENOTEMPTY */
2658     /* case EPROCLIM */
2659     /* case EUSERS  */
2660     /* case EDQUOT  */
2661     /* case ENOMSG  */
2662     /* case EIDRM */
2663     /* case EALIGN */
2664     /* case ESTALE */
2665     /* case EREMOTE */
2666     /* case ENOLCK */
2667     /* case ENOSYS */
2668     /* case EFTYPE */
2669     /* case ECANCELED */
2670     /* case EFAIL */
2671     /* case EINPROG */
2672     case ENOTSUP:
2673         return SS$_UNSUPPORTED;
2674     /* case EDEADLK */
2675     /* case ENWAIT */
2676     /* case EILSEQ */
2677     /* case EBADCAT */
2678     /* case EBADMSG */
2679     /* case EABANDONED */
2680     default:
2681         return SS$_ABORT; /* punt */
2682     }
2683
2684   return SS$_ABORT; /* Should not get here */
2685 }
2686
2687
2688 /* default piping mailbox size */
2689 #define PERL_BUFSIZ        512
2690
2691
2692 static void
2693 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2694 {
2695   unsigned long int mbxbufsiz;
2696   static unsigned long int syssize = 0;
2697   unsigned long int dviitm = DVI$_DEVNAM;
2698   char csize[LNM$C_NAMLENGTH+1];
2699   int sts;
2700
2701   if (!syssize) {
2702     unsigned long syiitm = SYI$_MAXBUF;
2703     /*
2704      * Get the SYSGEN parameter MAXBUF
2705      *
2706      * If the logical 'PERL_MBX_SIZE' is defined
2707      * use the value of the logical instead of PERL_BUFSIZ, but
2708      * keep the size between 128 and MAXBUF.
2709      *
2710      */
2711     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2712   }
2713
2714   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2715       mbxbufsiz = atoi(csize);
2716   } else {
2717       mbxbufsiz = PERL_BUFSIZ;
2718   }
2719   if (mbxbufsiz < 128) mbxbufsiz = 128;
2720   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2721
2722   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2723
2724   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2725   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2726
2727 }  /* end of create_mbx() */
2728
2729
2730 /*{{{  my_popen and my_pclose*/
2731
2732 typedef struct _iosb           IOSB;
2733 typedef struct _iosb*         pIOSB;
2734 typedef struct _pipe           Pipe;
2735 typedef struct _pipe*         pPipe;
2736 typedef struct pipe_details    Info;
2737 typedef struct pipe_details*  pInfo;
2738 typedef struct _srqp            RQE;
2739 typedef struct _srqp*          pRQE;
2740 typedef struct _tochildbuf      CBuf;
2741 typedef struct _tochildbuf*    pCBuf;
2742
2743 struct _iosb {
2744     unsigned short status;
2745     unsigned short count;
2746     unsigned long  dvispec;
2747 };
2748
2749 #pragma member_alignment save
2750 #pragma nomember_alignment quadword
2751 struct _srqp {          /* VMS self-relative queue entry */
2752     unsigned long qptr[2];
2753 };
2754 #pragma member_alignment restore
2755 static RQE  RQE_ZERO = {0,0};
2756
2757 struct _tochildbuf {
2758     RQE             q;
2759     int             eof;
2760     unsigned short  size;
2761     char            *buf;
2762 };
2763
2764 struct _pipe {
2765     RQE            free;
2766     RQE            wait;
2767     int            fd_out;
2768     unsigned short chan_in;
2769     unsigned short chan_out;
2770     char          *buf;
2771     unsigned int   bufsize;
2772     IOSB           iosb;
2773     IOSB           iosb2;
2774     int           *pipe_done;
2775     int            retry;
2776     int            type;
2777     int            shut_on_empty;
2778     int            need_wake;
2779     pPipe         *home;
2780     pInfo          info;
2781     pCBuf          curr;
2782     pCBuf          curr2;
2783 #if defined(PERL_IMPLICIT_CONTEXT)
2784     void            *thx;           /* Either a thread or an interpreter */
2785                                     /* pointer, depending on how we're built */
2786 #endif
2787 };
2788
2789
2790 struct pipe_details
2791 {
2792     pInfo           next;
2793     PerlIO *fp;  /* file pointer to pipe mailbox */
2794     int useFILE; /* using stdio, not perlio */
2795     int pid;   /* PID of subprocess */
2796     int mode;  /* == 'r' if pipe open for reading */
2797     int done;  /* subprocess has completed */
2798     int waiting; /* waiting for completion/closure */
2799     int             closing;        /* my_pclose is closing this pipe */
2800     unsigned long   completion;     /* termination status of subprocess */
2801     pPipe           in;             /* pipe in to sub */
2802     pPipe           out;            /* pipe out of sub */
2803     pPipe           err;            /* pipe of sub's sys$error */
2804     int             in_done;        /* true when in pipe finished */
2805     int             out_done;
2806     int             err_done;
2807     unsigned short  xchan;          /* channel to debug xterm */
2808     unsigned short  xchan_valid;    /* channel is assigned */
2809 };
2810
2811 struct exit_control_block
2812 {
2813     struct exit_control_block *flink;
2814     unsigned long int   (*exit_routine)();
2815     unsigned long int arg_count;
2816     unsigned long int *status_address;
2817     unsigned long int exit_status;
2818 };
2819
2820 typedef struct _closed_pipes    Xpipe;
2821 typedef struct _closed_pipes*  pXpipe;
2822
2823 struct _closed_pipes {
2824     int             pid;            /* PID of subprocess */
2825     unsigned long   completion;     /* termination status of subprocess */
2826 };
2827 #define NKEEPCLOSED 50
2828 static Xpipe closed_list[NKEEPCLOSED];
2829 static int   closed_index = 0;
2830 static int   closed_num = 0;
2831
2832 #define RETRY_DELAY     "0 ::0.20"
2833 #define MAX_RETRY              50
2834
2835 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2836 static unsigned long mypid;
2837 static unsigned long delaytime[2];
2838
2839 static pInfo open_pipes = NULL;
2840 static $DESCRIPTOR(nl_desc, "NL:");
2841
2842 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2843
2844
2845
2846 static unsigned long int
2847 pipe_exit_routine(pTHX)
2848 {
2849     pInfo info;
2850     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2851     int sts, did_stuff, need_eof, j;
2852
2853    /*
2854     * Flush any pending i/o, but since we are in process run-down, be
2855     * careful about referencing PerlIO structures that may already have
2856     * been deallocated.  We may not even have an interpreter anymore.
2857     */
2858     info = open_pipes;
2859     while (info) {
2860         if (info->fp) {
2861            if (!info->useFILE
2862 #if defined(USE_ITHREADS)
2863              && my_perl
2864 #endif
2865              && PL_perlio_fd_refcnt)
2866                PerlIO_flush(info->fp);
2867            else
2868                fflush((FILE *)info->fp);
2869         }
2870         info = info->next;
2871     }
2872
2873     /*
2874      next we try sending an EOF...ignore if doesn't work, make sure we
2875      don't hang
2876     */
2877     did_stuff = 0;
2878     info = open_pipes;
2879
2880     while (info) {
2881       int need_eof;
2882       _ckvmssts_noperl(sys$setast(0));
2883       if (info->in && !info->in->shut_on_empty) {
2884         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2885                           0, 0, 0, 0, 0, 0));
2886         info->waiting = 1;
2887         did_stuff = 1;
2888       }
2889       _ckvmssts_noperl(sys$setast(1));
2890       info = info->next;
2891     }
2892
2893     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2894
2895     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2896         int nwait = 0;
2897
2898         info = open_pipes;
2899         while (info) {
2900           _ckvmssts_noperl(sys$setast(0));
2901           if (info->waiting && info->done)
2902                 info->waiting = 0;
2903           nwait += info->waiting;
2904           _ckvmssts_noperl(sys$setast(1));
2905           info = info->next;
2906         }
2907         if (!nwait) break;
2908         sleep(1);
2909     }
2910
2911     did_stuff = 0;
2912     info = open_pipes;
2913     while (info) {
2914       _ckvmssts_noperl(sys$setast(0));
2915       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2916         sts = sys$forcex(&info->pid,0,&abort);
2917         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2918         did_stuff = 1;
2919       }
2920       _ckvmssts_noperl(sys$setast(1));
2921       info = info->next;
2922     }
2923
2924     /* again, wait for effect */
2925
2926     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2927         int nwait = 0;
2928
2929         info = open_pipes;
2930         while (info) {
2931           _ckvmssts_noperl(sys$setast(0));
2932           if (info->waiting && info->done)
2933                 info->waiting = 0;
2934           nwait += info->waiting;
2935           _ckvmssts_noperl(sys$setast(1));
2936           info = info->next;
2937         }
2938         if (!nwait) break;
2939         sleep(1);
2940     }
2941
2942     info = open_pipes;
2943     while (info) {
2944       _ckvmssts_noperl(sys$setast(0));
2945       if (!info->done) {  /* We tried to be nice . . . */
2946         sts = sys$delprc(&info->pid,0);
2947         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2948         info->done = 1;  /* sys$delprc is as done as we're going to get. */
2949       }
2950       _ckvmssts_noperl(sys$setast(1));
2951       info = info->next;
2952     }
2953
2954     while(open_pipes) {
2955       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2956       else if (!(sts & 1)) retsts = sts;
2957     }
2958     return retsts;
2959 }
2960
2961 static struct exit_control_block pipe_exitblock =
2962        {(struct exit_control_block *) 0,
2963         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2964
2965 static void pipe_mbxtofd_ast(pPipe p);
2966 static void pipe_tochild1_ast(pPipe p);
2967 static void pipe_tochild2_ast(pPipe p);
2968
2969 static void
2970 popen_completion_ast(pInfo info)
2971 {
2972   pInfo i = open_pipes;
2973   int iss;
2974   int sts;
2975   pXpipe x;
2976
2977   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2978   closed_list[closed_index].pid = info->pid;
2979   closed_list[closed_index].completion = info->completion;
2980   closed_index++;
2981   if (closed_index == NKEEPCLOSED)
2982     closed_index = 0;
2983   closed_num++;
2984
2985   while (i) {
2986     if (i == info) break;
2987     i = i->next;
2988   }
2989   if (!i) return;       /* unlinked, probably freed too */
2990
2991   info->done = TRUE;
2992
2993 /*
2994     Writing to subprocess ...
2995             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2996
2997             chan_out may be waiting for "done" flag, or hung waiting
2998             for i/o completion to child...cancel the i/o.  This will
2999             put it into "snarf mode" (done but no EOF yet) that discards
3000             input.
3001
3002     Output from subprocess (stdout, stderr) needs to be flushed and
3003     shut down.   We try sending an EOF, but if the mbx is full the pipe
3004     routine should still catch the "shut_on_empty" flag, telling it to
3005     use immediate-style reads so that "mbx empty" -> EOF.
3006
3007
3008 */
3009   if (info->in && !info->in_done) {               /* only for mode=w */
3010         if (info->in->shut_on_empty && info->in->need_wake) {
3011             info->in->need_wake = FALSE;
3012             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3013         } else {
3014             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3015         }
3016   }
3017
3018   if (info->out && !info->out_done) {             /* were we also piping output? */
3019       info->out->shut_on_empty = TRUE;
3020       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3021       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3022       _ckvmssts_noperl(iss);
3023   }
3024
3025   if (info->err && !info->err_done) {        /* we were piping stderr */
3026         info->err->shut_on_empty = TRUE;
3027         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3028         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3029         _ckvmssts_noperl(iss);
3030   }
3031   _ckvmssts_noperl(sys$setef(pipe_ef));
3032
3033 }
3034
3035 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3036 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3037
3038 /*
3039     we actually differ from vmstrnenv since we use this to
3040     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3041     are pointing to the same thing
3042 */
3043
3044 static unsigned short
3045 popen_translate(pTHX_ char *logical, char *result)
3046 {
3047     int iss;
3048     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3049     $DESCRIPTOR(d_log,"");
3050     struct _il3 {
3051         unsigned short length;
3052         unsigned short code;
3053         char *         buffer_addr;
3054         unsigned short *retlenaddr;
3055     } itmlst[2];
3056     unsigned short l, ifi;
3057
3058     d_log.dsc$a_pointer = logical;
3059     d_log.dsc$w_length  = strlen(logical);
3060
3061     itmlst[0].code = LNM$_STRING;
3062     itmlst[0].length = 255;
3063     itmlst[0].buffer_addr = result;
3064     itmlst[0].retlenaddr = &l;
3065
3066     itmlst[1].code = 0;
3067     itmlst[1].length = 0;
3068     itmlst[1].buffer_addr = 0;
3069     itmlst[1].retlenaddr = 0;
3070
3071     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3072     if (iss == SS$_NOLOGNAM) {
3073         iss = SS$_NORMAL;
3074         l = 0;
3075     }
3076     if (!(iss&1)) lib$signal(iss);
3077     result[l] = '\0';
3078 /*
3079     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3080     strip it off and return the ifi, if any
3081 */
3082     ifi  = 0;
3083     if (result[0] == 0x1b && result[1] == 0x00) {
3084         memmove(&ifi,result+2,2);
3085         strcpy(result,result+4);
3086     }
3087     return ifi;     /* this is the RMS internal file id */
3088 }
3089
3090 static void pipe_infromchild_ast(pPipe p);
3091
3092 /*
3093     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3094     inside an AST routine without worrying about reentrancy and which Perl
3095     memory allocator is being used.
3096
3097     We read data and queue up the buffers, then spit them out one at a
3098     time to the output mailbox when the output mailbox is ready for one.
3099
3100 */
3101 #define INITIAL_TOCHILDQUEUE  2
3102
3103 static pPipe
3104 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3105 {
3106     pPipe p;
3107     pCBuf b;
3108     char mbx1[64], mbx2[64];
3109     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3110                                       DSC$K_CLASS_S, mbx1},
3111                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3112                                       DSC$K_CLASS_S, mbx2};
3113     unsigned int dviitm = DVI$_DEVBUFSIZ;
3114     int j, n;
3115
3116     n = sizeof(Pipe);
3117     _ckvmssts(lib$get_vm(&n, &p));
3118
3119     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3120     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3121     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3122
3123     p->buf           = 0;
3124     p->shut_on_empty = FALSE;
3125     p->need_wake     = FALSE;
3126     p->type          = 0;
3127     p->retry         = 0;
3128     p->iosb.status   = SS$_NORMAL;
3129     p->iosb2.status  = SS$_NORMAL;
3130     p->free          = RQE_ZERO;
3131     p->wait          = RQE_ZERO;
3132     p->curr          = 0;
3133     p->curr2         = 0;
3134     p->info          = 0;
3135 #ifdef PERL_IMPLICIT_CONTEXT
3136     p->thx           = aTHX;
3137 #endif
3138
3139     n = sizeof(CBuf) + p->bufsize;
3140
3141     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3142         _ckvmssts(lib$get_vm(&n, &b));
3143         b->buf = (char *) b + sizeof(CBuf);
3144         _ckvmssts(lib$insqhi(b, &p->free));
3145     }
3146
3147     pipe_tochild2_ast(p);
3148     pipe_tochild1_ast(p);
3149     strcpy(wmbx, mbx1);
3150     strcpy(rmbx, mbx2);
3151     return p;
3152 }
3153
3154 /*  reads the MBX Perl is writing, and queues */
3155
3156 static void
3157 pipe_tochild1_ast(pPipe p)
3158 {
3159     pCBuf b = p->curr;
3160     int iss = p->iosb.status;
3161     int eof = (iss == SS$_ENDOFFILE);
3162     int sts;
3163 #ifdef PERL_IMPLICIT_CONTEXT
3164     pTHX = p->thx;
3165 #endif
3166
3167     if (p->retry) {
3168         if (eof) {
3169             p->shut_on_empty = TRUE;
3170             b->eof     = TRUE;
3171             _ckvmssts(sys$dassgn(p->chan_in));
3172         } else  {
3173             _ckvmssts(iss);
3174         }
3175
3176         b->eof  = eof;
3177         b->size = p->iosb.count;
3178         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3179         if (p->need_wake) {
3180             p->need_wake = FALSE;
3181             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3182         }
3183     } else {
3184         p->retry = 1;   /* initial call */
3185     }
3186
3187     if (eof) {                  /* flush the free queue, return when done */
3188         int n = sizeof(CBuf) + p->bufsize;
3189         while (1) {
3190             iss = lib$remqti(&p->free, &b);
3191             if (iss == LIB$_QUEWASEMP) return;
3192             _ckvmssts(iss);
3193             _ckvmssts(lib$free_vm(&n, &b));
3194         }
3195     }
3196
3197     iss = lib$remqti(&p->free, &b);
3198     if (iss == LIB$_QUEWASEMP) {
3199         int n = sizeof(CBuf) + p->bufsize;
3200         _ckvmssts(lib$get_vm(&n, &b));
3201         b->buf = (char *) b + sizeof(CBuf);
3202     } else {
3203        _ckvmssts(iss);
3204     }
3205
3206     p->curr = b;
3207     iss = sys$qio(0,p->chan_in,
3208              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3209              &p->iosb,
3210              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3211     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3212     _ckvmssts(iss);
3213 }
3214
3215
3216 /* writes queued buffers to output, waits for each to complete before
3217    doing the next */
3218
3219 static void
3220 pipe_tochild2_ast(pPipe p)
3221 {
3222     pCBuf b = p->curr2;
3223     int iss = p->iosb2.status;
3224     int n = sizeof(CBuf) + p->bufsize;
3225     int done = (p->info && p->info->done) ||
3226               iss == SS$_CANCEL || iss == SS$_ABORT;
3227 #if defined(PERL_IMPLICIT_CONTEXT)
3228     pTHX = p->thx;
3229 #endif
3230
3231     do {
3232         if (p->type) {         /* type=1 has old buffer, dispose */
3233             if (p->shut_on_empty) {
3234                 _ckvmssts(lib$free_vm(&n, &b));
3235             } else {
3236                 _ckvmssts(lib$insqhi(b, &p->free));
3237             }
3238             p->type = 0;
3239         }
3240
3241         iss = lib$remqti(&p->wait, &b);
3242         if (iss == LIB$_QUEWASEMP) {
3243             if (p->shut_on_empty) {
3244                 if (done) {
3245                     _ckvmssts(sys$dassgn(p->chan_out));
3246                     *p->pipe_done = TRUE;
3247                     _ckvmssts(sys$setef(pipe_ef));
3248                 } else {
3249                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3250                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3251                 }
3252                 return;
3253             }
3254             p->need_wake = TRUE;
3255             return;
3256         }
3257         _ckvmssts(iss);
3258         p->type = 1;
3259     } while (done);
3260
3261
3262     p->curr2 = b;
3263     if (b->eof) {
3264         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3265             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3266     } else {
3267         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3268             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3269     }
3270
3271     return;
3272
3273 }
3274
3275
3276 static pPipe
3277 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3278 {
3279     pPipe p;
3280     char mbx1[64], mbx2[64];
3281     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3282                                       DSC$K_CLASS_S, mbx1},
3283                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3284                                       DSC$K_CLASS_S, mbx2};
3285     unsigned int dviitm = DVI$_DEVBUFSIZ;
3286
3287     int n = sizeof(Pipe);
3288     _ckvmssts(lib$get_vm(&n, &p));
3289     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3290     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3291
3292     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3293     n = p->bufsize * sizeof(char);
3294     _ckvmssts(lib$get_vm(&n, &p->buf));
3295     p->shut_on_empty = FALSE;
3296     p->info   = 0;
3297     p->type   = 0;
3298     p->iosb.status = SS$_NORMAL;
3299 #if defined(PERL_IMPLICIT_CONTEXT)
3300     p->thx = aTHX;
3301 #endif
3302     pipe_infromchild_ast(p);
3303
3304     strcpy(wmbx, mbx1);
3305     strcpy(rmbx, mbx2);
3306     return p;
3307 }
3308
3309 static void
3310 pipe_infromchild_ast(pPipe p)
3311 {
3312     int iss = p->iosb.status;
3313     int eof = (iss == SS$_ENDOFFILE);
3314     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3315     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3316 #if defined(PERL_IMPLICIT_CONTEXT)
3317     pTHX = p->thx;
3318 #endif
3319
3320     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3321         _ckvmssts(sys$dassgn(p->chan_out));
3322         p->chan_out = 0;
3323     }
3324
3325     /* read completed:
3326             input shutdown if EOF from self (done or shut_on_empty)
3327             output shutdown if closing flag set (my_pclose)
3328             send data/eof from child or eof from self
3329             otherwise, re-read (snarf of data from child)
3330     */
3331
3332     if (p->type == 1) {
3333         p->type = 0;
3334         if (myeof && p->chan_in) {                  /* input shutdown */
3335             _ckvmssts(sys$dassgn(p->chan_in));
3336             p->chan_in = 0;
3337         }
3338
3339         if (p->chan_out) {
3340             if (myeof || kideof) {      /* pass EOF to parent */
3341                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3342                               pipe_infromchild_ast, p,
3343                               0, 0, 0, 0, 0, 0));
3344                 return;
3345             } else if (eof) {       /* eat EOF --- fall through to read*/
3346
3347             } else {                /* transmit data */
3348                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3349                               pipe_infromchild_ast,p,
3350                               p->buf, p->iosb.count, 0, 0, 0, 0));
3351                 return;
3352             }
3353         }
3354     }
3355
3356     /*  everything shut? flag as done */
3357
3358     if (!p->chan_in && !p->chan_out) {
3359         *p->pipe_done = TRUE;
3360         _ckvmssts(sys$setef(pipe_ef));
3361         return;
3362     }
3363
3364     /* write completed (or read, if snarfing from child)
3365             if still have input active,
3366                queue read...immediate mode if shut_on_empty so we get EOF if empty
3367             otherwise,
3368                check if Perl reading, generate EOFs as needed
3369     */
3370
3371     if (p->type == 0) {
3372         p->type = 1;
3373         if (p->chan_in) {
3374             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3375                           pipe_infromchild_ast,p,
3376                           p->buf, p->bufsize, 0, 0, 0, 0);
3377             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3378             _ckvmssts(iss);
3379         } else {           /* send EOFs for extra reads */
3380             p->iosb.status = SS$_ENDOFFILE;
3381             p->iosb.dvispec = 0;
3382             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3383                       0, 0, 0,
3384                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3385         }
3386     }
3387 }
3388
3389 static pPipe
3390 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3391 {
3392     pPipe p;
3393     char mbx[64];
3394     unsigned long dviitm = DVI$_DEVBUFSIZ;
3395     struct stat s;
3396     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3397                                       DSC$K_CLASS_S, mbx};
3398     int n = sizeof(Pipe);
3399
3400     /* things like terminals and mbx's don't need this filter */
3401     if (fd && fstat(fd,&s) == 0) {
3402         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3403         char device[65];
3404         unsigned short dev_len;
3405         struct dsc$descriptor_s d_dev;
3406         char * cptr;
3407         struct item_list_3 items[3];
3408         int status;
3409         unsigned short dvi_iosb[4];
3410
3411         cptr = getname(fd, out, 1);
3412         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3413         d_dev.dsc$a_pointer = out;
3414         d_dev.dsc$w_length = strlen(out);
3415         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3416         d_dev.dsc$b_class = DSC$K_CLASS_S;
3417
3418         items[0].len = 4;
3419         items[0].code = DVI$_DEVCHAR;
3420         items[0].bufadr = &devchar;
3421         items[0].retadr = NULL;
3422         items[1].len = 64;
3423         items[1].code = DVI$_FULLDEVNAM;
3424         items[1].bufadr = device;
3425         items[1].retadr = &dev_len;
3426         items[2].len = 0;
3427         items[2].code = 0;
3428
3429         status = sys$getdviw
3430                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3431         _ckvmssts(status);
3432         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3433             device[dev_len] = 0;
3434
3435             if (!(devchar & DEV$M_DIR)) {
3436                 strcpy(out, device);
3437                 return 0;
3438             }
3439         }
3440     }
3441
3442     _ckvmssts(lib$get_vm(&n, &p));
3443     p->fd_out = dup(fd);
3444     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3445     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3446     n = (p->bufsize+1) * sizeof(char);
3447     _ckvmssts(lib$get_vm(&n, &p->buf));
3448     p->shut_on_empty = FALSE;
3449     p->retry = 0;
3450     p->info  = 0;
3451     strcpy(out, mbx);
3452
3453     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3454                   pipe_mbxtofd_ast, p,
3455                   p->buf, p->bufsize, 0, 0, 0, 0));
3456
3457     return p;
3458 }
3459
3460 static void
3461 pipe_mbxtofd_ast(pPipe p)
3462 {
3463     int iss = p->iosb.status;
3464     int done = p->info->done;
3465     int iss2;
3466     int eof = (iss == SS$_ENDOFFILE);
3467     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3468     int err = !(iss&1) && !eof;
3469 #if defined(PERL_IMPLICIT_CONTEXT)
3470     pTHX = p->thx;
3471 #endif
3472
3473     if (done && myeof) {               /* end piping */
3474         close(p->fd_out);
3475         sys$dassgn(p->chan_in);
3476         *p->pipe_done = TRUE;
3477         _ckvmssts(sys$setef(pipe_ef));
3478         return;
3479     }
3480
3481     if (!err && !eof) {             /* good data to send to file */
3482         p->buf[p->iosb.count] = '\n';
3483         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3484         if (iss2 < 0) {
3485             p->retry++;
3486             if (p->retry < MAX_RETRY) {
3487                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3488                 return;
3489             }
3490         }
3491         p->retry = 0;
3492     } else if (err) {
3493         _ckvmssts(iss);
3494     }
3495
3496
3497     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3498           pipe_mbxtofd_ast, p,
3499           p->buf, p->bufsize, 0, 0, 0, 0);
3500     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3501     _ckvmssts(iss);
3502 }
3503
3504
3505 typedef struct _pipeloc     PLOC;
3506 typedef struct _pipeloc*   pPLOC;
3507
3508 struct _pipeloc {
3509     pPLOC   next;
3510     char    dir[NAM$C_MAXRSS+1];
3511 };
3512 static pPLOC  head_PLOC = 0;
3513
3514 void
3515 free_pipelocs(pTHX_ void *head)
3516 {
3517     pPLOC p, pnext;
3518     pPLOC *pHead = (pPLOC *)head;
3519
3520     p = *pHead;
3521     while (p) {
3522         pnext = p->next;
3523         PerlMem_free(p);
3524         p = pnext;
3525     }
3526     *pHead = 0;
3527 }
3528
3529 static void
3530 store_pipelocs(pTHX)
3531 {
3532     int    i;
3533     pPLOC  p;
3534     AV    *av = 0;
3535     SV    *dirsv;
3536     GV    *gv;
3537     char  *dir, *x;
3538     char  *unixdir;
3539     char  temp[NAM$C_MAXRSS+1];
3540     STRLEN n_a;
3541
3542     if (head_PLOC)
3543         free_pipelocs(aTHX_ &head_PLOC);
3544
3545 /*  the . directory from @INC comes last */
3546
3547     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3548     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3549     p->next = head_PLOC;
3550     head_PLOC = p;
3551     strcpy(p->dir,"./");
3552
3553 /*  get the directory from $^X */
3554
3555     unixdir = PerlMem_malloc(VMS_MAXRSS);
3556     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3557
3558 #ifdef PERL_IMPLICIT_CONTEXT
3559     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3560 #else
3561     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3562 #endif
3563         strcpy(temp, PL_origargv[0]);
3564         x = strrchr(temp,']');
3565         if (x == NULL) {
3566         x = strrchr(temp,'>');
3567           if (x == NULL) {
3568             /* It could be a UNIX path */
3569             x = strrchr(temp,'/');
3570           }
3571         }
3572         if (x)
3573           x[1] = '\0';
3574         else {
3575           /* Got a bare name, so use default directory */
3576           temp[0] = '.';
3577           temp[1] = '\0';
3578         }
3579
3580         if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3581             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3582             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3583             p->next = head_PLOC;
3584             head_PLOC = p;
3585             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3586             p->dir[NAM$C_MAXRSS] = '\0';
3587         }
3588     }
3589
3590 /*  reverse order of @INC entries, skip "." since entered above */
3591
3592 #ifdef PERL_IMPLICIT_CONTEXT
3593     if (aTHX)
3594 #endif
3595     if (PL_incgv) av = GvAVn(PL_incgv);
3596
3597     for (i = 0; av && i <= AvFILL(av); i++) {
3598         dirsv = *av_fetch(av,i,TRUE);
3599
3600         if (SvROK(dirsv)) continue;
3601         dir = SvPVx(dirsv,n_a);
3602         if (strcmp(dir,".") == 0) continue;
3603         if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3604             continue;
3605
3606         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3607         p->next = head_PLOC;
3608         head_PLOC = p;
3609         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3610         p->dir[NAM$C_MAXRSS] = '\0';
3611     }
3612
3613 /* most likely spot (ARCHLIB) put first in the list */
3614
3615 #ifdef ARCHLIB_EXP
3616     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3617         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3618         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3619         p->next = head_PLOC;
3620         head_PLOC = p;
3621         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3622         p->dir[NAM$C_MAXRSS] = '\0';
3623     }
3624 #endif
3625     PerlMem_free(unixdir);
3626 }
3627
3628 static I32
3629 Perl_cando_by_name_int
3630    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3631 #if !defined(PERL_IMPLICIT_CONTEXT)
3632 #define cando_by_name_int               Perl_cando_by_name_int
3633 #else
3634 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3635 #endif
3636
3637 static char *
3638 find_vmspipe(pTHX)
3639 {
3640     static int   vmspipe_file_status = 0;
3641     static char  vmspipe_file[NAM$C_MAXRSS+1];
3642
3643     /* already found? Check and use ... need read+execute permission */
3644
3645     if (vmspipe_file_status == 1) {
3646         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3647          && cando_by_name_int
3648            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3649             return vmspipe_file;
3650         }
3651         vmspipe_file_status = 0;
3652     }
3653
3654     /* scan through stored @INC, $^X */
3655
3656     if (vmspipe_file_status == 0) {
3657         char file[NAM$C_MAXRSS+1];
3658         pPLOC  p = head_PLOC;
3659
3660         while (p) {
3661             char * exp_res;
3662             int dirlen;
3663             strcpy(file, p->dir);
3664             dirlen = strlen(file);
3665             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3666             file[NAM$C_MAXRSS] = '\0';
3667             p = p->next;
3668
3669             exp_res = do_rmsexpand
3670                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3671             if (!exp_res) continue;
3672
3673             if (cando_by_name_int
3674                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3675              && cando_by_name_int
3676                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3677                 vmspipe_file_status = 1;
3678                 return vmspipe_file;
3679             }
3680         }
3681         vmspipe_file_status = -1;   /* failed, use tempfiles */
3682     }
3683
3684     return 0;
3685 }
3686
3687 static FILE *
3688 vmspipe_tempfile(pTHX)
3689 {
3690     char file[NAM$C_MAXRSS+1];
3691     FILE *fp;
3692     static int index = 0;
3693     Stat_t s0, s1;
3694     int cmp_result;
3695
3696     /* create a tempfile */
3697
3698     /* we can't go from   W, shr=get to  R, shr=get without
3699        an intermediate vulnerable state, so don't bother trying...
3700
3701        and lib$spawn doesn't shr=put, so have to close the write
3702
3703        So... match up the creation date/time and the FID to
3704        make sure we're dealing with the same file
3705
3706     */
3707
3708     index++;
3709     if (!decc_filename_unix_only) {
3710       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3711       fp = fopen(file,"w");
3712       if (!fp) {
3713         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3714         fp = fopen(file,"w");
3715         if (!fp) {
3716             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3717             fp = fopen(file,"w");
3718         }
3719       }
3720      }
3721      else {
3722       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3723       fp = fopen(file,"w");
3724       if (!fp) {
3725         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3726         fp = fopen(file,"w");
3727         if (!fp) {
3728           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3729           fp = fopen(file,"w");
3730         }
3731       }
3732     }
3733     if (!fp) return 0;  /* we're hosed */
3734
3735     fprintf(fp,"$! 'f$verify(0)'\n");
3736     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3737     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3738     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3739     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3740     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3741     fprintf(fp,"$ perl_del    = \"delete\"\n");
3742     fprintf(fp,"$ pif         = \"if\"\n");
3743     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3744     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3745     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3746     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3747     fprintf(fp,"$!  --- build command line to get max possible length\n");
3748     fprintf(fp,"$c=perl_popen_cmd0\n");
3749     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3750     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3751     fprintf(fp,"$x=perl_popen_cmd3\n");
3752     fprintf(fp,"$c=c+x\n");
3753     fprintf(fp,"$ perl_on\n");
3754     fprintf(fp,"$ 'c'\n");
3755     fprintf(fp,"$ perl_status = $STATUS\n");
3756     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3757     fprintf(fp,"$ perl_exit 'perl_status'\n");
3758     fsync(fileno(fp));
3759
3760     fgetname(fp, file, 1);
3761     fstat(fileno(fp), (struct stat *)&s0);
3762     fclose(fp);
3763
3764     if (decc_filename_unix_only)
3765         do_tounixspec(file, file, 0, NULL);
3766     fp = fopen(file,"r","shr=get");
3767     if (!fp) return 0;
3768     fstat(fileno(fp), (struct stat *)&s1);
3769
3770     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3771     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3772         fclose(fp);
3773         return 0;
3774     }
3775
3776     return fp;
3777 }
3778
3779
3780 static int vms_is_syscommand_xterm(void)
3781 {
3782     const static struct dsc$descriptor_s syscommand_dsc =
3783       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3784
3785     const static struct dsc$descriptor_s decwdisplay_dsc =
3786       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3787
3788     struct item_list_3 items[2];
3789     unsigned short dvi_iosb[4];
3790     unsigned long devchar;
3791     unsigned long devclass;
3792     int status;
3793
3794     /* Very simple check to guess if sys$command is a decterm? */
3795     /* First see if the DECW$DISPLAY: device exists */
3796     items[0].len = 4;
3797     items[0].code = DVI$_DEVCHAR;
3798     items[0].bufadr = &devchar;
3799     items[0].retadr = NULL;
3800     items[1].len = 0;
3801     items[1].code = 0;
3802
3803     status = sys$getdviw
3804         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3805
3806     if ($VMS_STATUS_SUCCESS(status)) {
3807         status = dvi_iosb[0];
3808     }
3809
3810     if (!$VMS_STATUS_SUCCESS(status)) {
3811         SETERRNO(EVMSERR, status);
3812         return -1;
3813     }
3814
3815     /* If it does, then for now assume that we are on a workstation */
3816     /* Now verify that SYS$COMMAND is a terminal */
3817     /* for creating the debugger DECTerm */
3818
3819     items[0].len = 4;
3820     items[0].code = DVI$_DEVCLASS;
3821     items[0].bufadr = &devclass;
3822     items[0].retadr = NULL;
3823     items[1].len = 0;
3824     items[1].code = 0;
3825
3826     status = sys$getdviw
3827         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3828
3829     if ($VMS_STATUS_SUCCESS(status)) {
3830         status = dvi_iosb[0];
3831     }
3832
3833     if (!$VMS_STATUS_SUCCESS(status)) {
3834         SETERRNO(EVMSERR, status);
3835         return -1;
3836     }
3837     else {
3838         if (devclass == DC$_TERM) {
3839             return 0;
3840         }
3841     }
3842     return -1;
3843 }
3844
3845 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3846 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3847 {
3848     int status;
3849     int ret_stat;
3850     char * ret_char;
3851     char device_name[65];
3852     unsigned short device_name_len;
3853     struct dsc$descriptor_s customization_dsc;
3854     struct dsc$descriptor_s device_name_dsc;
3855     const char * cptr;
3856     char * tptr;
3857     char customization[200];
3858     char title[40];
3859     pInfo info = NULL;
3860     char mbx1[64];
3861     unsigned short p_chan;
3862     int n;
3863     unsigned short iosb[4];
3864     struct item_list_3 items[2];
3865     const char * cust_str =
3866         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3867     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3868                                           DSC$K_CLASS_S, mbx1};
3869
3870      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3871     /*---------------------------------------*/
3872     VAXC$ESTABLISH((__vms_handler)LIB$SIG_TO_RET);
3873
3874
3875     /* Make sure that this is from the Perl debugger */
3876     ret_char = strstr(cmd," xterm ");
3877     if (ret_char == NULL)
3878         return NULL;
3879     cptr = ret_char + 7;
3880     ret_char = strstr(cmd,"tty");
3881     if (ret_char == NULL)
3882         return NULL;
3883     ret_char = strstr(cmd,"sleep");
3884     if (ret_char == NULL)
3885         return NULL;
3886
3887     if (decw_term_port == 0) {
3888         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3889         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3890         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3891
3892         status = LIB$FIND_IMAGE_SYMBOL
3893                                (&filename1_dsc,
3894                                 &decw_term_port_dsc,
3895                                 (void *)&decw_term_port,
3896                                 NULL,
3897                                 0);
3898
3899         /* Try again with the other image name */
3900         if (!$VMS_STATUS_SUCCESS(status)) {
3901
3902             status = LIB$FIND_IMAGE_SYMBOL
3903                                (&filename2_dsc,
3904                                 &decw_term_port_dsc,
3905                                 (void *)&decw_term_port,
3906                                 NULL,
3907                                 0);
3908
3909         }
3910
3911     }
3912
3913
3914     /* No decw$term_port, give it up */
3915     if (!$VMS_STATUS_SUCCESS(status))
3916         return NULL;
3917
3918     /* Are we on a workstation? */
3919     /* to do: capture the rows / columns and pass their properties */
3920     ret_stat = vms_is_syscommand_xterm();
3921     if (ret_stat < 0)
3922         return NULL;
3923
3924     /* Make the title: */
3925     ret_char = strstr(cptr,"-title");
3926     if (ret_char != NULL) {
3927         while ((*cptr != 0) && (*cptr != '\"')) {
3928             cptr++;
3929         }
3930         if (*cptr == '\"')
3931             cptr++;
3932         n = 0;
3933         while ((*cptr != 0) && (*cptr != '\"')) {
3934             title[n] = *cptr;
3935             n++;
3936             if (n == 39) {
3937                 title[39] == 0;
3938                 break;
3939             }
3940             cptr++;
3941         }
3942         title[n] = 0;
3943     }
3944     else {
3945             /* Default title */
3946             strcpy(title,"Perl Debug DECTerm");
3947     }
3948     sprintf(customization, cust_str, title);
3949
3950     customization_dsc.dsc$a_pointer = customization;
3951     customization_dsc.dsc$w_length = strlen(customization);
3952     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3953     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3954
3955     device_name_dsc.dsc$a_pointer = device_name;
3956     device_name_dsc.dsc$w_length = sizeof device_name -1;
3957     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3958     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3959
3960     device_name_len = 0;
3961
3962     /* Try to create the window */
3963      status = (*decw_term_port)
3964        (NULL,
3965         NULL,
3966         &customization_dsc,
3967         &device_name_dsc,
3968         &device_name_len,
3969         NULL,
3970         NULL,
3971         NULL);
3972     if (!$VMS_STATUS_SUCCESS(status)) {
3973         SETERRNO(EVMSERR, status);
3974         return NULL;
3975     }
3976
3977     device_name[device_name_len] = '\0';
3978
3979     /* Need to set this up to look like a pipe for cleanup */
3980     n = sizeof(Info);
3981     status = lib$get_vm(&n, &info);
3982     if (!$VMS_STATUS_SUCCESS(status)) {
3983         SETERRNO(ENOMEM, status);
3984         return NULL;
3985     }
3986
3987     info->mode = *mode;
3988     info->done = FALSE;
3989     info->completion = 0;
3990     info->closing    = FALSE;
3991     info->in         = 0;
3992     info->out        = 0;
3993     info->err        = 0;
3994     info->fp         = Nullfp;
3995     info->useFILE    = 0;
3996     info->waiting    = 0;
3997     info->in_done    = TRUE;
3998     info->out_done   = TRUE;
3999     info->err_done   = TRUE;
4000
4001     /* Assign a channel on this so that it will persist, and not login */
4002     /* We stash this channel in the info structure for reference. */
4003     /* The created xterm self destructs when the last channel is removed */
4004     /* and it appears that perl5db.pl (perl debugger) does this routinely */
4005     /* So leave this assigned. */
4006     device_name_dsc.dsc$w_length = device_name_len;
4007     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4008     if (!$VMS_STATUS_SUCCESS(status)) {
4009         SETERRNO(EVMSERR, status);
4010         return NULL;
4011     }
4012     info->xchan_valid = 1;
4013
4014     /* Now create a mailbox to be read by the application */
4015
4016     create_mbx(aTHX_ &p_chan, &d_mbx1);
4017
4018     /* write the name of the created terminal to the mailbox */
4019     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4020             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4021
4022     if (!$VMS_STATUS_SUCCESS(status)) {
4023         SETERRNO(EVMSERR, status);
4024         return NULL;
4025     }
4026
4027     info->fp  = PerlIO_open(mbx1, mode);
4028
4029     /* Done with this channel */
4030     sys$dassgn(p_chan);
4031
4032     /* If any errors, then clean up */
4033     if (!info->fp) {
4034         n = sizeof(Info);
4035         _ckvmssts(lib$free_vm(&n, &info));
4036         return NULL;
4037         }
4038
4039     /* All done */
4040     return info->fp;
4041 }
4042
4043 static PerlIO *
4044 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4045 {
4046     static int handler_set_up = FALSE;
4047     unsigned long int sts, flags = CLI$M_NOWAIT;
4048     /* The use of a GLOBAL table (as was done previously) rendered
4049      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4050      * environment.  Hence we've switched to LOCAL symbol table.
4051      */
4052     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4053     int j, wait = 0, n;
4054     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4055     char *in, *out, *err, mbx[512];
4056     FILE *tpipe = 0;
4057     char tfilebuf[NAM$C_MAXRSS+1];
4058     pInfo info = NULL;
4059     char cmd_sym_name[20];
4060     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4061                                       DSC$K_CLASS_S, symbol};
4062     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4063                                       DSC$K_CLASS_S, 0};
4064     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4065                                       DSC$K_CLASS_S, cmd_sym_name};
4066     struct dsc$descriptor_s *vmscmd;
4067     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4068     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4069     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4070
4071     /* Check here for Xterm create request.  This means looking for
4072      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4073      *  is possible to create an xterm.
4074      */
4075     if (*in_mode == 'r') {
4076         PerlIO * xterm_fd;
4077
4078         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4079         if (xterm_fd != Nullfp)
4080             return xterm_fd;
4081     }
4082
4083     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4084
4085     /* once-per-program initialization...
4086        note that the SETAST calls and the dual test of pipe_ef
4087        makes sure that only the FIRST thread through here does
4088        the initialization...all other threads wait until it's
4089        done.
4090
4091        Yeah, uglier than a pthread call, it's got all the stuff inline
4092        rather than in a separate routine.
4093     */
4094
4095     if (!pipe_ef) {
4096         _ckvmssts(sys$setast(0));
4097         if (!pipe_ef) {
4098             unsigned long int pidcode = JPI$_PID;
4099             $DESCRIPTOR(d_delay, RETRY_DELAY);
4100             _ckvmssts(lib$get_ef(&pipe_ef));
4101             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4102             _ckvmssts(sys$bintim(&d_delay, delaytime));
4103         }
4104         if (!handler_set_up) {
4105           _ckvmssts(sys$dclexh(&pipe_exitblock));
4106           handler_set_up = TRUE;
4107         }
4108         _ckvmssts(sys$setast(1));
4109     }
4110
4111     /* see if we can find a VMSPIPE.COM */
4112
4113     tfilebuf[0] = '@';
4114     vmspipe = find_vmspipe(aTHX);
4115     if (vmspipe) {
4116         strcpy(tfilebuf+1,vmspipe);
4117     } else {        /* uh, oh...we're in tempfile hell */
4118         tpipe = vmspipe_tempfile(aTHX);
4119         if (!tpipe) {       /* a fish popular in Boston */
4120             if (ckWARN(WARN_PIPE)) {
4121                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4122             }
4123         return Nullfp;
4124         }
4125         fgetname(tpipe,tfilebuf+1,1);
4126     }
4127     vmspipedsc.dsc$a_pointer = tfilebuf;
4128     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4129
4130     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4131     if (!(sts & 1)) {
4132       switch (sts) {
4133         case RMS$_FNF:  case RMS$_DNF:
4134           set_errno(ENOENT); break;
4135         case RMS$_DIR:
4136           set_errno(ENOTDIR); break;
4137         case RMS$_DEV:
4138           set_errno(ENODEV); break;
4139         case RMS$_PRV:
4140           set_errno(EACCES); break;
4141         case RMS$_SYN:
4142           set_errno(EINVAL); break;
4143         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4144           set_errno(E2BIG); break;
4145         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4146           _ckvmssts(sts); /* fall through */
4147         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4148           set_errno(EVMSERR);
4149       }
4150       set_vaxc_errno(sts);
4151       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4152         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4153       }
4154       *psts = sts;
4155       return Nullfp;
4156     }
4157     n = sizeof(Info);
4158     _ckvmssts(lib$get_vm(&n, &info));
4159
4160     strcpy(mode,in_mode);
4161     info->mode = *mode;
4162     info->done = FALSE;
4163     info->completion = 0;
4164     info->closing    = FALSE;
4165     info->in         = 0;
4166     info->out        = 0;
4167     info->err        = 0;
4168     info->fp         = Nullfp;
4169     info->useFILE    = 0;
4170     info->waiting    = 0;
4171     info->in_done    = TRUE;
4172     info->out_done   = TRUE;
4173     info->err_done   = TRUE;
4174     info->xchan      = 0;
4175     info->xchan_valid = 0;
4176
4177     in = PerlMem_malloc(VMS_MAXRSS);
4178     if (in == NULL) _ckvmssts(SS$_INSFMEM);
4179     out = PerlMem_malloc(VMS_MAXRSS);
4180     if (out == NULL) _ckvmssts(SS$_INSFMEM);
4181     err = PerlMem_malloc(VMS_MAXRSS);
4182     if (err == NULL) _ckvmssts(SS$_INSFMEM);
4183
4184     in[0] = out[0] = err[0] = '\0';
4185
4186     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4187         info->useFILE = 1;
4188         strcpy(p,p+1);
4189     }
4190     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4191         wait = 1;
4192         strcpy(p,p+1);
4193     }
4194
4195     if (*mode == 'r') {             /* piping from subroutine */
4196
4197         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4198         if (info->out) {
4199             info->out->pipe_done = &info->out_done;
4200             info->out_done = FALSE;
4201             info->out->info = info;
4202         }
4203         if (!info->useFILE) {
4204             info->fp  = PerlIO_open(mbx, mode);
4205         } else {
4206             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4207             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4208         }
4209
4210         if (!info->fp && info->out) {
4211             sys$cancel(info->out->chan_out);
4212
4213             while (!info->out_done) {
4214                 int done;
4215                 _ckvmssts(sys$setast(0));
4216                 done = info->out_done;
4217                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4218                 _ckvmssts(sys$setast(1));
4219                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4220             }
4221
4222             if (info->out->buf) {
4223                 n = info->out->bufsize * sizeof(char);
4224                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4225             }
4226             n = sizeof(Pipe);
4227             _ckvmssts(lib$free_vm(&n, &info->out));
4228             n = sizeof(Info);
4229             _ckvmssts(lib$free_vm(&n, &info));
4230             *psts = RMS$_FNF;
4231             return Nullfp;
4232         }
4233
4234         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4235         if (info->err) {
4236             info->err->pipe_done = &info->err_done;
4237             info->err_done = FALSE;
4238             info->err->info = info;
4239         }
4240
4241     } else if (*mode == 'w') {      /* piping to subroutine */
4242
4243         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4244         if (info->out) {
4245             info->out->pipe_done = &info->out_done;
4246             info->out_done = FALSE;
4247             info->out->info = info;
4248         }
4249
4250         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4251         if (info->err) {
4252             info->err->pipe_done = &info->err_done;
4253             info->err_done = FALSE;
4254             info->err->info = info;
4255         }
4256
4257         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4258         if (!info->useFILE) {
4259             info->fp  = PerlIO_open(mbx, mode);
4260         } else {
4261             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4262             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4263         }
4264
4265         if (info->in) {
4266             info->in->pipe_done = &info->in_done;
4267             info->in_done = FALSE;
4268             info->in->info = info;
4269         }
4270
4271         /* error cleanup */
4272         if (!info->fp && info->in) {
4273             info->done = TRUE;
4274             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4275                               0, 0, 0, 0, 0, 0, 0, 0));
4276
4277             while (!info->in_done) {
4278                 int done;
4279                 _ckvmssts(sys$setast(0));
4280                 done = info->in_done;
4281                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4282                 _ckvmssts(sys$setast(1));
4283                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4284             }
4285
4286             if (info->in->buf) {
4287                 n = info->in->bufsize * sizeof(char);
4288                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4289             }
4290             n = sizeof(Pipe);
4291             _ckvmssts(lib$free_vm(&n, &info->in));
4292             n = sizeof(Info);
4293             _ckvmssts(lib$free_vm(&n, &info));
4294             *psts = RMS$_FNF;
4295             return Nullfp;
4296         }
4297
4298
4299     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4300         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4301         if (info->out) {
4302             info->out->pipe_done = &info->out_done;
4303             info->out_done = FALSE;
4304             info->out->info = info;
4305         }
4306
4307         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4308         if (info->err) {
4309             info->err->pipe_done = &info->err_done;
4310             info->err_done = FALSE;
4311             info->err->info = info;
4312         }
4313     }
4314
4315     symbol[MAX_DCL_SYMBOL] = '\0';
4316
4317     strncpy(symbol, in, MAX_DCL_SYMBOL);
4318     d_symbol.dsc$w_length = strlen(symbol);
4319     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4320
4321     strncpy(symbol, err, MAX_DCL_SYMBOL);
4322     d_symbol.dsc$w_length = strlen(symbol);
4323     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4324
4325     strncpy(symbol, out, MAX_DCL_SYMBOL);
4326     d_symbol.dsc$w_length = strlen(symbol);
4327     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4328
4329     /* Done with the names for the pipes */
4330     PerlMem_free(err);
4331     PerlMem_free(out);
4332     PerlMem_free(in);
4333
4334     p = vmscmd->dsc$a_pointer;
4335     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4336     if (*p == '$') p++;                         /* remove leading $ */
4337     while (*p == ' ' || *p == '\t') p++;
4338
4339     for (j = 0; j < 4; j++) {
4340         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4341         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4342
4343     strncpy(symbol, p, MAX_DCL_SYMBOL);
4344     d_symbol.dsc$w_length = strlen(symbol);
4345     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4346
4347         if (strlen(p) > MAX_DCL_SYMBOL) {
4348             p += MAX_DCL_SYMBOL;
4349         } else {
4350             p += strlen(p);
4351         }
4352     }
4353     _ckvmssts(sys$setast(0));
4354     info->next=open_pipes;  /* prepend to list */
4355     open_pipes=info;
4356     _ckvmssts(sys$setast(1));
4357     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4358      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4359      * have SYS$COMMAND if we need it.
4360      */
4361     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4362                       0, &info->pid, &info->completion,
4363                       0, popen_completion_ast,info,0,0,0));
4364
4365     /* if we were using a tempfile, close it now */
4366
4367     if (tpipe) fclose(tpipe);
4368
4369     /* once the subprocess is spawned, it has copied the symbols and
4370        we can get rid of ours */
4371
4372     for (j = 0; j < 4; j++) {
4373         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4374         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4375     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4376     }
4377     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4378     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4379     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4380     vms_execfree(vmscmd);
4381
4382 #ifdef PERL_IMPLICIT_CONTEXT
4383     if (aTHX)
4384 #endif
4385     PL_forkprocess = info->pid;
4386
4387     if (wait) {
4388          int done = 0;
4389          while (!done) {
4390              _ckvmssts(sys$setast(0));
4391              done = info->done;
4392              if (!done) _ckvmssts(sys$clref(pipe_ef));
4393              _ckvmssts(sys$setast(1));
4394              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4395          }
4396         *psts = info->completion;
4397 /* Caller thinks it is open and tries to close it. */
4398 /* This causes some problems, as it changes the error status */
4399 /*        my_pclose(info->fp); */
4400     } else {
4401         *psts = SS$_NORMAL;
4402     }
4403     return info->fp;
4404 }  /* end of safe_popen */
4405
4406
4407 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4408 PerlIO *
4409 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4410 {
4411     int sts;
4412     TAINT_ENV();
4413     TAINT_PROPER("popen");
4414     PERL_FLUSHALL_FOR_CHILD;
4415     return safe_popen(aTHX_ cmd,mode,&sts);
4416 }
4417
4418 /*}}}*/
4419
4420 /*{{{  I32 my_pclose(PerlIO *fp)*/
4421 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4422 {
4423     pInfo info, last = NULL;
4424     unsigned long int retsts;
4425     int done, iss, n;
4426     int status;
4427
4428     for (info = open_pipes; info != NULL; last = info, info = info->next)
4429         if (info->fp == fp) break;
4430
4431     if (info == NULL) {  /* no such pipe open */
4432       set_errno(ECHILD); /* quoth POSIX */
4433       set_vaxc_errno(SS$_NONEXPR);
4434       return -1;
4435     }
4436
4437     /* If we were writing to a subprocess, insure that someone reading from
4438      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4439      * produce an EOF record in the mailbox.
4440      *
4441      *  well, at least sometimes it *does*, so we have to watch out for
4442      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4443      */
4444      if (info->fp) {
4445         if (!info->useFILE
4446 #if defined(USE_ITHREADS)
4447           && my_perl
4448 #endif
4449           && PL_perlio_fd_refcnt)
4450             PerlIO_flush(info->fp);
4451         else
4452             fflush((FILE *)info->fp);
4453     }
4454
4455     _ckvmssts(sys$setast(0));
4456      info->closing = TRUE;
4457      done = info->done && info->in_done && info->out_done && info->err_done;
4458      /* hanging on write to Perl's input? cancel it */
4459      if (info->mode == 'r' && info->out && !info->out_done) {
4460         if (info->out->chan_out) {
4461             _ckvmssts(sys$cancel(info->out->chan_out));
4462             if (!info->out->chan_in) {   /* EOF generation, need AST */
4463                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4464             }
4465         }
4466      }
4467      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4468          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4469                            0, 0, 0, 0, 0, 0));
4470     _ckvmssts(sys$setast(1));
4471     if (info->fp) {
4472      if (!info->useFILE
4473 #if defined(USE_ITHREADS)
4474          && my_perl
4475 #endif
4476          && PL_perlio_fd_refcnt)
4477         PerlIO_close(info->fp);
4478      else
4479         fclose((FILE *)info->fp);
4480     }
4481      /*
4482         we have to wait until subprocess completes, but ALSO wait until all
4483         the i/o completes...otherwise we'll be freeing the "info" structure
4484         that the i/o ASTs could still be using...
4485      */
4486
4487      while (!done) {
4488          _ckvmssts(sys$setast(0));
4489          done = info->done && info->in_done && info->out_done && info->err_done;
4490          if (!done) _ckvmssts(sys$clref(pipe_ef));
4491          _ckvmssts(sys$setast(1));
4492          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4493      }
4494      retsts = info->completion;
4495
4496     /* remove from list of open pipes */
4497     _ckvmssts(sys$setast(0));
4498     if (last) last->next = info->next;
4499     else open_pipes = info->next;
4500     _ckvmssts(sys$setast(1));
4501
4502     /* free buffers and structures */
4503
4504     if (info->in) {
4505         if (info->in->buf) {
4506             n = info->in->bufsize * sizeof(char);
4507             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4508         }
4509         n = sizeof(Pipe);
4510         _ckvmssts(lib$free_vm(&n, &info->in));
4511     }
4512     if (info->out) {
4513         if (info->out->buf) {
4514             n = info->out->bufsize * sizeof(char);
4515             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4516         }
4517         n = sizeof(Pipe);
4518         _ckvmssts(lib$free_vm(&n, &info->out));
4519     }
4520     if (info->err) {
4521         if (info->err->buf) {
4522             n = info->err->bufsize * sizeof(char);
4523             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4524         }
4525         n = sizeof(Pipe);
4526         _ckvmssts(lib$free_vm(&n, &info->err));
4527     }
4528     n = sizeof(Info);
4529     _ckvmssts(lib$free_vm(&n, &info));
4530
4531     return retsts;
4532
4533 }  /* end of my_pclose() */
4534
4535 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4536   /* Roll our own prototype because we want this regardless of whether
4537    * _VMS_WAIT is defined.
4538    */
4539   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4540 #endif
4541 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4542    created with popen(); otherwise partially emulate waitpid() unless
4543    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4544    Also check processes not considered by the CRTL waitpid().
4545  */
4546 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4547 Pid_t
4548 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4549 {
4550     pInfo info;
4551     int done;
4552     int sts;
4553     int j;
4554
4555     if (statusp) *statusp = 0;
4556
4557     for (info = open_pipes; info != NULL; info = info->next)
4558         if (info->pid == pid) break;
4559
4560     if (info != NULL) {  /* we know about this child */
4561       while (!info->done) {
4562           _ckvmssts(sys$setast(0));
4563           done = info->done;
4564           if (!done) _ckvmssts(sys$clref(pipe_ef));
4565           _ckvmssts(sys$setast(1));
4566           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4567       }
4568
4569       if (statusp) *statusp = info->completion;
4570       return pid;
4571     }
4572
4573     /* child that already terminated? */
4574
4575     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4576         if (closed_list[j].pid == pid) {
4577             if (statusp) *statusp = closed_list[j].completion;
4578             return pid;
4579         }
4580     }
4581
4582     /* fall through if this child is not one of our own pipe children */
4583
4584 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4585
4586       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4587        * in 7.2 did we get a version that fills in the VMS completion
4588        * status as Perl has always tried to do.
4589        */
4590
4591       sts = __vms_waitpid( pid, statusp, flags );
4592
4593       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4594          return sts;
4595
4596       /* If the real waitpid tells us the child does not exist, we
4597        * fall through here to implement waiting for a child that
4598        * was created by some means other than exec() (say, spawned
4599        * from DCL) or to wait for a process that is not a subprocess
4600        * of the current process.
4601        */
4602
4603 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4604
4605     {
4606       $DESCRIPTOR(intdsc,"0 00:00:01");
4607       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4608       unsigned long int pidcode = JPI$_PID, mypid;
4609       unsigned long int interval[2];
4610       unsigned int jpi_iosb[2];
4611       struct itmlst_3 jpilist[2] = {
4612           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4613           {                      0,         0,                 0, 0}
4614       };
4615
4616       if (pid <= 0) {
4617         /* Sorry folks, we don't presently implement rooting around for
4618            the first child we can find, and we definitely don't want to
4619            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4620          */
4621         set_errno(ENOTSUP);
4622         return -1;
4623       }
4624
4625       /* Get the owner of the child so I can warn if it's not mine. If the
4626        * process doesn't exist or I don't have the privs to look at it,
4627        * I can go home early.
4628        */
4629       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4630       if (sts & 1) sts = jpi_iosb[0];
4631       if (!(sts & 1)) {
4632         switch (sts) {
4633             case SS$_NONEXPR:
4634                 set_errno(ECHILD);
4635                 break;
4636             case SS$_NOPRIV:
4637                 set_errno(EACCES);
4638                 break;
4639             default:
4640                 _ckvmssts(sts);
4641         }
4642         set_vaxc_errno(sts);
4643         return -1;
4644       }
4645
4646       if (ckWARN(WARN_EXEC)) {
4647         /* remind folks they are asking for non-standard waitpid behavior */
4648         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4649         if (ownerpid != mypid)
4650           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4651                       "waitpid: process %x is not a child of process %x",
4652                       pid,mypid);
4653       }
4654
4655       /* simply check on it once a second until it's not there anymore. */
4656
4657       _ckvmssts(sys$bintim(&intdsc,interval));
4658       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4659             _ckvmssts(sys$schdwk(0,0,interval,0));
4660             _ckvmssts(sys$hiber());
4661       }
4662       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4663
4664       _ckvmssts(sts);
4665       return pid;
4666     }
4667 }  /* end of waitpid() */
4668 /*}}}*/
4669 /*}}}*/
4670 /*}}}*/
4671
4672 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4673 char *
4674 my_gconvert(double val, int ndig, int trail, char *buf)
4675 {
4676   static char __gcvtbuf[DBL_DIG+1];
4677   char *loc;
4678
4679   loc = buf ? buf : __gcvtbuf;
4680
4681 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4682   if (val < 1) {
4683     sprintf(loc,"%.*g",ndig,val);
4684     return loc;
4685   }
4686 #endif
4687
4688   if (val) {
4689     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4690     return gcvt(val,ndig,loc);
4691   }
4692   else {
4693     loc[0] = '0'; loc[1] = '\0';
4694     return loc;
4695   }
4696
4697 }
4698 /*}}}*/
4699
4700 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4701 static int rms_free_search_context(struct FAB * fab)
4702 {
4703 struct NAM * nam;
4704
4705     nam = fab->fab$l_nam;
4706     nam->nam$b_nop |= NAM$M_SYNCHK;
4707     nam->nam$l_rlf = NULL;
4708     fab->fab$b_dns = 0;
4709     return sys$parse(fab, NULL, NULL);
4710 }
4711
4712 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4713 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4714 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4715 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4716 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4717 #define rms_nam_esll(nam) nam.nam$b_esl
4718 #define rms_nam_esl(nam) nam.nam$b_esl
4719 #define rms_nam_name(nam) nam.nam$l_name
4720 #define rms_nam_namel(nam) nam.nam$l_name
4721 #define rms_nam_type(nam) nam.nam$l_type
4722 #define rms_nam_typel(nam) nam.nam$l_type
4723 #define rms_nam_ver(nam) nam.nam$l_ver
4724 #define rms_nam_verl(nam) nam.nam$l_ver
4725 #define rms_nam_rsll(nam) nam.nam$b_rsl
4726 #define rms_nam_rsl(nam) nam.nam$b_rsl
4727 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4728 #define rms_set_fna(fab, nam, name, size) \
4729         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4730 #define rms_get_fna(fab, nam) fab.fab$l_fna
4731 #define rms_set_dna(fab, nam, name, size) \
4732         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4733 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4734 #define rms_set_esa(fab, nam, name, size) \
4735         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4736 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4737         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4738 #define rms_set_rsa(nam, name, size) \
4739         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4740 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4741         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4742 #define rms_nam_name_type_l_size(nam) \
4743         (nam.nam$b_name + nam.nam$b_type)
4744 #else
4745 static int rms_free_search_context(struct FAB * fab)
4746 {
4747 struct NAML * nam;
4748
4749     nam = fab->fab$l_naml;
4750     nam->naml$b_nop |= NAM$M_SYNCHK;
4751     nam->naml$l_rlf = NULL;
4752     nam->naml$l_long_defname_size = 0;
4753
4754     fab->fab$b_dns = 0;
4755     return sys$parse(fab, NULL, NULL);
4756 }
4757
4758 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4759 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4760 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4761 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4762 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4763 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4764 #define rms_nam_esl(nam) nam.naml$b_esl
4765 #define rms_nam_name(nam) nam.naml$l_name
4766 #define rms_nam_namel(nam) nam.naml$l_long_name
4767 #define rms_nam_type(nam) nam.naml$l_type
4768 #define rms_nam_typel(nam) nam.naml$l_long_type
4769 #define rms_nam_ver(nam) nam.naml$l_ver
4770 #define rms_nam_verl(nam) nam.naml$l_long_ver
4771 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4772 #define rms_nam_rsl(nam) nam.naml$b_rsl
4773 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4774 #define rms_set_fna(fab, nam, name, size) \
4775         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4776         nam.naml$l_long_filename_size = size; \
4777         nam.naml$l_long_filename = name;}
4778 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4779 #define rms_set_dna(fab, nam, name, size) \
4780         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4781         nam.naml$l_long_defname_size = size; \
4782         nam.naml$l_long_defname = name; }
4783 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4784 #define rms_set_esa(fab, nam, name, size) \
4785         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4786         nam.naml$l_long_expand_alloc = size; \
4787         nam.naml$l_long_expand = name; }
4788 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4789         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4790         nam.naml$l_long_expand = l_name; \
4791         nam.naml$l_long_expand_alloc = l_size; }
4792 #define rms_set_rsa(nam, name, size) \
4793         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4794         nam.naml$l_long_result = name; \
4795         nam.naml$l_long_result_alloc = size; }
4796 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4797         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4798         nam.naml$l_long_result = l_name; \
4799         nam.naml$l_long_result_alloc = l_size; }
4800 #define rms_nam_name_type_l_size(nam) \
4801         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4802 #endif
4803
4804
4805 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4806 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4807  * to expand file specification.  Allows for a single default file
4808  * specification and a simple mask of options.  If outbuf is non-NULL,
4809  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4810  * the resultant file specification is placed.  If outbuf is NULL, the
4811  * resultant file specification is placed into a static buffer.
4812  * The third argument, if non-NULL, is taken to be a default file
4813  * specification string.  The fourth argument is unused at present.
4814  * rmesexpand() returns the address of the resultant string if
4815  * successful, and NULL on error.
4816  *
4817  * New functionality for previously unused opts value:
4818  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4819  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
4820  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4821  */
4822 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4823
4824 static char *
4825 mp_do_rmsexpand
4826    (pTHX_ const char *filespec,
4827     char *outbuf,
4828     int ts,
4829     const char *defspec,
4830     unsigned opts,
4831     int * fs_utf8,
4832     int * dfs_utf8)
4833 {
4834   static char __rmsexpand_retbuf[VMS_MAXRSS];
4835   char * vmsfspec, *tmpfspec;
4836   char * esa, *cp, *out = NULL;
4837   char * tbuf;
4838   char * esal = NULL;
4839   char * outbufl;
4840   struct FAB myfab = cc$rms_fab;
4841   rms_setup_nam(mynam);
4842   STRLEN speclen;
4843   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4844   int sts;
4845
4846   /* temp hack until UTF8 is actually implemented */
4847   if (fs_utf8 != NULL)
4848     *fs_utf8 = 0;
4849
4850   if (!filespec || !*filespec) {
4851     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4852     return NULL;
4853   }
4854   if (!outbuf) {
4855     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4856     else    outbuf = __rmsexpand_retbuf;
4857   }
4858
4859   vmsfspec = NULL;
4860   tmpfspec = NULL;
4861   outbufl = NULL;
4862
4863   isunix = 0;
4864   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4865     isunix = is_unix_filespec(filespec);
4866     if (isunix) {
4867       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4868       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4869       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4870         PerlMem_free(vmsfspec);
4871         if (out)
4872            Safefree(out);
4873         return NULL;
4874       }
4875       filespec = vmsfspec;
4876
4877       /* Unless we are forcing to VMS format, a UNIX input means
4878        * UNIX output, and that requires long names to be used
4879        */
4880       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4881         opts |= PERL_RMSEXPAND_M_LONG;
4882       else {
4883         isunix = 0;
4884       }
4885     }
4886   }
4887
4888   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4889   rms_bind_fab_nam(myfab, mynam);
4890
4891   if (defspec && *defspec) {
4892     int t_isunix;
4893     t_isunix = is_unix_filespec(defspec);
4894     if (t_isunix) {
4895       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4896       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4897       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4898         PerlMem_free(tmpfspec);
4899         if (vmsfspec != NULL)
4900             PerlMem_free(vmsfspec);
4901         if (out)
4902            Safefree(out);
4903         return NULL;
4904       }
4905       defspec = tmpfspec;
4906     }
4907     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4908   }
4909
4910   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4911   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4912 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4913   esal = PerlMem_malloc(VMS_MAXRSS);
4914   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4915 #endif
4916   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4917
4918   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4919     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4920   }
4921   else {
4922 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4923     outbufl = PerlMem_malloc(VMS_MAXRSS);
4924     if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4925     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4926 #else
4927     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4928 #endif
4929   }
4930
4931 #ifdef NAM$M_NO_SHORT_UPCASE
4932   if (decc_efs_case_preserve)
4933     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4934 #endif
4935
4936   /* First attempt to parse as an existing file */
4937   retsts = sys$parse(&myfab,0,0);
4938   if (!(retsts & STS$K_SUCCESS)) {
4939
4940     /* Could not find the file, try as syntax only if error is not fatal */
4941     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4942     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4943       retsts = sys$parse(&myfab,0,0);
4944       if (retsts & STS$K_SUCCESS) goto expanded;
4945     }
4946
4947      /* Still could not parse the file specification */
4948     /*----------------------------------------------*/
4949     sts = rms_free_search_context(&myfab); /* Free search context */
4950     if (out) Safefree(out);
4951     if (tmpfspec != NULL)
4952         PerlMem_free(tmpfspec);
4953     if (vmsfspec != NULL)
4954         PerlMem_free(vmsfspec);
4955     if (outbufl != NULL)
4956         PerlMem_free(outbufl);
4957     PerlMem_free(esa);
4958     if (esal != NULL)
4959         PerlMem_free(esal);
4960     set_vaxc_errno(retsts);
4961     if      (retsts == RMS$_PRV) set_errno(EACCES);
4962     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4963     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4964     else                         set_errno(EVMSERR);
4965     return NULL;
4966   }
4967   retsts = sys$search(&myfab,0,0);
4968   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4969     sts = rms_free_search_context(&myfab); /* Free search context */
4970     if (out) Safefree(out);
4971     if (tmpfspec != NULL)
4972         PerlMem_free(tmpfspec);
4973     if (vmsfspec != NULL)
4974         PerlMem_free(vmsfspec);
4975     if (outbufl != NULL)
4976         PerlMem_free(outbufl);
4977     PerlMem_free(esa);
4978     if (esal != NULL)
4979         PerlMem_free(esal);
4980     set_vaxc_errno(retsts);
4981     if      (retsts == RMS$_PRV) set_errno(EACCES);
4982     else                         set_errno(EVMSERR);
4983     return NULL;
4984   }
4985
4986   /* If the input filespec contained any lowercase characters,
4987    * downcase the result for compatibility with Unix-minded code. */
4988   expanded:
4989   if (!decc_efs_case_preserve) {
4990     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4991       if (islower(*tbuf)) { haslower = 1; break; }
4992   }
4993
4994    /* Is a long or a short name expected */
4995   /*------------------------------------*/
4996   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4997     if (rms_nam_rsll(mynam)) {
4998         tbuf = outbuf;
4999         speclen = rms_nam_rsll(mynam);
5000     }
5001     else {
5002         tbuf = esal; /* Not esa */
5003         speclen = rms_nam_esll(mynam);
5004     }
5005   }
5006   else {
5007     if (rms_nam_rsl(mynam)) {
5008         tbuf = outbuf;
5009         speclen = rms_nam_rsl(mynam);
5010     }
5011     else {
5012         tbuf = esa; /* Not esal */
5013         speclen = rms_nam_esl(mynam);
5014     }
5015   }
5016   tbuf[speclen] = '\0';
5017
5018   /* Trim off null fields added by $PARSE
5019    * If type > 1 char, must have been specified in original or default spec
5020    * (not true for version; $SEARCH may have added version of existing file).
5021    */
5022   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5023   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5024     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5025              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5026   }
5027   else {
5028     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5029              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5030   }
5031   if (trimver || trimtype) {
5032     if (defspec && *defspec) {
5033       char *defesal = NULL;
5034       defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5035       if (defesal != NULL) {
5036         struct FAB deffab = cc$rms_fab;
5037         rms_setup_nam(defnam);
5038
5039         rms_bind_fab_nam(deffab, defnam);
5040
5041         /* Cast ok */
5042         rms_set_fna
5043             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5044
5045         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
5046
5047         rms_clear_nam_nop(defnam);
5048         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5049 #ifdef NAM$M_NO_SHORT_UPCASE
5050         if (decc_efs_case_preserve)
5051           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5052 #endif
5053         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5054           if (trimver) {
5055              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5056           }
5057           if (trimtype) {
5058             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5059           }
5060         }
5061         PerlMem_free(defesal);
5062       }
5063     }
5064     if (trimver) {
5065       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5066         if (*(rms_nam_verl(mynam)) != '\"')
5067           speclen = rms_nam_verl(mynam) - tbuf;
5068       }
5069       else {
5070         if (*(rms_nam_ver(mynam)) != '\"')
5071           speclen = rms_nam_ver(mynam) - tbuf;
5072       }
5073     }
5074     if (trimtype) {
5075       /* If we didn't already trim version, copy down */
5076       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5077         if (speclen > rms_nam_verl(mynam) - tbuf)
5078           memmove
5079            (rms_nam_typel(mynam),
5080             rms_nam_verl(mynam),
5081             speclen - (rms_nam_verl(mynam) - tbuf));
5082           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5083       }
5084       else {
5085         if (speclen > rms_nam_ver(mynam) - tbuf)
5086           memmove
5087            (rms_nam_type(mynam),
5088             rms_nam_ver(mynam),
5089             speclen - (rms_nam_ver(mynam) - tbuf));
5090           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5091       }
5092     }
5093   }
5094
5095    /* Done with these copies of the input files */
5096   /*-------------------------------------------*/
5097   if (vmsfspec != NULL)
5098         PerlMem_free(vmsfspec);
5099   if (tmpfspec != NULL)
5100         PerlMem_free(tmpfspec);
5101
5102   /* If we just had a directory spec on input, $PARSE "helpfully"
5103    * adds an empty name and type for us */
5104   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5105     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5106         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5107         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5108       speclen = rms_nam_namel(mynam) - tbuf;
5109   }
5110   else {
5111     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5112         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5113         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5114       speclen = rms_nam_name(mynam) - tbuf;
5115   }
5116
5117   /* Posix format specifications must have matching quotes */
5118   if (speclen < (VMS_MAXRSS - 1)) {
5119     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5120       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5121         tbuf[speclen] = '\"';
5122         speclen++;
5123       }
5124     }
5125   }
5126   tbuf[speclen] = '\0';
5127   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5128
5129   /* Have we been working with an expanded, but not resultant, spec? */
5130   /* Also, convert back to Unix syntax if necessary. */
5131
5132   if (!rms_nam_rsll(mynam)) {
5133     if (isunix) {
5134       if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
5135         if (out) Safefree(out);
5136         if (esal != NULL)
5137             PerlMem_free(esal);
5138         PerlMem_free(esa);
5139         if (outbufl != NULL)
5140             PerlMem_free(outbufl);
5141         return NULL;
5142       }
5143     }
5144     else strcpy(outbuf,esa);
5145   }
5146   else if (isunix) {
5147     tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5148     if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5149     if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
5150         if (out) Safefree(out);
5151         PerlMem_free(esa);
5152         if (esal != NULL)
5153             PerlMem_free(esal);
5154         PerlMem_free(tmpfspec);
5155         if (outbufl != NULL)
5156             PerlMem_free(outbufl);
5157         return NULL;
5158     }
5159     strcpy(outbuf,tmpfspec);
5160     PerlMem_free(tmpfspec);
5161   }
5162
5163   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5164   sts = rms_free_search_context(&myfab); /* Free search context */
5165   PerlMem_free(esa);
5166   if (esal != NULL)
5167      PerlMem_free(esal);
5168   if (outbufl != NULL)
5169      PerlMem_free(outbufl);
5170   return outbuf;
5171 }
5172 /*}}}*/
5173 /* External entry points */
5174 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5175 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5176 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5177 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5178 char *Perl_rmsexpand_utf8
5179   (pTHX_ const char *spec, char *buf, const char *def,
5180    unsigned opt, int * fs_utf8, int * dfs_utf8)
5181 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5182 char *Perl_rmsexpand_utf8_ts
5183   (pTHX_ const char *spec, char *buf, const char *def,
5184    unsigned opt, int * fs_utf8, int * dfs_utf8)
5185 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5186
5187
5188 /*
5189 ** The following routines are provided to make life easier when
5190 ** converting among VMS-style and Unix-style directory specifications.
5191 ** All will take input specifications in either VMS or Unix syntax. On
5192 ** failure, all return NULL.  If successful, the routines listed below
5193 ** return a pointer to a buffer containing the appropriately
5194 ** reformatted spec (and, therefore, subsequent calls to that routine
5195 ** will clobber the result), while the routines of the same names with
5196 ** a _ts suffix appended will return a pointer to a mallocd string
5197 ** containing the appropriately reformatted spec.
5198 ** In all cases, only explicit syntax is altered; no check is made that
5199 ** the resulting string is valid or that the directory in question
5200 ** actually exists.
5201 **
5202 **   fileify_dirspec() - convert a directory spec into the name of the
5203 **     directory file (i.e. what you can stat() to see if it's a dir).
5204 **     The style (VMS or Unix) of the result is the same as the style
5205 **     of the parameter passed in.
5206 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5207 **     what you prepend to a filename to indicate what directory it's in).
5208 **     The style (VMS or Unix) of the result is the same as the style
5209 **     of the parameter passed in.
5210 **   tounixpath() - convert a directory spec into a Unix-style path.
5211 **   tovmspath() - convert a directory spec into a VMS-style path.
5212 **   tounixspec() - convert any file spec into a Unix-style file spec.
5213 **   tovmsspec() - convert any file spec into a VMS-style spec.
5214 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5215 **
5216 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5217 ** Permission is given to distribute this code as part of the Perl
5218 ** standard distribution under the terms of the GNU General Public
5219 ** License or the Perl Artistic License.  Copies of each may be
5220 ** found in the Perl standard distribution.
5221  */
5222
5223 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5224 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5225 {
5226     static char __fileify_retbuf[VMS_MAXRSS];
5227     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5228     char *retspec, *cp1, *cp2, *lastdir;
5229     char *trndir, *vmsdir;
5230     unsigned short int trnlnm_iter_count;
5231     int sts;
5232     if (utf8_fl != NULL)
5233         *utf8_fl = 0;
5234
5235     if (!dir || !*dir) {
5236       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5237     }
5238     dirlen = strlen(dir);
5239     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5240     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5241       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5242         dir = "/sys$disk";
5243         dirlen = 9;
5244       }
5245       else
5246         dirlen = 1;
5247     }
5248     if (dirlen > (VMS_MAXRSS - 1)) {
5249       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5250       return NULL;
5251     }
5252     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5253     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5254     if (!strpbrk(dir+1,"/]>:")  &&
5255         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5256       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5257       trnlnm_iter_count = 0;
5258       while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5259         trnlnm_iter_count++;
5260         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5261       }
5262       dirlen = strlen(trndir);
5263     }
5264     else {
5265       strncpy(trndir,dir,dirlen);
5266       trndir[dirlen] = '\0';
5267     }
5268
5269     /* At this point we are done with *dir and use *trndir which is a
5270      * copy that can be modified.  *dir must not be modified.
5271      */
5272
5273     /* If we were handed a rooted logical name or spec, treat it like a
5274      * simple directory, so that
5275      *    $ Define myroot dev:[dir.]
5276      *    ... do_fileify_dirspec("myroot",buf,1) ...
5277      * does something useful.
5278      */
5279     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5280       trndir[--dirlen] = '\0';
5281       trndir[dirlen-1] = ']';
5282     }
5283     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5284       trndir[--dirlen] = '\0';
5285       trndir[dirlen-1] = '>';
5286     }
5287
5288     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5289       /* If we've got an explicit filename, we can just shuffle the string. */
5290       if (*(cp1+1)) hasfilename = 1;
5291       /* Similarly, we can just back up a level if we've got multiple levels
5292          of explicit directories in a VMS spec which ends with directories. */
5293       else {
5294         for (cp2 = cp1; cp2 > trndir; cp2--) {
5295           if (*cp2 == '.') {
5296             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5297 /* fix-me, can not scan EFS file specs backward like this */
5298               *cp2 = *cp1; *cp1 = '\0';
5299               hasfilename = 1;
5300               break;
5301             }
5302           }
5303           if (*cp2 == '[' || *cp2 == '<') break;
5304         }
5305       }
5306     }
5307
5308     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5309     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5310     cp1 = strpbrk(trndir,"]:>");
5311     if (hasfilename || !cp1) { /* Unix-style path or filename */
5312       if (trndir[0] == '.') {
5313         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5314           PerlMem_free(trndir);
5315           PerlMem_free(vmsdir);
5316           return do_fileify_dirspec("[]",buf,ts,NULL);
5317         }
5318         else if (trndir[1] == '.' &&
5319                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5320           PerlMem_free(trndir);
5321           PerlMem_free(vmsdir);
5322           return do_fileify_dirspec("[-]",buf,ts,NULL);
5323         }
5324       }
5325       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5326         dirlen -= 1;                 /* to last element */
5327         lastdir = strrchr(trndir,'/');
5328       }
5329       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5330         /* If we have "/." or "/..", VMSify it and let the VMS code
5331          * below expand it, rather than repeating the code to handle
5332          * relative components of a filespec here */
5333         do {
5334           if (*(cp1+2) == '.') cp1++;
5335           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5336             char * ret_chr;
5337             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5338                 PerlMem_free(trndir);
5339                 PerlMem_free(vmsdir);
5340                 return NULL;
5341             }
5342             if (strchr(vmsdir,'/') != NULL) {
5343               /* If do_tovmsspec() returned it, it must have VMS syntax
5344                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5345                * the time to check this here only so we avoid a recursion
5346                * loop; otherwise, gigo.
5347                */
5348               PerlMem_free(trndir);
5349               PerlMem_free(vmsdir);
5350               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5351               return NULL;
5352             }
5353             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5354                 PerlMem_free(trndir);
5355                 PerlMem_free(vmsdir);
5356                 return NULL;
5357             }
5358             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5359             PerlMem_free(trndir);
5360             PerlMem_free(vmsdir);
5361             return ret_chr;
5362           }
5363           cp1++;
5364         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5365         lastdir = strrchr(trndir,'/');
5366       }
5367       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5368         char * ret_chr;
5369         /* Ditto for specs that end in an MFD -- let the VMS code
5370          * figure out whether it's a real device or a rooted logical. */
5371
5372         /* This should not happen any more.  Allowing the fake /000000
5373          * in a UNIX pathname causes all sorts of problems when trying
5374          * to run in UNIX emulation.  So the VMS to UNIX conversions
5375          * now remove the fake /000000 directories.
5376          */
5377
5378         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5379         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5380             PerlMem_free(trndir);
5381             PerlMem_free(vmsdir);
5382             return NULL;
5383         }
5384         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5385             PerlMem_free(trndir);
5386             PerlMem_free(vmsdir);
5387             return NULL;
5388         }
5389         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5390         PerlMem_free(trndir);
5391         PerlMem_free(vmsdir);
5392         return ret_chr;
5393       }
5394       else {
5395
5396         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5397              !(lastdir = cp1 = strrchr(trndir,']')) &&
5398              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5399         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5400           int ver; char *cp3;
5401
5402           /* For EFS or ODS-5 look for the last dot */
5403           if (decc_efs_charset) {
5404               cp2 = strrchr(cp1,'.');
5405           }
5406           if (vms_process_case_tolerant) {
5407               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5408                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5409                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5410                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5411                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5412                             (ver || *cp3)))))) {
5413                   PerlMem_free(trndir);
5414                   PerlMem_free(vmsdir);
5415                   set_errno(ENOTDIR);
5416                   set_vaxc_errno(RMS$_DIR);
5417                   return NULL;
5418               }
5419           }
5420           else {
5421               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5422                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5423                   !*(cp2+3) || *(cp2+3) != 'R' ||
5424                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5425                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5426                             (ver || *cp3)))))) {
5427                  PerlMem_free(trndir);
5428                  PerlMem_free(vmsdir);
5429                  set_errno(ENOTDIR);
5430                  set_vaxc_errno(RMS$_DIR);
5431                  return NULL;
5432               }
5433           }
5434           dirlen = cp2 - trndir;
5435         }
5436       }
5437
5438       retlen = dirlen + 6;
5439       if (buf) retspec = buf;
5440       else if (ts) Newx(retspec,retlen+1,char);
5441       else retspec = __fileify_retbuf;
5442       memcpy(retspec,trndir,dirlen);
5443       retspec[dirlen] = '\0';
5444
5445       /* We've picked up everything up to the directory file name.
5446          Now just add the type and version, and we're set. */
5447       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5448         strcat(retspec,".dir;1");
5449       else
5450         strcat(retspec,".DIR;1");
5451       PerlMem_free(trndir);
5452       PerlMem_free(vmsdir);
5453       return retspec;
5454     }
5455     else {  /* VMS-style directory spec */
5456
5457       char *esa, term, *cp;
5458       unsigned long int sts, cmplen, haslower = 0;
5459       unsigned int nam_fnb;
5460       char * nam_type;
5461       struct FAB dirfab = cc$rms_fab;
5462       rms_setup_nam(savnam);
5463       rms_setup_nam(dirnam);
5464
5465       esa = PerlMem_malloc(VMS_MAXRSS + 1);
5466       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5467       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5468       rms_bind_fab_nam(dirfab, dirnam);
5469       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5470       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5471 #ifdef NAM$M_NO_SHORT_UPCASE
5472       if (decc_efs_case_preserve)
5473         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5474 #endif
5475
5476       for (cp = trndir; *cp; cp++)
5477         if (islower(*cp)) { haslower = 1; break; }
5478       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5479         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5480           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5481           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5482         }
5483         if (!sts) {
5484           PerlMem_free(esa);
5485           PerlMem_free(trndir);
5486           PerlMem_free(vmsdir);
5487           set_errno(EVMSERR);
5488           set_vaxc_errno(dirfab.fab$l_sts);
5489           return NULL;
5490         }
5491       }
5492       else {
5493         savnam = dirnam;
5494         /* Does the file really exist? */
5495         if (sys$search(&dirfab)& STS$K_SUCCESS) {
5496           /* Yes; fake the fnb bits so we'll check type below */
5497         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5498         }
5499         else { /* No; just work with potential name */
5500           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5501           else {
5502             int fab_sts;
5503             fab_sts = dirfab.fab$l_sts;
5504             sts = rms_free_search_context(&dirfab);
5505             PerlMem_free(esa);
5506             PerlMem_free(trndir);
5507             PerlMem_free(vmsdir);
5508             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
5509             return NULL;
5510           }
5511         }
5512       }
5513       esa[rms_nam_esll(dirnam)] = '\0';
5514       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5515         cp1 = strchr(esa,']');
5516         if (!cp1) cp1 = strchr(esa,'>');
5517         if (cp1) {  /* Should always be true */
5518           rms_nam_esll(dirnam) -= cp1 - esa - 1;
5519           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5520         }
5521       }
5522       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5523         /* Yep; check version while we're at it, if it's there. */
5524         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5525         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5526           /* Something other than .DIR[;1].  Bzzt. */
5527           sts = rms_free_search_context(&dirfab);
5528           PerlMem_free(esa);
5529           PerlMem_free(trndir);
5530           PerlMem_free(vmsdir);
5531           set_errno(ENOTDIR);
5532           set_vaxc_errno(RMS$_DIR);
5533           return NULL;
5534         }
5535       }
5536
5537       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5538         /* They provided at least the name; we added the type, if necessary, */
5539         if (buf) retspec = buf;                            /* in sys$parse() */
5540         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5541         else retspec = __fileify_retbuf;
5542         strcpy(retspec,esa);
5543         sts = rms_free_search_context(&dirfab);
5544         PerlMem_free(trndir);
5545         PerlMem_free(esa);
5546         PerlMem_free(vmsdir);
5547         return retspec;
5548       }
5549       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5550         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5551         *cp1 = '\0';
5552         rms_nam_esll(dirnam) -= 9;
5553       }
5554       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5555       if (cp1 == NULL) { /* should never happen */
5556         sts = rms_free_search_context(&dirfab);
5557         PerlMem_free(trndir);
5558         PerlMem_free(esa);
5559         PerlMem_free(vmsdir);
5560         return NULL;
5561       }
5562       term = *cp1;
5563       *cp1 = '\0';
5564       retlen = strlen(esa);
5565       cp1 = strrchr(esa,'.');
5566       /* ODS-5 directory specifications can have extra "." in them. */
5567       /* Fix-me, can not scan EFS file specifications backwards */
5568       while (cp1 != NULL) {
5569         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5570           break;
5571         else {
5572            cp1--;
5573            while ((cp1 > esa) && (*cp1 != '.'))
5574              cp1--;
5575         }
5576         if (cp1 == esa)
5577           cp1 = NULL;
5578       }
5579
5580       if ((cp1) != NULL) {
5581         /* There's more than one directory in the path.  Just roll back. */
5582         *cp1 = term;
5583         if (buf) retspec = buf;
5584         else if (ts) Newx(retspec,retlen+7,char);
5585         else retspec = __fileify_retbuf;
5586         strcpy(retspec,esa);
5587       }
5588       else {
5589         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5590           /* Go back and expand rooted logical name */
5591           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5592 #ifdef NAM$M_NO_SHORT_UPCASE
5593           if (decc_efs_case_preserve)
5594             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5595 #endif
5596           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5597             sts = rms_free_search_context(&dirfab);
5598             PerlMem_free(esa);
5599             PerlMem_free(trndir);
5600             PerlMem_free(vmsdir);
5601             set_errno(EVMSERR);
5602             set_vaxc_errno(dirfab.fab$l_sts);
5603             return NULL;
5604           }
5605           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5606           if (buf) retspec = buf;
5607           else if (ts) Newx(retspec,retlen+16,char);
5608           else retspec = __fileify_retbuf;
5609           cp1 = strstr(esa,"][");
5610           if (!cp1) cp1 = strstr(esa,"]<");
5611           dirlen = cp1 - esa;
5612           memcpy(retspec,esa,dirlen);
5613           if (!strncmp(cp1+2,"000000]",7)) {
5614             retspec[dirlen-1] = '\0';
5615             /* fix-me Not full ODS-5, just extra dots in directories for now */
5616             cp1 = retspec + dirlen - 1;
5617             while (cp1 > retspec)
5618             {
5619               if (*cp1 == '[')
5620                 break;
5621               if (*cp1 == '.') {
5622                 if (*(cp1-1) != '^')
5623                   break;
5624               }
5625               cp1--;
5626             }
5627             if (*cp1 == '.') *cp1 = ']';
5628             else {
5629               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5630               memmove(cp1+1,"000000]",7);
5631             }
5632           }
5633           else {
5634             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5635             retspec[retlen] = '\0';
5636             /* Convert last '.' to ']' */
5637             cp1 = retspec+retlen-1;
5638             while (*cp != '[') {
5639               cp1--;
5640               if (*cp1 == '.') {
5641                 /* Do not trip on extra dots in ODS-5 directories */
5642                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5643                 break;
5644               }
5645             }
5646             if (*cp1 == '.') *cp1 = ']';
5647             else {
5648               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5649               memmove(cp1+1,"000000]",7);
5650             }
5651           }
5652         }
5653         else {  /* This is a top-level dir.  Add the MFD to the path. */
5654           if (buf) retspec = buf;
5655           else if (ts) Newx(retspec,retlen+16,char);
5656           else retspec = __fileify_retbuf;
5657           cp1 = esa;
5658           cp2 = retspec;
5659           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5660           strcpy(cp2,":[000000]");
5661           cp1 += 2;
5662           strcpy(cp2+9,cp1);
5663         }
5664       }
5665       sts = rms_free_search_context(&dirfab);
5666       /* We've set up the string up through the filename.  Add the
5667          type and version, and we're done. */
5668       strcat(retspec,".DIR;1");
5669
5670       /* $PARSE may have upcased filespec, so convert output to lower
5671        * case if input contained any lowercase characters. */
5672       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5673       PerlMem_free(trndir);
5674       PerlMem_free(esa);
5675       PerlMem_free(vmsdir);
5676       return retspec;
5677     }
5678 }  /* end of do_fileify_dirspec() */
5679 /*}}}*/
5680 /* External entry points */
5681 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5682 { return do_fileify_dirspec(dir,buf,0,NULL); }
5683 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5684 { return do_fileify_dirspec(dir,buf,1,NULL); }
5685 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5686 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5687 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5688 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5689
5690 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5691 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5692 {
5693     static char __pathify_retbuf[VMS_MAXRSS];
5694     unsigned long int retlen;
5695     char *retpath, *cp1, *cp2, *trndir;
5696     unsigned short int trnlnm_iter_count;
5697     STRLEN trnlen;
5698     int sts;
5699     if (utf8_fl != NULL)
5700         *utf8_fl = 0;
5701
5702     if (!dir || !*dir) {
5703       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5704     }
5705
5706     trndir = PerlMem_malloc(VMS_MAXRSS);
5707     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5708     if (*dir) strcpy(trndir,dir);
5709     else getcwd(trndir,VMS_MAXRSS - 1);
5710
5711     trnlnm_iter_count = 0;
5712     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5713            && my_trnlnm(trndir,trndir,0)) {
5714       trnlnm_iter_count++;
5715       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5716       trnlen = strlen(trndir);
5717
5718       /* Trap simple rooted lnms, and return lnm:[000000] */
5719       if (!strcmp(trndir+trnlen-2,".]")) {
5720         if (buf) retpath = buf;
5721         else if (ts) Newx(retpath,strlen(dir)+10,char);
5722         else retpath = __pathify_retbuf;
5723         strcpy(retpath,dir);
5724         strcat(retpath,":[000000]");
5725         PerlMem_free(trndir);
5726         return retpath;
5727       }
5728     }
5729
5730     /* At this point we do not work with *dir, but the copy in
5731      * *trndir that is modifiable.
5732      */
5733
5734     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5735       if (*trndir == '.' && (*(trndir+1) == '\0' ||
5736                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5737         retlen = 2 + (*(trndir+1) != '\0');
5738       else {
5739         if ( !(cp1 = strrchr(trndir,'/')) &&
5740              !(cp1 = strrchr(trndir,']')) &&
5741              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5742         if ((cp2 = strchr(cp1,'.')) != NULL &&
5743             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
5744              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
5745               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5746               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5747           int ver; char *cp3;
5748
5749           /* For EFS or ODS-5 look for the last dot */
5750           if (decc_efs_charset) {
5751             cp2 = strrchr(cp1,'.');
5752           }
5753           if (vms_process_case_tolerant) {
5754               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5755                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5756                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5757                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5758                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5759                             (ver || *cp3)))))) {
5760                 PerlMem_free(trndir);
5761                 set_errno(ENOTDIR);
5762                 set_vaxc_errno(RMS$_DIR);
5763                 return NULL;
5764               }
5765           }
5766           else {
5767               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5768                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5769                   !*(cp2+3) || *(cp2+3) != 'R' ||
5770                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5771                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5772                             (ver || *cp3)))))) {
5773                 PerlMem_free(trndir);
5774                 set_errno(ENOTDIR);
5775                 set_vaxc_errno(RMS$_DIR);
5776                 return NULL;
5777               }
5778           }
5779           retlen = cp2 - trndir + 1;
5780         }
5781         else {  /* No file type present.  Treat the filename as a directory. */
5782           retlen = strlen(trndir) + 1;
5783         }
5784       }
5785       if (buf) retpath = buf;
5786       else if (ts) Newx(retpath,retlen+1,char);
5787       else retpath = __pathify_retbuf;
5788       strncpy(retpath, trndir, retlen-1);
5789       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5790         retpath[retlen-1] = '/';      /* with '/', add it. */
5791         retpath[retlen] = '\0';
5792       }
5793       else retpath[retlen-1] = '\0';
5794     }
5795     else {  /* VMS-style directory spec */
5796       char *esa, *cp;
5797       unsigned long int sts, cmplen, haslower;
5798       struct FAB dirfab = cc$rms_fab;
5799       int dirlen;
5800       rms_setup_nam(savnam);
5801       rms_setup_nam(dirnam);
5802
5803       /* If we've got an explicit filename, we can just shuffle the string. */
5804       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5805              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
5806         if ((cp2 = strchr(cp1,'.')) != NULL) {
5807           int ver; char *cp3;
5808           if (vms_process_case_tolerant) {
5809               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5810                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5811                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5812                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5813                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5814                             (ver || *cp3)))))) {
5815                PerlMem_free(trndir);
5816                set_errno(ENOTDIR);
5817                set_vaxc_errno(RMS$_DIR);
5818                return NULL;
5819              }
5820           }
5821           else {
5822               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5823                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5824                   !*(cp2+3) || *(cp2+3) != 'R' ||
5825                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5826                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5827                             (ver || *cp3)))))) {
5828                PerlMem_free(trndir);
5829                set_errno(ENOTDIR);
5830                set_vaxc_errno(RMS$_DIR);
5831                return NULL;
5832              }
5833           }
5834         }
5835         else {  /* No file type, so just draw name into directory part */
5836           for (cp2 = cp1; *cp2; cp2++) ;
5837         }
5838         *cp2 = *cp1;
5839         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5840         *cp1 = '.';
5841         /* We've now got a VMS 'path'; fall through */
5842       }
5843
5844       dirlen = strlen(trndir);
5845       if (trndir[dirlen-1] == ']' ||
5846           trndir[dirlen-1] == '>' ||
5847           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5848         if (buf) retpath = buf;
5849         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5850         else retpath = __pathify_retbuf;
5851         strcpy(retpath,trndir);
5852         PerlMem_free(trndir);
5853         return retpath;
5854       }
5855       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5856       esa = PerlMem_malloc(VMS_MAXRSS);
5857       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5858       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5859       rms_bind_fab_nam(dirfab, dirnam);
5860       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5861 #ifdef NAM$M_NO_SHORT_UPCASE
5862       if (decc_efs_case_preserve)
5863           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5864 #endif
5865
5866       for (cp = trndir; *cp; cp++)
5867         if (islower(*cp)) { haslower = 1; break; }
5868
5869       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5870         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5871           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5872           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5873         }
5874         if (!sts) {
5875           PerlMem_free(trndir);
5876           PerlMem_free(esa);
5877           set_errno(EVMSERR);
5878           set_vaxc_errno(dirfab.fab$l_sts);
5879           return NULL;
5880         }
5881       }
5882       else {
5883         savnam = dirnam;
5884         /* Does the file really exist? */
5885         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5886           if (dirfab.fab$l_sts != RMS$_FNF) {
5887             int sts1;
5888             sts1 = rms_free_search_context(&dirfab);
5889             PerlMem_free(trndir);
5890             PerlMem_free(esa);
5891             set_errno(EVMSERR);
5892             set_vaxc_errno(dirfab.fab$l_sts);
5893             return NULL;
5894           }
5895           dirnam = savnam; /* No; just work with potential name */
5896         }
5897       }
5898       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5899         /* Yep; check version while we're at it, if it's there. */
5900         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5901         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5902           int sts2;
5903           /* Something other than .DIR[;1].  Bzzt. */
5904           sts2 = rms_free_search_context(&dirfab);
5905           PerlMem_free(trndir);
5906           PerlMem_free(esa);
5907           set_errno(ENOTDIR);
5908           set_vaxc_errno(RMS$_DIR);
5909           return NULL;
5910         }
5911       }
5912       /* OK, the type was fine.  Now pull any file name into the
5913          directory path. */
5914       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5915       else {
5916         cp1 = strrchr(esa,'>');
5917         *(rms_nam_typel(dirnam)) = '>';
5918       }
5919       *cp1 = '.';
5920       *(rms_nam_typel(dirnam) + 1) = '\0';
5921       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5922       if (buf) retpath = buf;
5923       else if (ts) Newx(retpath,retlen,char);
5924       else retpath = __pathify_retbuf;
5925       strcpy(retpath,esa);
5926       PerlMem_free(esa);
5927       sts = rms_free_search_context(&dirfab);
5928       /* $PARSE may have upcased filespec, so convert output to lower
5929        * case if input contained any lowercase characters. */
5930       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5931     }
5932
5933     PerlMem_free(trndir);
5934     return retpath;
5935 }  /* end of do_pathify_dirspec() */
5936 /*}}}*/
5937 /* External entry points */
5938 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5939 { return do_pathify_dirspec(dir,buf,0,NULL); }
5940 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5941 { return do_pathify_dirspec(dir,buf,1,NULL); }
5942 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5943 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5944 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5945 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5946
5947 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5948 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5949 {
5950   static char __tounixspec_retbuf[VMS_MAXRSS];
5951   char *dirend, *rslt, *cp1, *cp3, *tmp;
5952   const char *cp2;
5953   int devlen, dirlen, retlen = VMS_MAXRSS;
5954   int expand = 1; /* guarantee room for leading and trailing slashes */
5955   unsigned short int trnlnm_iter_count;
5956   int cmp_rslt;
5957   if (utf8_fl != NULL)
5958     *utf8_fl = 0;
5959
5960   if (spec == NULL) return NULL;
5961   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5962   if (buf) rslt = buf;
5963   else if (ts) {
5964     Newx(rslt, VMS_MAXRSS, char);
5965   }
5966   else rslt = __tounixspec_retbuf;
5967
5968   /* New VMS specific format needs translation
5969    * glob passes filenames with trailing '\n' and expects this preserved.
5970    */
5971   if (decc_posix_compliant_pathnames) {
5972     if (strncmp(spec, "\"^UP^", 5) == 0) {
5973       char * uspec;
5974       char *tunix;
5975       int tunix_len;
5976       int nl_flag;
5977
5978       tunix = PerlMem_malloc(VMS_MAXRSS);
5979       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5980       strcpy(tunix, spec);
5981       tunix_len = strlen(tunix);
5982       nl_flag = 0;
5983       if (tunix[tunix_len - 1] == '\n') {
5984         tunix[tunix_len - 1] = '\"';
5985         tunix[tunix_len] = '\0';
5986         tunix_len--;
5987         nl_flag = 1;
5988       }
5989       uspec = decc$translate_vms(tunix);
5990       PerlMem_free(tunix);
5991       if ((int)uspec > 0) {
5992         strcpy(rslt,uspec);
5993         if (nl_flag) {
5994           strcat(rslt,"\n");
5995         }
5996         else {
5997           /* If we can not translate it, makemaker wants as-is */
5998           strcpy(rslt, spec);
5999         }
6000         return rslt;
6001       }
6002     }
6003   }
6004
6005   cmp_rslt = 0; /* Presume VMS */
6006   cp1 = strchr(spec, '/');
6007   if (cp1 == NULL)
6008     cmp_rslt = 0;
6009
6010     /* Look for EFS ^/ */
6011     if (decc_efs_charset) {
6012       while (cp1 != NULL) {
6013         cp2 = cp1 - 1;
6014         if (*cp2 != '^') {
6015           /* Found illegal VMS, assume UNIX */
6016           cmp_rslt = 1;
6017           break;
6018         }
6019       cp1++;
6020       cp1 = strchr(cp1, '/');
6021     }
6022   }
6023
6024   /* Look for "." and ".." */
6025   if (decc_filename_unix_report) {
6026     if (spec[0] == '.') {
6027       if ((spec[1] == '\0') || (spec[1] == '\n')) {
6028         cmp_rslt = 1;
6029       }
6030       else {
6031         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6032           cmp_rslt = 1;
6033         }
6034       }
6035     }
6036   }
6037   /* This is already UNIX or at least nothing VMS understands */
6038   if (cmp_rslt) {
6039     strcpy(rslt,spec);
6040     return rslt;
6041   }
6042
6043   cp1 = rslt;
6044   cp2 = spec;
6045   dirend = strrchr(spec,']');
6046   if (dirend == NULL) dirend = strrchr(spec,'>');
6047   if (dirend == NULL) dirend = strchr(spec,':');
6048   if (dirend == NULL) {
6049     strcpy(rslt,spec);
6050     return rslt;
6051   }
6052
6053   /* Special case 1 - sys$posix_root = / */
6054 #if __CRTL_VER >= 70000000
6055   if (!decc_disable_posix_root) {
6056     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6057       *cp1 = '/';
6058       cp1++;
6059       cp2 = cp2 + 15;
6060       }
6061   }
6062 #endif
6063
6064   /* Special case 2 - Convert NLA0: to /dev/null */
6065 #if __CRTL_VER < 70000000
6066   cmp_rslt = strncmp(spec,"NLA0:", 5);
6067   if (cmp_rslt != 0)
6068      cmp_rslt = strncmp(spec,"nla0:", 5);
6069 #else
6070   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6071 #endif
6072   if (cmp_rslt == 0) {
6073     strcpy(rslt, "/dev/null");
6074     cp1 = cp1 + 9;
6075     cp2 = cp2 + 5;
6076     if (spec[6] != '\0') {
6077       cp1[9] == '/';
6078       cp1++;
6079       cp2++;
6080     }
6081   }
6082
6083    /* Also handle special case "SYS$SCRATCH:" */
6084 #if __CRTL_VER < 70000000
6085   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6086   if (cmp_rslt != 0)
6087      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6088 #else
6089   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6090 #endif
6091   tmp = PerlMem_malloc(VMS_MAXRSS);
6092   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6093   if (cmp_rslt == 0) {
6094   int islnm;
6095
6096     islnm = my_trnlnm(tmp, "TMP", 0);
6097     if (!islnm) {
6098       strcpy(rslt, "/tmp");
6099       cp1 = cp1 + 4;
6100       cp2 = cp2 + 12;
6101       if (spec[12] != '\0') {
6102         cp1[4] == '/';
6103         cp1++;
6104         cp2++;
6105       }
6106     }
6107   }
6108
6109   if (*cp2 != '[' && *cp2 != '<') {
6110     *(cp1++) = '/';
6111   }
6112   else {  /* the VMS spec begins with directories */
6113     cp2++;
6114     if (*cp2 == ']' || *cp2 == '>') {
6115       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6116       PerlMem_free(tmp);
6117       return rslt;
6118     }
6119     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6120       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6121         if (ts) Safefree(rslt);
6122         PerlMem_free(tmp);
6123         return NULL;
6124       }
6125       trnlnm_iter_count = 0;
6126       do {
6127         cp3 = tmp;
6128         while (*cp3 != ':' && *cp3) cp3++;
6129         *(cp3++) = '\0';
6130         if (strchr(cp3,']') != NULL) break;
6131         trnlnm_iter_count++;
6132         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6133       } while (vmstrnenv(tmp,tmp,0,fildev,0));
6134       if (ts && !buf &&
6135           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6136         retlen = devlen + dirlen;
6137         Renew(rslt,retlen+1+2*expand,char);
6138         cp1 = rslt;
6139       }
6140       cp3 = tmp;
6141       *(cp1++) = '/';
6142       while (*cp3) {
6143         *(cp1++) = *(cp3++);
6144         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6145             PerlMem_free(tmp);
6146             return NULL; /* No room */
6147         }
6148       }
6149       *(cp1++) = '/';
6150     }
6151     if ((*cp2 == '^')) {
6152         /* EFS file escape, pass the next character as is */
6153         /* Fix me: HEX encoding for Unicode not implemented */
6154         cp2++;
6155     }
6156     else if ( *cp2 == '.') {
6157       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6158         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6159         cp2 += 3;
6160       }
6161       else cp2++;
6162     }
6163   }
6164   PerlMem_free(tmp);
6165   for (; cp2 <= dirend; cp2++) {
6166     if ((*cp2 == '^')) {
6167         /* EFS file escape, pass the next character as is */
6168         /* Fix me: HEX encoding for Unicode not implemented */
6169         *(cp1++) = *(++cp2);
6170         /* An escaped dot stays as is -- don't convert to slash */
6171         if (*cp2 == '.') cp2++;
6172     }
6173     if (*cp2 == ':') {
6174       *(cp1++) = '/';
6175       if (*(cp2+1) == '[') cp2++;
6176     }
6177     else if (*cp2 == ']' || *cp2 == '>') {
6178       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6179     }
6180     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6181       *(cp1++) = '/';
6182       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6183         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6184                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6185         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6186             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6187       }
6188       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6189         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6190         cp2 += 2;
6191       }
6192     }
6193     else if (*cp2 == '-') {
6194       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6195         while (*cp2 == '-') {
6196           cp2++;
6197           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6198         }
6199         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6200           if (ts) Safefree(rslt);                        /* filespecs like */
6201           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
6202           return NULL;
6203         }
6204       }
6205       else *(cp1++) = *cp2;
6206     }
6207     else *(cp1++) = *cp2;
6208   }
6209   while (*cp2) {
6210     if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++;  /* '^.' --> '.' */
6211     *(cp1++) = *(cp2++);
6212   }
6213   *cp1 = '\0';
6214
6215   /* This still leaves /000000/ when working with a
6216    * VMS device root or concealed root.
6217    */
6218   {
6219   int ulen;
6220   char * zeros;
6221
6222       ulen = strlen(rslt);
6223
6224       /* Get rid of "000000/ in rooted filespecs */
6225       if (ulen > 7) {
6226         zeros = strstr(rslt, "/000000/");
6227         if (zeros != NULL) {
6228           int mlen;
6229           mlen = ulen - (zeros - rslt) - 7;
6230           memmove(zeros, &zeros[7], mlen);
6231           ulen = ulen - 7;
6232           rslt[ulen] = '\0';
6233         }
6234       }
6235   }
6236
6237   return rslt;
6238
6239 }  /* end of do_tounixspec() */
6240 /*}}}*/
6241 /* External entry points */
6242 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6243   { return do_tounixspec(spec,buf,0, NULL); }
6244 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6245   { return do_tounixspec(spec,buf,1, NULL); }
6246 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6247   { return do_tounixspec(spec,buf,0, utf8_fl); }
6248 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6249   { return do_tounixspec(spec,buf,1, utf8_fl); }
6250
6251 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6252
6253 /*
6254  This procedure is used to identify if a path is based in either
6255  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6256  it returns the OpenVMS format directory for it.
6257
6258  It is expecting specifications of only '/' or '/xxxx/'
6259
6260  If a posix root does not exist, or 'xxxx' is not a directory
6261  in the posix root, it returns a failure.
6262
6263  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6264
6265  It is used only internally by posix_to_vmsspec_hardway().
6266  */
6267
6268 static int posix_root_to_vms
6269   (char *vmspath, int vmspath_len,
6270    const char *unixpath,
6271    const int * utf8_fl) {
6272 int sts;
6273 struct FAB myfab = cc$rms_fab;
6274 struct NAML mynam = cc$rms_naml;
6275 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6276  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6277 char *esa;
6278 char *vms_delim;
6279 int dir_flag;
6280 int unixlen;
6281
6282     dir_flag = 0;
6283     unixlen = strlen(unixpath);
6284     if (unixlen == 0) {
6285       vmspath[0] = '\0';
6286       return RMS$_FNF;
6287     }
6288
6289 #if __CRTL_VER >= 80200000
6290   /* If not a posix spec already, convert it */
6291   if (decc_posix_compliant_pathnames) {
6292     if (strncmp(unixpath,"\"^UP^",5) != 0) {
6293       sprintf(vmspath,"\"^UP^%s\"",unixpath);
6294     }
6295     else {
6296       /* This is already a VMS specification, no conversion */
6297       unixlen--;
6298       strncpy(vmspath,unixpath, vmspath_len);
6299     }
6300   }
6301   else
6302 #endif
6303   {
6304   int path_len;
6305   int i,j;
6306
6307      /* Check to see if this is under the POSIX root */
6308      if (decc_disable_posix_root) {
6309         return RMS$_FNF;
6310      }
6311
6312      /* Skip leading / */
6313      if (unixpath[0] == '/') {
6314         unixpath++;
6315         unixlen--;
6316      }
6317
6318
6319      strcpy(vmspath,"SYS$POSIX_ROOT:");
6320
6321      /* If this is only the / , or blank, then... */
6322      if (unixpath[0] == '\0') {
6323         /* by definition, this is the answer */
6324         return SS$_NORMAL;
6325      }
6326
6327      /* Need to look up a directory */
6328      vmspath[15] = '[';
6329      vmspath[16] = '\0';
6330
6331      /* Copy and add '^' escape characters as needed */
6332      j = 16;
6333      i = 0;
6334      while (unixpath[i] != 0) {
6335      int k;
6336
6337         j += copy_expand_unix_filename_escape
6338             (&vmspath[j], &unixpath[i], &k, utf8_fl);
6339         i += k;
6340      }
6341
6342      path_len = strlen(vmspath);
6343      if (vmspath[path_len - 1] == '/')
6344         path_len--;
6345      vmspath[path_len] = ']';
6346      path_len++;
6347      vmspath[path_len] = '\0';
6348
6349   }
6350   vmspath[vmspath_len] = 0;
6351   if (unixpath[unixlen - 1] == '/')
6352   dir_flag = 1;
6353   esa = PerlMem_malloc(VMS_MAXRSS);
6354   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6355   myfab.fab$l_fna = vmspath;
6356   myfab.fab$b_fns = strlen(vmspath);
6357   myfab.fab$l_naml = &mynam;
6358   mynam.naml$l_esa = NULL;
6359   mynam.naml$b_ess = 0;
6360   mynam.naml$l_long_expand = esa;
6361   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6362   mynam.naml$l_rsa = NULL;
6363   mynam.naml$b_rss = 0;
6364   if (decc_efs_case_preserve)
6365     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6366 #ifdef NAML$M_OPEN_SPECIAL
6367   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6368 #endif
6369
6370   /* Set up the remaining naml fields */
6371   sts = sys$parse(&myfab);
6372
6373   /* It failed! Try again as a UNIX filespec */
6374   if (!(sts & 1)) {
6375     PerlMem_free(esa);
6376     return sts;
6377   }
6378
6379    /* get the Device ID and the FID */
6380    sts = sys$search(&myfab);
6381    /* on any failure, returned the POSIX ^UP^ filespec */
6382    if (!(sts & 1)) {
6383       PerlMem_free(esa);
6384       return sts;
6385    }
6386    specdsc.dsc$a_pointer = vmspath;
6387    specdsc.dsc$w_length = vmspath_len;
6388
6389    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6390    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6391    sts = lib$fid_to_name
6392       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6393
6394   /* on any failure, returned the POSIX ^UP^ filespec */
6395   if (!(sts & 1)) {
6396      /* This can happen if user does not have permission to read directories */
6397      if (strncmp(unixpath,"\"^UP^",5) != 0)
6398        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6399      else
6400        strcpy(vmspath, unixpath);
6401   }
6402   else {
6403     vmspath[specdsc.dsc$w_length] = 0;
6404
6405     /* Are we expecting a directory? */
6406     if (dir_flag != 0) {
6407     int i;
6408     char *eptr;
6409
6410       eptr = NULL;
6411
6412       i = specdsc.dsc$w_length - 1;
6413       while (i > 0) {
6414       int zercnt;
6415         zercnt = 0;
6416         /* Version must be '1' */
6417         if (vmspath[i--] != '1')
6418           break;
6419         /* Version delimiter is one of ".;" */
6420         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6421           break;
6422         i--;
6423         if (vmspath[i--] != 'R')
6424           break;
6425         if (vmspath[i--] != 'I')
6426           break;
6427         if (vmspath[i--] != 'D')
6428           break;
6429         if (vmspath[i--] != '.')
6430           break;
6431         eptr = &vmspath[i+1];
6432         while (i > 0) {
6433           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6434             if (vmspath[i-1] != '^') {
6435               if (zercnt != 6) {
6436                 *eptr = vmspath[i];
6437                 eptr[1] = '\0';
6438                 vmspath[i] = '.';
6439                 break;
6440               }
6441               else {
6442                 /* Get rid of 6 imaginary zero directory filename */
6443                 vmspath[i+1] = '\0';
6444               }
6445             }
6446           }
6447           if (vmspath[i] == '0')
6448             zercnt++;
6449           else
6450             zercnt = 10;
6451           i--;
6452         }
6453         break;
6454       }
6455     }
6456   }
6457   PerlMem_free(esa);
6458   return sts;
6459 }
6460
6461 /* /dev/mumble needs to be handled special.
6462    /dev/null becomes NLA0:, And there is the potential for other stuff
6463    like /dev/tty which may need to be mapped to something.
6464 */
6465
6466 static int
6467 slash_dev_special_to_vms
6468    (const char * unixptr,
6469     char * vmspath,
6470     int vmspath_len)
6471 {
6472 char * nextslash;
6473 int len;
6474 int cmp;
6475 int islnm;
6476
6477     unixptr += 4;
6478     nextslash = strchr(unixptr, '/');
6479     len = strlen(unixptr);
6480     if (nextslash != NULL)
6481         len = nextslash - unixptr;
6482     cmp = strncmp("null", unixptr, 5);
6483     if (cmp == 0) {
6484         if (vmspath_len >= 6) {
6485             strcpy(vmspath, "_NLA0:");
6486             return SS$_NORMAL;
6487         }
6488     }
6489 }
6490
6491
6492 /* The built in routines do not understand perl's special needs, so
6493     doing a manual conversion from UNIX to VMS
6494
6495     If the utf8_fl is not null and points to a non-zero value, then
6496     treat 8 bit characters as UTF-8.
6497
6498     The sequence starting with '$(' and ending with ')' will be passed
6499     through with out interpretation instead of being escaped.
6500
6501   */
6502 static int posix_to_vmsspec_hardway
6503   (char *vmspath, int vmspath_len,
6504    const char *unixpath,
6505    int dir_flag,
6506    int * utf8_fl) {
6507
6508 char *esa;
6509 const char *unixptr;
6510 const char *unixend;
6511 char *vmsptr;
6512 const char *lastslash;
6513 const char *lastdot;
6514 int unixlen;
6515 int vmslen;
6516 int dir_start;
6517 int dir_dot;
6518 int quoted;
6519 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6520 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6521
6522   if (utf8_fl != NULL)
6523     *utf8_fl = 0;
6524
6525   unixptr = unixpath;
6526   dir_dot = 0;
6527
6528   /* Ignore leading "/" characters */
6529   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6530     unixptr++;
6531   }
6532   unixlen = strlen(unixptr);
6533
6534   /* Do nothing with blank paths */
6535   if (unixlen == 0) {
6536     vmspath[0] = '\0';
6537     return SS$_NORMAL;
6538   }
6539
6540   quoted = 0;
6541   /* This could have a "^UP^ on the front */
6542   if (strncmp(unixptr,"\"^UP^",5) == 0) {
6543     quoted = 1;
6544     unixptr+= 5;
6545     unixlen-= 5;
6546   }
6547
6548   lastslash = strrchr(unixptr,'/');
6549   lastdot = strrchr(unixptr,'.');
6550   unixend = strrchr(unixptr,'\"');
6551   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6552     unixend = unixptr + unixlen;
6553   }
6554
6555   /* last dot is last dot or past end of string */
6556   if (lastdot == NULL)
6557     lastdot = unixptr + unixlen;
6558
6559   /* if no directories, set last slash to beginning of string */
6560   if (lastslash == NULL) {
6561     lastslash = unixptr;
6562   }
6563   else {
6564     /* Watch out for trailing "." after last slash, still a directory */
6565     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6566       lastslash = unixptr + unixlen;
6567     }
6568
6569     /* Watch out for traiing ".." after last slash, still a directory */
6570     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6571       lastslash = unixptr + unixlen;
6572     }
6573
6574     /* dots in directories are aways escaped */
6575     if (lastdot < lastslash)
6576       lastdot = unixptr + unixlen;
6577   }
6578
6579   /* if (unixptr < lastslash) then we are in a directory */
6580
6581   dir_start = 0;
6582
6583   vmsptr = vmspath;
6584   vmslen = 0;
6585
6586   /* Start with the UNIX path */
6587   if (*unixptr != '/') {
6588     /* relative paths */
6589
6590     /* If allowing logical names on relative pathnames, then handle here */
6591     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6592         !decc_posix_compliant_pathnames) {
6593     char * nextslash;
6594     int seg_len;
6595     char * trn;
6596     int islnm;
6597
6598         /* Find the next slash */
6599         nextslash = strchr(unixptr,'/');
6600
6601         esa = PerlMem_malloc(vmspath_len);
6602         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6603
6604         trn = PerlMem_malloc(VMS_MAXRSS);
6605         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6606
6607         if (nextslash != NULL) {
6608
6609             seg_len = nextslash - unixptr;
6610             strncpy(esa, unixptr, seg_len);
6611             esa[seg_len] = 0;
6612         }
6613         else {
6614             strcpy(esa, unixptr);
6615             seg_len = strlen(unixptr);
6616         }
6617         /* trnlnm(section) */
6618         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6619
6620         if (islnm) {
6621             /* Now fix up the directory */
6622
6623             /* Split up the path to find the components */
6624             sts = vms_split_path
6625                   (trn,
6626                    &v_spec,
6627                    &v_len,
6628                    &r_spec,
6629                    &r_len,
6630                    &d_spec,
6631                    &d_len,
6632                    &n_spec,
6633                    &n_len,
6634                    &e_spec,
6635                    &e_len,
6636                    &vs_spec,
6637                    &vs_len);
6638
6639             while (sts == 0) {
6640             char * strt;
6641             int cmp;
6642
6643                 /* A logical name must be a directory  or the full
6644                    specification.  It is only a full specification if
6645                    it is the only component */
6646                 if ((unixptr[seg_len] == '\0') ||
6647                     (unixptr[seg_len+1] == '\0')) {
6648
6649                     /* Is a directory being required? */
6650                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6651                         /* Not a logical name */
6652                         break;
6653                     }
6654
6655
6656                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6657                         /* This must be a directory */
6658                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6659                             strcpy(vmsptr, esa);
6660                             vmslen=strlen(vmsptr);
6661                             vmsptr[vmslen] = ':';
6662                             vmslen++;
6663                             vmsptr[vmslen] = '\0';
6664                             return SS$_NORMAL;
6665                         }
6666                     }
6667
6668                 }
6669
6670
6671                 /* must be dev/directory - ignore version */
6672                 if ((n_len + e_len) != 0)
6673                     break;
6674
6675                 /* transfer the volume */
6676                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6677                     strncpy(vmsptr, v_spec, v_len);
6678                     vmsptr += v_len;
6679                     vmsptr[0] = '\0';
6680                     vmslen += v_len;
6681                 }
6682
6683                 /* unroot the rooted directory */
6684                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6685                     r_spec[0] = '[';
6686                     r_spec[r_len - 1] = ']';
6687
6688                     /* This should not be there, but nothing is perfect */
6689                     if (r_len > 9) {
6690                         cmp = strcmp(&r_spec[1], "000000.");
6691                         if (cmp == 0) {
6692                             r_spec += 7;
6693                             r_spec[7] = '[';
6694                             r_len -= 7;
6695                             if (r_len == 2)
6696                                 r_len = 0;
6697                         }
6698                     }
6699                     if (r_len > 0) {
6700                         strncpy(vmsptr, r_spec, r_len);
6701                         vmsptr += r_len;
6702                         vmslen += r_len;
6703                         vmsptr[0] = '\0';
6704                     }
6705                 }
6706                 /* Bring over the directory. */
6707                 if ((d_len > 0) &&
6708                     ((d_len + vmslen) < vmspath_len)) {
6709                     d_spec[0] = '[';
6710                     d_spec[d_len - 1] = ']';
6711                     if (d_len > 9) {
6712                         cmp = strcmp(&d_spec[1], "000000.");
6713                         if (cmp == 0) {
6714                             d_spec += 7;
6715                             d_spec[7] = '[';
6716                             d_len -= 7;
6717                             if (d_len == 2)
6718                                 d_len = 0;
6719                         }
6720                     }
6721
6722                     if (r_len > 0) {
6723                         /* Remove the redundant root */
6724                         if (r_len > 0) {
6725                             /* remove the ][ */
6726                             vmsptr--;
6727                             vmslen--;
6728                             d_spec++;
6729                             d_len--;
6730                         }
6731                         strncpy(vmsptr, d_spec, d_len);
6732                             vmsptr += d_len;
6733                             vmslen += d_len;
6734                             vmsptr[0] = '\0';
6735                     }
6736                 }
6737                 break;
6738             }
6739         }
6740
6741         PerlMem_free(esa);
6742         PerlMem_free(trn);
6743     }
6744
6745     if (lastslash > unixptr) {
6746     int dotdir_seen;
6747
6748       /* skip leading ./ */
6749       dotdir_seen = 0;
6750       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6751         dotdir_seen = 1;
6752         unixptr++;
6753         unixptr++;
6754       }
6755
6756       /* Are we still in a directory? */
6757       if (unixptr <= lastslash) {
6758         *vmsptr++ = '[';
6759         vmslen = 1;
6760         dir_start = 1;
6761
6762         /* if not backing up, then it is relative forward. */
6763         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6764               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6765           *vmsptr++ = '.';
6766           vmslen++;
6767           dir_dot = 1;
6768           }
6769        }
6770        else {
6771          if (dotdir_seen) {
6772            /* Perl wants an empty directory here to tell the difference
6773             * between a DCL commmand and a filename
6774             */
6775           *vmsptr++ = '[';
6776           *vmsptr++ = ']';
6777           vmslen = 2;
6778         }
6779       }
6780     }
6781     else {
6782       /* Handle two special files . and .. */
6783       if (unixptr[0] == '.') {
6784         if (&unixptr[1] == unixend) {
6785           *vmsptr++ = '[';
6786           *vmsptr++ = ']';
6787           vmslen += 2;
6788           *vmsptr++ = '\0';
6789           return SS$_NORMAL;
6790         }
6791         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6792           *vmsptr++ = '[';
6793           *vmsptr++ = '-';
6794           *vmsptr++ = ']';
6795           vmslen += 3;
6796           *vmsptr++ = '\0';
6797           return SS$_NORMAL;
6798         }
6799       }
6800     }
6801   }
6802   else {        /* Absolute PATH handling */
6803   int sts;
6804   char * nextslash;
6805   int seg_len;
6806     /* Need to find out where root is */
6807
6808     /* In theory, this procedure should never get an absolute POSIX pathname
6809      * that can not be found on the POSIX root.
6810      * In practice, that can not be relied on, and things will show up
6811      * here that are a VMS device name or concealed logical name instead.
6812      * So to make things work, this procedure must be tolerant.
6813      */
6814     esa = PerlMem_malloc(vmspath_len);
6815     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6816
6817     sts = SS$_NORMAL;
6818     nextslash = strchr(&unixptr[1],'/');
6819     seg_len = 0;
6820     if (nextslash != NULL) {
6821     int cmp;
6822       seg_len = nextslash - &unixptr[1];
6823       strncpy(vmspath, unixptr, seg_len + 1);
6824       vmspath[seg_len+1] = 0;
6825       cmp = 1;
6826       if (seg_len == 3) {
6827         cmp = strncmp(vmspath, "dev", 4);
6828         if (cmp == 0) {
6829             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6830             if (sts = SS$_NORMAL)
6831                 return SS$_NORMAL;
6832         }
6833       }
6834       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6835     }
6836
6837     if ($VMS_STATUS_SUCCESS(sts)) {
6838       /* This is verified to be a real path */
6839
6840       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6841       if ($VMS_STATUS_SUCCESS(sts)) {
6842         strcpy(vmspath, esa);
6843         vmslen = strlen(vmspath);
6844         vmsptr = vmspath + vmslen;
6845         unixptr++;
6846         if (unixptr < lastslash) {
6847         char * rptr;
6848           vmsptr--;
6849           *vmsptr++ = '.';
6850           dir_start = 1;
6851           dir_dot = 1;
6852           if (vmslen > 7) {
6853           int cmp;
6854             rptr = vmsptr - 7;
6855             cmp = strcmp(rptr,"000000.");
6856             if (cmp == 0) {
6857               vmslen -= 7;
6858               vmsptr -= 7;
6859               vmsptr[1] = '\0';
6860             } /* removing 6 zeros */
6861           } /* vmslen < 7, no 6 zeros possible */
6862         } /* Not in a directory */
6863       } /* Posix root found */
6864       else {
6865         /* No posix root, fall back to default directory */
6866         strcpy(vmspath, "SYS$DISK:[");
6867         vmsptr = &vmspath[10];
6868         vmslen = 10;
6869         if (unixptr > lastslash) {
6870            *vmsptr = ']';
6871            vmsptr++;
6872            vmslen++;
6873         }
6874         else {
6875            dir_start = 1;
6876         }
6877       }
6878     } /* end of verified real path handling */
6879     else {
6880     int add_6zero;
6881     int islnm;
6882
6883       /* Ok, we have a device or a concealed root that is not in POSIX
6884        * or we have garbage.  Make the best of it.
6885        */
6886
6887       /* Posix to VMS destroyed this, so copy it again */
6888       strncpy(vmspath, &unixptr[1], seg_len);
6889       vmspath[seg_len] = 0;
6890       vmslen = seg_len;
6891       vmsptr = &vmsptr[vmslen];
6892       islnm = 0;
6893
6894       /* Now do we need to add the fake 6 zero directory to it? */
6895       add_6zero = 1;
6896       if ((*lastslash == '/') && (nextslash < lastslash)) {
6897         /* No there is another directory */
6898         add_6zero = 0;
6899       }
6900       else {
6901       int trnend;
6902       int cmp;
6903
6904         /* now we have foo:bar or foo:[000000]bar to decide from */
6905         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6906
6907         if (!islnm && !decc_posix_compliant_pathnames) {
6908
6909             cmp = strncmp("bin", vmspath, 4);
6910             if (cmp == 0) {
6911                 /* bin => SYS$SYSTEM: */
6912                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6913             }
6914             else {
6915                 /* tmp => SYS$SCRATCH: */
6916                 cmp = strncmp("tmp", vmspath, 4);
6917                 if (cmp == 0) {
6918                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6919                 }
6920             }
6921         }
6922
6923         trnend = islnm ? islnm - 1 : 0;
6924
6925         /* if this was a logical name, ']' or '>' must be present */
6926         /* if not a logical name, then assume a device and hope. */
6927         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6928
6929         /* if log name and trailing '.' then rooted - treat as device */
6930         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6931
6932         /* Fix me, if not a logical name, a device lookup should be
6933          * done to see if the device is file structured.  If the device
6934          * is not file structured, the 6 zeros should not be put on.
6935          *
6936          * As it is, perl is occasionally looking for dev:[000000]tty.
6937          * which looks a little strange.
6938          *
6939          * Not that easy to detect as "/dev" may be file structured with
6940          * special device files.
6941          */
6942
6943         if ((add_6zero == 0) && (*nextslash == '/') &&
6944             (&nextslash[1] == unixend)) {
6945           /* No real directory present */
6946           add_6zero = 1;
6947         }
6948       }
6949
6950       /* Put the device delimiter on */
6951       *vmsptr++ = ':';
6952       vmslen++;
6953       unixptr = nextslash;
6954       unixptr++;
6955
6956       /* Start directory if needed */
6957       if (!islnm || add_6zero) {
6958         *vmsptr++ = '[';
6959         vmslen++;
6960         dir_start = 1;
6961       }
6962
6963       /* add fake 000000] if needed */
6964       if (add_6zero) {
6965         *vmsptr++ = '0';
6966         *vmsptr++ = '0';
6967         *vmsptr++ = '0';
6968         *vmsptr++ = '0';
6969         *vmsptr++ = '0';
6970         *vmsptr++ = '0';
6971         *vmsptr++ = ']';
6972         vmslen += 7;
6973         dir_start = 0;
6974       }
6975
6976     } /* non-POSIX translation */
6977     PerlMem_free(esa);
6978   } /* End of relative/absolute path handling */
6979
6980   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6981   int dash_flag;
6982   int in_cnt;
6983   int out_cnt;
6984
6985     dash_flag = 0;
6986
6987     if (dir_start != 0) {
6988
6989       /* First characters in a directory are handled special */
6990       while ((*unixptr == '/') ||
6991              ((*unixptr == '.') &&
6992               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6993                 (&unixptr[1]==unixend)))) {
6994       int loop_flag;
6995
6996         loop_flag = 0;
6997
6998         /* Skip redundant / in specification */
6999         while ((*unixptr == '/') && (dir_start != 0)) {
7000           loop_flag = 1;
7001           unixptr++;
7002           if (unixptr == lastslash)
7003             break;
7004         }
7005         if (unixptr == lastslash)
7006           break;
7007
7008         /* Skip redundant ./ characters */
7009         while ((*unixptr == '.') &&
7010                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
7011           loop_flag = 1;
7012           unixptr++;
7013           if (unixptr == lastslash)
7014             break;
7015           if (*unixptr == '/')
7016             unixptr++;
7017         }
7018         if (unixptr == lastslash)
7019           break;
7020
7021         /* Skip redundant ../ characters */
7022         while ((*unixptr == '.') && (unixptr[1] == '.') &&
7023              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
7024           /* Set the backing up flag */
7025           loop_flag = 1;
7026           dir_dot = 0;
7027           dash_flag = 1;
7028           *vmsptr++ = '-';
7029           vmslen++;
7030           unixptr++; /* first . */
7031           unixptr++; /* second . */
7032           if (unixptr == lastslash)
7033             break;
7034           if (*unixptr == '/') /* The slash */
7035             unixptr++;
7036         }
7037         if (unixptr == lastslash)
7038           break;
7039
7040         /* To do: Perl expects /.../ to be translated to [...] on VMS */
7041         /* Not needed when VMS is pretending to be UNIX. */
7042
7043         /* Is this loop stuck because of too many dots? */
7044         if (loop_flag == 0) {
7045           /* Exit the loop and pass the rest through */
7046           break;
7047         }
7048       }
7049
7050       /* Are we done with directories yet? */
7051       if (unixptr >= lastslash) {
7052
7053         /* Watch out for trailing dots */
7054         if (dir_dot != 0) {
7055             vmslen --;
7056             vmsptr--;
7057         }
7058         *vmsptr++ = ']';
7059         vmslen++;
7060         dash_flag = 0;
7061         dir_start = 0;
7062         if (*unixptr == '/')
7063           unixptr++;
7064       }
7065       else {
7066         /* Have we stopped backing up? */
7067         if (dash_flag) {
7068           *vmsptr++ = '.';
7069           vmslen++;
7070           dash_flag = 0;
7071           /* dir_start continues to be = 1 */
7072         }
7073         if (*unixptr == '-') {
7074           *vmsptr++ = '^';
7075           *vmsptr++ = *unixptr++;
7076           vmslen += 2;
7077           dir_start = 0;
7078
7079           /* Now are we done with directories yet? */
7080           if (unixptr >= lastslash) {
7081
7082             /* Watch out for trailing dots */
7083             if (dir_dot != 0) {
7084               vmslen --;
7085               vmsptr--;
7086             }
7087
7088             *vmsptr++ = ']';
7089             vmslen++;
7090             dash_flag = 0;
7091             dir_start = 0;
7092           }
7093         }
7094       }
7095     }
7096
7097     /* All done? */
7098     if (unixptr >= unixend)
7099       break;
7100
7101     /* Normal characters - More EFS work probably needed */
7102     dir_start = 0;
7103     dir_dot = 0;
7104
7105     switch(*unixptr) {
7106     case '/':
7107         /* remove multiple / */
7108         while (unixptr[1] == '/') {
7109            unixptr++;
7110         }
7111         if (unixptr == lastslash) {
7112           /* Watch out for trailing dots */
7113           if (dir_dot != 0) {
7114             vmslen --;
7115             vmsptr--;
7116           }
7117           *vmsptr++ = ']';
7118         }
7119         else {
7120           dir_start = 1;
7121           *vmsptr++ = '.';
7122           dir_dot = 1;
7123
7124           /* To do: Perl expects /.../ to be translated to [...] on VMS */
7125           /* Not needed when VMS is pretending to be UNIX. */
7126
7127         }
7128         dash_flag = 0;
7129         if (unixptr != unixend)
7130           unixptr++;
7131         vmslen++;
7132         break;
7133     case '.':
7134         if ((unixptr < lastdot) || (unixptr < lastslash) ||
7135             (&unixptr[1] == unixend)) {
7136           *vmsptr++ = '^';
7137           *vmsptr++ = '.';
7138           vmslen += 2;
7139           unixptr++;
7140
7141           /* trailing dot ==> '^..' on VMS */
7142           if (unixptr == unixend) {
7143             *vmsptr++ = '.';
7144             vmslen++;
7145             unixptr++;
7146           }
7147           break;
7148         }
7149
7150         *vmsptr++ = *unixptr++;
7151         vmslen ++;
7152         break;
7153     case '"':
7154         if (quoted && (&unixptr[1] == unixend)) {
7155             unixptr++;
7156             break;
7157         }
7158         in_cnt = copy_expand_unix_filename_escape
7159                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7160         vmsptr += out_cnt;
7161         unixptr += in_cnt;
7162         break;
7163     case '~':
7164     case ';':
7165     case '\\':
7166     case '?':
7167     case ' ':
7168     default:
7169         in_cnt = copy_expand_unix_filename_escape
7170                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7171         vmsptr += out_cnt;
7172         unixptr += in_cnt;
7173         break;
7174     }
7175   }
7176
7177   /* Make sure directory is closed */
7178   if (unixptr == lastslash) {
7179     char *vmsptr2;
7180     vmsptr2 = vmsptr - 1;
7181
7182     if (*vmsptr2 != ']') {
7183       *vmsptr2--;
7184
7185       /* directories do not end in a dot bracket */
7186       if (*vmsptr2 == '.') {
7187         vmsptr2--;
7188
7189         /* ^. is allowed */
7190         if (*vmsptr2 != '^') {
7191           vmsptr--; /* back up over the dot */
7192         }
7193       }
7194       *vmsptr++ = ']';
7195     }
7196   }
7197   else {
7198     char *vmsptr2;
7199     /* Add a trailing dot if a file with no extension */
7200     vmsptr2 = vmsptr - 1;
7201     if ((vmslen > 1) &&
7202         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7203         (*vmsptr2 != ')') && (*lastdot != '.')) {
7204         *vmsptr++ = '.';
7205         vmslen++;
7206     }
7207   }
7208
7209   *vmsptr = '\0';
7210   return SS$_NORMAL;
7211 }
7212 #endif
7213
7214  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7215 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7216 {
7217 char * result;
7218 int utf8_flag;
7219
7220    /* If a UTF8 flag is being passed, honor it */
7221    utf8_flag = 0;
7222    if (utf8_fl != NULL) {
7223      utf8_flag = *utf8_fl;
7224     *utf8_fl = 0;
7225    }
7226
7227    if (utf8_flag) {
7228      /* If there is a possibility of UTF8, then if any UTF8 characters
7229         are present, then they must be converted to VTF-7
7230       */
7231      result = strcpy(rslt, path); /* FIX-ME */
7232    }
7233    else
7234      result = strcpy(rslt, path);
7235
7236    return result;
7237 }
7238
7239
7240 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7241 static char *mp_do_tovmsspec
7242    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7243   static char __tovmsspec_retbuf[VMS_MAXRSS];
7244   char *rslt, *dirend;
7245   char *lastdot;
7246   char *vms_delim;
7247   register char *cp1;
7248   const char *cp2;
7249   unsigned long int infront = 0, hasdir = 1;
7250   int rslt_len;
7251   int no_type_seen;
7252   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7253   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7254
7255   if (path == NULL) return NULL;
7256   rslt_len = VMS_MAXRSS-1;
7257   if (buf) rslt = buf;
7258   else if (ts) Newx(rslt, VMS_MAXRSS, char);
7259   else rslt = __tovmsspec_retbuf;
7260
7261   /* '.' and '..' are "[]" and "[-]" for a quick check */
7262   if (path[0] == '.') {
7263     if (path[1] == '\0') {
7264       strcpy(rslt,"[]");
7265       if (utf8_flag != NULL)
7266         *utf8_flag = 0;
7267       return rslt;
7268     }
7269     else {
7270       if (path[1] == '.' && path[2] == '\0') {
7271         strcpy(rslt,"[-]");
7272         if (utf8_flag != NULL)
7273            *utf8_flag = 0;
7274         return rslt;
7275       }
7276     }
7277   }
7278
7279    /* Posix specifications are now a native VMS format */
7280   /*--------------------------------------------------*/
7281 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7282   if (decc_posix_compliant_pathnames) {
7283     if (strncmp(path,"\"^UP^",5) == 0) {
7284       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7285       return rslt;
7286     }
7287   }
7288 #endif
7289
7290   /* This is really the only way to see if this is already in VMS format */
7291   sts = vms_split_path
7292        (path,
7293         &v_spec,
7294         &v_len,
7295         &r_spec,
7296         &r_len,
7297         &d_spec,
7298         &d_len,
7299         &n_spec,
7300         &n_len,
7301         &e_spec,
7302         &e_len,
7303         &vs_spec,
7304         &vs_len);
7305   if (sts == 0) {
7306     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7307        replacement, because the above parse just took care of most of
7308        what is needed to do vmspath when the specification is already
7309        in VMS format.
7310
7311        And if it is not already, it is easier to do the conversion as
7312        part of this routine than to call this routine and then work on
7313        the result.
7314      */
7315
7316     /* If VMS punctuation was found, it is already VMS format */
7317     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7318       if (utf8_flag != NULL)
7319         *utf8_flag = 0;
7320       strcpy(rslt, path);
7321       return rslt;
7322     }
7323     /* Now, what to do with trailing "." cases where there is no
7324        extension?  If this is a UNIX specification, and EFS characters
7325        are enabled, then the trailing "." should be converted to a "^.".
7326        But if this was already a VMS specification, then it should be
7327        left alone.
7328
7329        So in the case of ambiguity, leave the specification alone.
7330      */
7331
7332
7333     /* If there is a possibility of UTF8, then if any UTF8 characters
7334         are present, then they must be converted to VTF-7
7335      */
7336     if (utf8_flag != NULL)
7337       *utf8_flag = 0;
7338     strcpy(rslt, path);
7339     return rslt;
7340   }
7341
7342   dirend = strrchr(path,'/');
7343
7344   if (dirend == NULL) {
7345      /* If we get here with no UNIX directory delimiters, then this is
7346         not a complete file specification, either garbage a UNIX glob
7347         specification that can not be converted to a VMS wildcard, or
7348         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7349         so apparently other programs expect this also.
7350
7351         utf8 flag setting needs to be preserved.
7352       */
7353       strcpy(rslt, path);
7354       return rslt;
7355   }
7356
7357 /* If POSIX mode active, handle the conversion */
7358 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7359   if (decc_efs_charset) {
7360     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7361     return rslt;
7362   }
7363 #endif
7364
7365   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7366     if (!*(dirend+2)) dirend +=2;
7367     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7368     if (decc_efs_charset == 0) {
7369       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7370     }
7371   }
7372
7373   cp1 = rslt;
7374   cp2 = path;
7375   lastdot = strrchr(cp2,'.');
7376   if (*cp2 == '/') {
7377     char *trndev;
7378     int islnm, rooted;
7379     STRLEN trnend;
7380
7381     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7382     if (!*(cp2+1)) {
7383       if (decc_disable_posix_root) {
7384         strcpy(rslt,"sys$disk:[000000]");
7385       }
7386       else {
7387         strcpy(rslt,"sys$posix_root:[000000]");
7388       }
7389       if (utf8_flag != NULL)
7390         *utf8_flag = 0;
7391       return rslt;
7392     }
7393     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7394     *cp1 = '\0';
7395     trndev = PerlMem_malloc(VMS_MAXRSS);
7396     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7397     islnm =  my_trnlnm(rslt,trndev,0);
7398
7399      /* DECC special handling */
7400     if (!islnm) {
7401       if (strcmp(rslt,"bin") == 0) {
7402         strcpy(rslt,"sys$system");
7403         cp1 = rslt + 10;
7404         *cp1 = 0;
7405         islnm =  my_trnlnm(rslt,trndev,0);
7406       }
7407       else if (strcmp(rslt,"tmp") == 0) {
7408         strcpy(rslt,"sys$scratch");
7409         cp1 = rslt + 11;
7410         *cp1 = 0;
7411         islnm =  my_trnlnm(rslt,trndev,0);
7412       }
7413       else if (!decc_disable_posix_root) {
7414         strcpy(rslt, "sys$posix_root");
7415         cp1 = rslt + 13;
7416         *cp1 = 0;
7417         cp2 = path;
7418         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7419         islnm =  my_trnlnm(rslt,trndev,0);
7420       }
7421       else if (strcmp(rslt,"dev") == 0) {
7422         if (strncmp(cp2,"/null", 5) == 0) {
7423           if ((cp2[5] == 0) || (cp2[5] == '/')) {
7424             strcpy(rslt,"NLA0");
7425             cp1 = rslt + 4;
7426             *cp1 = 0;
7427             cp2 = cp2 + 5;
7428             islnm =  my_trnlnm(rslt,trndev,0);
7429           }
7430         }
7431       }
7432     }
7433
7434     trnend = islnm ? strlen(trndev) - 1 : 0;
7435     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7436     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7437     /* If the first element of the path is a logical name, determine
7438      * whether it has to be translated so we can add more directories. */
7439     if (!islnm || rooted) {
7440       *(cp1++) = ':';
7441       *(cp1++) = '[';
7442       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7443       else cp2++;
7444     }
7445     else {
7446       if (cp2 != dirend) {
7447         strcpy(rslt,trndev);
7448         cp1 = rslt + trnend;
7449         if (*cp2 != 0) {
7450           *(cp1++) = '.';
7451           cp2++;
7452         }
7453       }
7454       else {
7455         if (decc_disable_posix_root) {
7456           *(cp1++) = ':';
7457           hasdir = 0;
7458         }
7459       }
7460     }
7461     PerlMem_free(trndev);
7462   }
7463   else {
7464     *(cp1++) = '[';
7465     if (*cp2 == '.') {
7466       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7467         cp2 += 2;         /* skip over "./" - it's redundant */
7468         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
7469       }
7470       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7471         *(cp1++) = '-';                                 /* "../" --> "-" */
7472         cp2 += 3;
7473       }
7474       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7475                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7476         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7477         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7478         cp2 += 4;
7479       }
7480       else if ((cp2 != lastdot) || (lastdot < dirend)) {
7481         /* Escape the extra dots in EFS file specifications */
7482         *(cp1++) = '^';
7483       }
7484       if (cp2 > dirend) cp2 = dirend;
7485     }
7486     else *(cp1++) = '.';
7487   }
7488   for (; cp2 < dirend; cp2++) {
7489     if (*cp2 == '/') {
7490       if (*(cp2-1) == '/') continue;
7491       if (*(cp1-1) != '.') *(cp1++) = '.';
7492       infront = 0;
7493     }
7494     else if (!infront && *cp2 == '.') {
7495       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7496       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
7497       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7498         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7499         else if (*(cp1-2) == '[') *(cp1-1) = '-';
7500         else {  /* back up over previous directory name */
7501           cp1--;
7502           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7503           if (*(cp1-1) == '[') {
7504             memcpy(cp1,"000000.",7);
7505             cp1 += 7;
7506           }
7507         }
7508         cp2 += 2;
7509         if (cp2 == dirend) break;
7510       }
7511       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7512                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7513         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7514         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7515         if (!*(cp2+3)) {
7516           *(cp1++) = '.';  /* Simulate trailing '/' */
7517           cp2 += 2;  /* for loop will incr this to == dirend */
7518         }
7519         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
7520       }
7521       else {
7522         if (decc_efs_charset == 0)
7523           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
7524         else {
7525           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
7526           *(cp1++) = '.';
7527         }
7528       }
7529     }
7530     else {
7531       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
7532       if (*cp2 == '.') {
7533         if (decc_efs_charset == 0)
7534           *(cp1++) = '_';
7535         else {
7536           *(cp1++) = '^';
7537           *(cp1++) = '.';
7538         }
7539       }
7540       else                  *(cp1++) =  *cp2;
7541       infront = 1;
7542     }
7543   }
7544   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7545   if (hasdir) *(cp1++) = ']';
7546   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
7547   /* fixme for ODS5 */
7548   no_type_seen = 0;
7549   if (cp2 > lastdot)
7550     no_type_seen = 1;
7551   while (*cp2) {
7552     switch(*cp2) {
7553     case '?':
7554         if (decc_efs_charset == 0)
7555           *(cp1++) = '%';
7556         else
7557           *(cp1++) = '?';
7558         cp2++;
7559     case ' ':
7560         *(cp1)++ = '^';
7561         *(cp1)++ = '_';
7562         cp2++;
7563         break;
7564     case '.':
7565         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7566             decc_readdir_dropdotnotype) {
7567           *(cp1)++ = '^';
7568           *(cp1)++ = '.';
7569           cp2++;
7570
7571           /* trailing dot ==> '^..' on VMS */
7572           if (*cp2 == '\0') {
7573             *(cp1++) = '.';
7574             no_type_seen = 0;
7575           }
7576         }
7577         else {
7578           *(cp1++) = *(cp2++);
7579           no_type_seen = 0;
7580         }
7581         break;
7582     case '$':
7583          /* This could be a macro to be passed through */
7584         *(cp1++) = *(cp2++);
7585         if (*cp2 == '(') {
7586         const char * save_cp2;
7587         char * save_cp1;
7588         int is_macro;
7589
7590             /* paranoid check */
7591             save_cp2 = cp2;
7592             save_cp1 = cp1;
7593             is_macro = 0;
7594
7595             /* Test through */
7596             *(cp1++) = *(cp2++);
7597             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7598                 *(cp1++) = *(cp2++);
7599                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7600                     *(cp1++) = *(cp2++);
7601                 }
7602                 if (*cp2 == ')') {
7603                     *(cp1++) = *(cp2++);
7604                     is_macro = 1;
7605                 }
7606             }
7607             if (is_macro == 0) {
7608                 /* Not really a macro - never mind */
7609                 cp2 = save_cp2;
7610                 cp1 = save_cp1;
7611             }
7612         }
7613         break;
7614     case '\"':
7615     case '~':
7616     case '`':
7617     case '!':
7618     case '#':
7619     case '%':
7620     case '^':
7621         /* Don't escape again if following character is
7622          * already something we escape.
7623          */
7624         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
7625             *(cp1++) = *(cp2++);
7626             break;
7627         }
7628         /* But otherwise fall through and escape it. */
7629     case '&':
7630     case '(':
7631     case ')':
7632     case '=':
7633     case '+':
7634     case '\'':
7635     case '@':
7636     case '[':
7637     case ']':
7638     case '{':
7639     case '}':
7640     case ':':
7641     case '\\':
7642     case '|':
7643     case '<':
7644     case '>':
7645         *(cp1++) = '^';
7646         *(cp1++) = *(cp2++);
7647         break;
7648     case ';':
7649         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7650          * which is wrong.  UNIX notation should be ".dir." unless
7651          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7652          * changing this behavior could break more things at this time.
7653          * efs character set effectively does not allow "." to be a version
7654          * delimiter as a further complication about changing this.
7655          */
7656         if (decc_filename_unix_report != 0) {
7657           *(cp1++) = '^';
7658         }
7659         *(cp1++) = *(cp2++);
7660         break;
7661     default:
7662         *(cp1++) = *(cp2++);
7663     }
7664   }
7665   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7666   char *lcp1;
7667     lcp1 = cp1;
7668     lcp1--;
7669      /* Fix me for "^]", but that requires making sure that you do
7670       * not back up past the start of the filename
7671       */
7672     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7673       *cp1++ = '.';
7674   }
7675   *cp1 = '\0';
7676
7677   if (utf8_flag != NULL)
7678     *utf8_flag = 0;
7679   return rslt;
7680
7681 }  /* end of do_tovmsspec() */
7682 /*}}}*/
7683 /* External entry points */
7684 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7685   { return do_tovmsspec(path,buf,0,NULL); }
7686 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7687   { return do_tovmsspec(path,buf,1,NULL); }
7688 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7689   { return do_tovmsspec(path,buf,0,utf8_fl); }
7690 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7691   { return do_tovmsspec(path,buf,1,utf8_fl); }
7692
7693 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7694 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7695   static char __tovmspath_retbuf[VMS_MAXRSS];
7696   int vmslen;
7697   char *pathified, *vmsified, *cp;
7698
7699   if (path == NULL) return NULL;
7700   pathified = PerlMem_malloc(VMS_MAXRSS);
7701   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7702   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7703     PerlMem_free(pathified);
7704     return NULL;
7705   }
7706
7707   vmsified = NULL;
7708   if (buf == NULL)
7709      Newx(vmsified, VMS_MAXRSS, char);
7710   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7711     PerlMem_free(pathified);
7712     if (vmsified) Safefree(vmsified);
7713     return NULL;
7714   }
7715   PerlMem_free(pathified);
7716   if (buf) {
7717     return buf;
7718   }
7719   else if (ts) {
7720     vmslen = strlen(vmsified);
7721     Newx(cp,vmslen+1,char);
7722     memcpy(cp,vmsified,vmslen);
7723     cp[vmslen] = '\0';
7724     Safefree(vmsified);
7725     return cp;
7726   }
7727   else {
7728     strcpy(__tovmspath_retbuf,vmsified);
7729     Safefree(vmsified);
7730     return __tovmspath_retbuf;
7731   }
7732
7733 }  /* end of do_tovmspath() */
7734 /*}}}*/
7735 /* External entry points */
7736 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7737   { return do_tovmspath(path,buf,0, NULL); }
7738 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7739   { return do_tovmspath(path,buf,1, NULL); }
7740 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7741   { return do_tovmspath(path,buf,0,utf8_fl); }
7742 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7743   { return do_tovmspath(path,buf,1,utf8_fl); }
7744
7745
7746 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7747 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7748   static char __tounixpath_retbuf[VMS_MAXRSS];
7749   int unixlen;
7750   char *pathified, *unixified, *cp;
7751
7752   if (path == NULL) return NULL;
7753   pathified = PerlMem_malloc(VMS_MAXRSS);
7754   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7755   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7756     PerlMem_free(pathified);
7757     return NULL;
7758   }
7759
7760   unixified = NULL;
7761   if (buf == NULL) {
7762       Newx(unixified, VMS_MAXRSS, char);
7763   }
7764   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7765     PerlMem_free(pathified);
7766     if (unixified) Safefree(unixified);
7767     return NULL;
7768   }
7769   PerlMem_free(pathified);
7770   if (buf) {
7771     return buf;
7772   }
7773   else if (ts) {
7774     unixlen = strlen(unixified);
7775     Newx(cp,unixlen+1,char);
7776     memcpy(cp,unixified,unixlen);
7777     cp[unixlen] = '\0';
7778     Safefree(unixified);
7779     return cp;
7780   }
7781   else {
7782     strcpy(__tounixpath_retbuf,unixified);
7783     Safefree(unixified);
7784     return __tounixpath_retbuf;
7785   }
7786
7787 }  /* end of do_tounixpath() */
7788 /*}}}*/
7789 /* External entry points */
7790 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7791   { return do_tounixpath(path,buf,0,NULL); }
7792 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7793   { return do_tounixpath(path,buf,1,NULL); }
7794 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7795   { return do_tounixpath(path,buf,0,utf8_fl); }
7796 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7797   { return do_tounixpath(path,buf,1,utf8_fl); }
7798
7799 /*
7800  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
7801  *
7802  *****************************************************************************
7803  *                                                                           *
7804  *  Copyright (C) 1989-1994, 2007 by                                         *
7805  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
7806  *                                                                           *
7807  *  Permission is hereby granted for the reproduction of this software       *
7808  *  on condition that this copyright notice is included in source            *
7809  *  distributions of the software.  The code may be modified and             *
7810  *  distributed under the same terms as Perl itself.                         *
7811  *                                                                           *
7812  *  27-Aug-1994 Modified for inclusion in perl5                              *
7813  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
7814  *****************************************************************************
7815  */
7816
7817 /*
7818  * getredirection() is intended to aid in porting C programs
7819  * to VMS (Vax-11 C).  The native VMS environment does not support
7820  * '>' and '<' I/O redirection, or command line wild card expansion,
7821  * or a command line pipe mechanism using the '|' AND background
7822  * command execution '&'.  All of these capabilities are provided to any
7823  * C program which calls this procedure as the first thing in the
7824  * main program.
7825  * The piping mechanism will probably work with almost any 'filter' type
7826  * of program.  With suitable modification, it may useful for other
7827  * portability problems as well.
7828  *
7829  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
7830  */
7831 struct list_item
7832     {
7833     struct list_item *next;
7834     char *value;
7835     };
7836
7837 static void add_item(struct list_item **head,
7838                      struct list_item **tail,
7839                      char *value,
7840                      int *count);
7841
7842 static void mp_expand_wild_cards(pTHX_ char *item,
7843                                 struct list_item **head,
7844                                 struct list_item **tail,
7845                                 int *count);
7846
7847 static int background_process(pTHX_ int argc, char **argv);
7848
7849 static void pipe_and_fork(pTHX_ char **cmargv);
7850
7851 /*{{{ void getredirection(int *ac, char ***av)*/
7852 static void
7853 mp_getredirection(pTHX_ int *ac, char ***av)
7854 /*
7855  * Process vms redirection arg's.  Exit if any error is seen.
7856  * If getredirection() processes an argument, it is erased
7857  * from the vector.  getredirection() returns a new argc and argv value.
7858  * In the event that a background command is requested (by a trailing "&"),
7859  * this routine creates a background subprocess, and simply exits the program.
7860  *
7861  * Warning: do not try to simplify the code for vms.  The code
7862  * presupposes that getredirection() is called before any data is
7863  * read from stdin or written to stdout.
7864  *
7865  * Normal usage is as follows:
7866  *
7867  *      main(argc, argv)
7868  *      int             argc;
7869  *      char            *argv[];
7870  *      {
7871  *              getredirection(&argc, &argv);
7872  *      }
7873  */
7874 {
7875     int                 argc = *ac;     /* Argument Count         */
7876     char                **argv = *av;   /* Argument Vector        */
7877     char                *ap;            /* Argument pointer       */
7878     int                 j;              /* argv[] index           */
7879     int                 item_count = 0; /* Count of Items in List */
7880     struct list_item    *list_head = 0; /* First Item in List       */
7881     struct list_item    *list_tail;     /* Last Item in List        */
7882     char                *in = NULL;     /* Input File Name          */
7883     char                *out = NULL;    /* Output File Name         */
7884     char                *outmode = "w"; /* Mode to Open Output File */
7885     char                *err = NULL;    /* Error File Name          */
7886     char                *errmode = "w"; /* Mode to Open Error File  */
7887     int                 cmargc = 0;     /* Piped Command Arg Count  */
7888     char                **cmargv = NULL;/* Piped Command Arg Vector */
7889
7890     /*
7891      * First handle the case where the last thing on the line ends with
7892      * a '&'.  This indicates the desire for the command to be run in a
7893      * subprocess, so we satisfy that desire.
7894      */
7895     ap = argv[argc-1];
7896     if (0 == strcmp("&", ap))
7897        exit(background_process(aTHX_ --argc, argv));
7898     if (*ap && '&' == ap[strlen(ap)-1])
7899         {
7900         ap[strlen(ap)-1] = '\0';
7901        exit(background_process(aTHX_ argc, argv));
7902         }
7903     /*
7904      * Now we handle the general redirection cases that involve '>', '>>',
7905      * '<', and pipes '|'.
7906      */
7907     for (j = 0; j < argc; ++j)
7908         {
7909         if (0 == strcmp("<", argv[j]))
7910             {
7911             if (j+1 >= argc)
7912                 {
7913                 fprintf(stderr,"No input file after < on command line");
7914                 exit(LIB$_WRONUMARG);
7915                 }
7916             in = argv[++j];
7917             continue;
7918             }
7919         if ('<' == *(ap = argv[j]))
7920             {
7921             in = 1 + ap;
7922             continue;
7923             }
7924         if (0 == strcmp(">", ap))
7925             {
7926             if (j+1 >= argc)
7927                 {
7928                 fprintf(stderr,"No output file after > on command line");
7929                 exit(LIB$_WRONUMARG);
7930                 }
7931             out = argv[++j];
7932             continue;
7933             }
7934         if ('>' == *ap)
7935             {
7936             if ('>' == ap[1])
7937                 {
7938                 outmode = "a";
7939                 if ('\0' == ap[2])
7940                     out = argv[++j];
7941                 else
7942                     out = 2 + ap;
7943                 }
7944             else
7945                 out = 1 + ap;
7946             if (j >= argc)
7947                 {
7948                 fprintf(stderr,"No output file after > or >> on command line");
7949                 exit(LIB$_WRONUMARG);
7950                 }
7951             continue;
7952             }
7953         if (('2' == *ap) && ('>' == ap[1]))
7954             {
7955             if ('>' == ap[2])
7956                 {
7957                 errmode = "a";
7958                 if ('\0' == ap[3])
7959                     err = argv[++j];
7960                 else
7961                     err = 3 + ap;
7962                 }
7963             else
7964                 if ('\0' == ap[2])
7965                     err = argv[++j];
7966                 else
7967                     err = 2 + ap;
7968             if (j >= argc)
7969                 {
7970                 fprintf(stderr,"No output file after 2> or 2>> on command line");
7971                 exit(LIB$_WRONUMARG);
7972                 }
7973             continue;
7974             }
7975         if (0 == strcmp("|", argv[j]))
7976             {
7977             if (j+1 >= argc)
7978                 {
7979                 fprintf(stderr,"No command into which to pipe on command line");
7980                 exit(LIB$_WRONUMARG);
7981                 }
7982             cmargc = argc-(j+1);
7983             cmargv = &argv[j+1];
7984             argc = j;
7985             continue;
7986             }
7987         if ('|' == *(ap = argv[j]))
7988             {
7989             ++argv[j];
7990             cmargc = argc-j;
7991             cmargv = &argv[j];
7992             argc = j;
7993             continue;
7994             }
7995         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7996         }
7997     /*
7998      * Allocate and fill in the new argument vector, Some Unix's terminate
7999      * the list with an extra null pointer.
8000      */
8001     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
8002     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8003     *av = argv;
8004     for (j = 0; j < item_count; ++j, list_head = list_head->next)
8005         argv[j] = list_head->value;
8006     *ac = item_count;
8007     if (cmargv != NULL)
8008         {
8009         if (out != NULL)
8010             {
8011             fprintf(stderr,"'|' and '>' may not both be specified on command line");
8012             exit(LIB$_INVARGORD);
8013             }
8014         pipe_and_fork(aTHX_ cmargv);
8015         }
8016
8017     /* Check for input from a pipe (mailbox) */
8018
8019     if (in == NULL && 1 == isapipe(0))
8020         {
8021         char mbxname[L_tmpnam];
8022         long int bufsize;
8023         long int dvi_item = DVI$_DEVBUFSIZ;
8024         $DESCRIPTOR(mbxnam, "");
8025         $DESCRIPTOR(mbxdevnam, "");
8026
8027         /* Input from a pipe, reopen it in binary mode to disable       */
8028         /* carriage control processing.                                 */
8029
8030         fgetname(stdin, mbxname);
8031         mbxnam.dsc$a_pointer = mbxname;
8032         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
8033         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
8034         mbxdevnam.dsc$a_pointer = mbxname;
8035         mbxdevnam.dsc$w_length = sizeof(mbxname);
8036         dvi_item = DVI$_DEVNAM;
8037         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
8038         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
8039         set_errno(0);
8040         set_vaxc_errno(1);
8041         freopen(mbxname, "rb", stdin);
8042         if (errno != 0)
8043             {
8044             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
8045             exit(vaxc$errno);
8046             }
8047         }
8048     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8049         {
8050         fprintf(stderr,"Can't open input file %s as stdin",in);
8051         exit(vaxc$errno);
8052         }
8053     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8054         {
8055         fprintf(stderr,"Can't open output file %s as stdout",out);
8056         exit(vaxc$errno);
8057         }
8058         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8059
8060     if (err != NULL) {
8061         if (strcmp(err,"&1") == 0) {
8062             dup2(fileno(stdout), fileno(stderr));
8063             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8064         } else {
8065         FILE *tmperr;
8066         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8067             {
8068             fprintf(stderr,"Can't open error file %s as stderr",err);
8069             exit(vaxc$errno);
8070             }
8071             fclose(tmperr);
8072            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8073                 {
8074                 exit(vaxc$errno);
8075                 }
8076             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8077         }
8078         }
8079 #ifdef ARGPROC_DEBUG
8080     PerlIO_printf(Perl_debug_log, "Arglist:\n");
8081     for (j = 0; j < *ac;  ++j)
8082         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8083 #endif
8084    /* Clear errors we may have hit expanding wildcards, so they don't
8085       show up in Perl's $! later */
8086    set_errno(0); set_vaxc_errno(1);
8087 }  /* end of getredirection() */
8088 /*}}}*/
8089
8090 static void add_item(struct list_item **head,
8091                      struct list_item **tail,
8092                      char *value,
8093                      int *count)
8094 {
8095     if (*head == 0)
8096         {
8097         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8098         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8099         *tail = *head;
8100         }
8101     else {
8102         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8103         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8104         *tail = (*tail)->next;
8105         }
8106     (*tail)->value = value;
8107     ++(*count);
8108 }
8109
8110 static void mp_expand_wild_cards(pTHX_ char *item,
8111                               struct list_item **head,
8112                               struct list_item **tail,
8113                               int *count)
8114 {
8115 int expcount = 0;
8116 unsigned long int context = 0;
8117 int isunix = 0;
8118 int item_len = 0;
8119 char *had_version;
8120 char *had_device;
8121 int had_directory;
8122 char *devdir,*cp;
8123 char *vmsspec;
8124 $DESCRIPTOR(filespec, "");
8125 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8126 $DESCRIPTOR(resultspec, "");
8127 unsigned long int lff_flags = 0;
8128 int sts;
8129 int rms_sts;
8130
8131 #ifdef VMS_LONGNAME_SUPPORT
8132     lff_flags = LIB$M_FIL_LONG_NAMES;
8133 #endif
8134
8135     for (cp = item; *cp; cp++) {
8136         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8137         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8138     }
8139     if (!*cp || isspace(*cp))
8140         {
8141         add_item(head, tail, item, count);
8142         return;
8143         }
8144     else
8145         {
8146      /* "double quoted" wild card expressions pass as is */
8147      /* From DCL that means using e.g.:                  */
8148      /* perl program """perl.*"""                        */
8149      item_len = strlen(item);
8150      if ( '"' == *item && '"' == item[item_len-1] )
8151        {
8152        item++;
8153        item[item_len-2] = '\0';
8154        add_item(head, tail, item, count);
8155        return;
8156        }
8157      }
8158     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8159     resultspec.dsc$b_class = DSC$K_CLASS_D;
8160     resultspec.dsc$a_pointer = NULL;
8161     vmsspec = PerlMem_malloc(VMS_MAXRSS);
8162     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8163     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8164       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8165     if (!isunix || !filespec.dsc$a_pointer)
8166       filespec.dsc$a_pointer = item;
8167     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8168     /*
8169      * Only return version specs, if the caller specified a version
8170      */
8171     had_version = strchr(item, ';');
8172     /*
8173      * Only return device and directory specs, if the caller specifed either.
8174      */
8175     had_device = strchr(item, ':');
8176     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8177
8178     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8179                                  (&filespec, &resultspec, &context,
8180                                   &defaultspec, 0, &rms_sts, &lff_flags)))
8181         {
8182         char *string;
8183         char *c;
8184
8185         string = PerlMem_malloc(resultspec.dsc$w_length+1);
8186         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8187         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8188         string[resultspec.dsc$w_length] = '\0';
8189         if (NULL == had_version)
8190             *(strrchr(string, ';')) = '\0';
8191         if ((!had_directory) && (had_device == NULL))
8192             {
8193             if (NULL == (devdir = strrchr(string, ']')))
8194                 devdir = strrchr(string, '>');
8195             strcpy(string, devdir + 1);
8196             }
8197         /*
8198          * Be consistent with what the C RTL has already done to the rest of
8199          * the argv items and lowercase all of these names.
8200          */
8201         if (!decc_efs_case_preserve) {
8202             for (c = string; *c; ++c)
8203             if (isupper(*c))
8204                 *c = tolower(*c);
8205         }
8206         if (isunix) trim_unixpath(string,item,1);
8207         add_item(head, tail, string, count);
8208         ++expcount;
8209     }
8210     PerlMem_free(vmsspec);
8211     if (sts != RMS$_NMF)
8212         {
8213         set_vaxc_errno(sts);
8214         switch (sts)
8215             {
8216             case RMS$_FNF: case RMS$_DNF:
8217                 set_errno(ENOENT); break;
8218             case RMS$_DIR:
8219                 set_errno(ENOTDIR); break;
8220             case RMS$_DEV:
8221                 set_errno(ENODEV); break;
8222             case RMS$_FNM: case RMS$_SYN:
8223                 set_errno(EINVAL); break;
8224             case RMS$_PRV:
8225                 set_errno(EACCES); break;
8226             default:
8227                 _ckvmssts_noperl(sts);
8228             }
8229         }
8230     if (expcount == 0)
8231         add_item(head, tail, item, count);
8232     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8233     _ckvmssts_noperl(lib$find_file_end(&context));
8234 }
8235
8236 static int child_st[2];/* Event Flag set when child process completes   */
8237
8238 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
8239
8240 static unsigned long int exit_handler(int *status)
8241 {
8242 short iosb[4];
8243
8244     if (0 == child_st[0])
8245         {
8246 #ifdef ARGPROC_DEBUG
8247         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8248 #endif
8249         fflush(stdout);     /* Have to flush pipe for binary data to    */
8250                             /* terminate properly -- <tp@mccall.com>    */
8251         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8252         sys$dassgn(child_chan);
8253         fclose(stdout);
8254         sys$synch(0, child_st);
8255         }
8256     return(1);
8257 }
8258
8259 static void sig_child(int chan)
8260 {
8261 #ifdef ARGPROC_DEBUG
8262     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8263 #endif
8264     if (child_st[0] == 0)
8265         child_st[0] = 1;
8266 }
8267
8268 static struct exit_control_block exit_block =
8269     {
8270     0,
8271     exit_handler,
8272     1,
8273     &exit_block.exit_status,
8274     0
8275     };
8276
8277 static void
8278 pipe_and_fork(pTHX_ char **cmargv)
8279 {
8280     PerlIO *fp;
8281     struct dsc$descriptor_s *vmscmd;
8282     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8283     int sts, j, l, ismcr, quote, tquote = 0;
8284
8285     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8286     vms_execfree(vmscmd);
8287
8288     j = l = 0;
8289     p = subcmd;
8290     q = cmargv[0];
8291     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
8292               && toupper(*(q+2)) == 'R' && !*(q+3);
8293
8294     while (q && l < MAX_DCL_LINE_LENGTH) {
8295         if (!*q) {
8296             if (j > 0 && quote) {
8297                 *p++ = '"';
8298                 l++;
8299             }
8300             q = cmargv[++j];
8301             if (q) {
8302                 if (ismcr && j > 1) quote = 1;
8303                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
8304                 *p++ = ' ';
8305                 l++;
8306                 if (quote || tquote) {
8307                     *p++ = '"';
8308                     l++;
8309                 }
8310             }
8311         } else {
8312             if ((quote||tquote) && *q == '"') {
8313                 *p++ = '"';
8314                 l++;
8315             }
8316             *p++ = *q++;
8317             l++;
8318         }
8319     }
8320     *p = '\0';
8321
8322     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8323     if (fp == Nullfp) {
8324         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8325     }
8326 }
8327
8328 static int background_process(pTHX_ int argc, char **argv)
8329 {
8330 char command[MAX_DCL_SYMBOL + 1] = "$";
8331 $DESCRIPTOR(value, "");
8332 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8333 static $DESCRIPTOR(null, "NLA0:");
8334 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8335 char pidstring[80];
8336 $DESCRIPTOR(pidstr, "");
8337 int pid;
8338 unsigned long int flags = 17, one = 1, retsts;
8339 int len;
8340
8341     strcat(command, argv[0]);
8342     len = strlen(command);
8343     while (--argc && (len < MAX_DCL_SYMBOL))
8344         {
8345         strcat(command, " \"");
8346         strcat(command, *(++argv));
8347         strcat(command, "\"");
8348         len = strlen(command);
8349         }
8350     value.dsc$a_pointer = command;
8351     value.dsc$w_length = strlen(value.dsc$a_pointer);
8352     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8353     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8354     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8355         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8356     }
8357     else {
8358         _ckvmssts_noperl(retsts);
8359     }
8360 #ifdef ARGPROC_DEBUG
8361     PerlIO_printf(Perl_debug_log, "%s\n", command);
8362 #endif
8363     sprintf(pidstring, "%08X", pid);
8364     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8365     pidstr.dsc$a_pointer = pidstring;
8366     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8367     lib$set_symbol(&pidsymbol, &pidstr);
8368     return(SS$_NORMAL);
8369 }
8370 /*}}}*/
8371 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8372
8373
8374 /* OS-specific initialization at image activation (not thread startup) */
8375 /* Older VAXC header files lack these constants */
8376 #ifndef JPI$_RIGHTS_SIZE
8377 #  define JPI$_RIGHTS_SIZE 817
8378 #endif
8379 #ifndef KGB$M_SUBSYSTEM
8380 #  define KGB$M_SUBSYSTEM 0x8
8381 #endif
8382
8383 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8384
8385 /*{{{void vms_image_init(int *, char ***)*/
8386 void
8387 vms_image_init(int *argcp, char ***argvp)
8388 {
8389   char eqv[LNM$C_NAMLENGTH+1] = "";
8390   unsigned int len, tabct = 8, tabidx = 0;
8391   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8392   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8393   unsigned short int dummy, rlen;
8394   struct dsc$descriptor_s **tabvec;
8395 #if defined(PERL_IMPLICIT_CONTEXT)
8396   pTHX = NULL;
8397 #endif
8398   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8399                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8400                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8401                                  {          0,                0,    0,      0} };
8402
8403 #ifdef KILL_BY_SIGPRC
8404     Perl_csighandler_init();
8405 #endif
8406
8407   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8408   _ckvmssts_noperl(iosb[0]);
8409   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8410     if (iprv[i]) {           /* Running image installed with privs? */
8411       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8412       will_taint = TRUE;
8413       break;
8414     }
8415   }
8416   /* Rights identifiers might trigger tainting as well. */
8417   if (!will_taint && (rlen || rsz)) {
8418     while (rlen < rsz) {
8419       /* We didn't get all the identifiers on the first pass.  Allocate a
8420        * buffer much larger than $GETJPI wants (rsz is size in bytes that
8421        * were needed to hold all identifiers at time of last call; we'll
8422        * allocate that many unsigned long ints), and go back and get 'em.
8423        * If it gave us less than it wanted to despite ample buffer space,
8424        * something's broken.  Is your system missing a system identifier?
8425        */
8426       if (rsz <= jpilist[1].buflen) {
8427          /* Perl_croak accvios when used this early in startup. */
8428          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8429                          rsz, (unsigned long) jpilist[1].buflen,
8430                          "Check your rights database for corruption.\n");
8431          exit(SS$_ABORT);
8432       }
8433       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8434       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8435       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8436       jpilist[1].buflen = rsz * sizeof(unsigned long int);
8437       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8438       _ckvmssts_noperl(iosb[0]);
8439     }
8440     mask = jpilist[1].bufadr;
8441     /* Check attribute flags for each identifier (2nd longword); protected
8442      * subsystem identifiers trigger tainting.
8443      */
8444     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8445       if (mask[i] & KGB$M_SUBSYSTEM) {
8446         will_taint = TRUE;
8447         break;
8448       }
8449     }
8450     if (mask != rlst) PerlMem_free(mask);
8451   }
8452
8453   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8454    * logical, some versions of the CRTL will add a phanthom /000000/
8455    * directory.  This needs to be removed.
8456    */
8457   if (decc_filename_unix_report) {
8458   char * zeros;
8459   int ulen;
8460     ulen = strlen(argvp[0][0]);
8461     if (ulen > 7) {
8462       zeros = strstr(argvp[0][0], "/000000/");
8463       if (zeros != NULL) {
8464         int mlen;
8465         mlen = ulen - (zeros - argvp[0][0]) - 7;
8466         memmove(zeros, &zeros[7], mlen);
8467         ulen = ulen - 7;
8468         argvp[0][0][ulen] = '\0';
8469       }
8470     }
8471     /* It also may have a trailing dot that needs to be removed otherwise
8472      * it will be converted to VMS mode incorrectly.
8473      */
8474     ulen--;
8475     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8476       argvp[0][0][ulen] = '\0';
8477   }
8478
8479   /* We need to use this hack to tell Perl it should run with tainting,
8480    * since its tainting flag may be part of the PL_curinterp struct, which
8481    * hasn't been allocated when vms_image_init() is called.
8482    */
8483   if (will_taint) {
8484     char **newargv, **oldargv;
8485     oldargv = *argvp;
8486     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8487     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8488     newargv[0] = oldargv[0];
8489     newargv[1] = PerlMem_malloc(3 * sizeof(char));
8490     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8491     strcpy(newargv[1], "-T");
8492     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8493     (*argcp)++;
8494     newargv[*argcp] = NULL;
8495     /* We orphan the old argv, since we don't know where it's come from,
8496      * so we don't know how to free it.
8497      */
8498     *argvp = newargv;
8499   }
8500   else {  /* Did user explicitly request tainting? */
8501     int i;
8502     char *cp, **av = *argvp;
8503     for (i = 1; i < *argcp; i++) {
8504       if (*av[i] != '-') break;
8505       for (cp = av[i]+1; *cp; cp++) {
8506         if (*cp == 'T') { will_taint = 1; break; }
8507         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8508                   strchr("DFIiMmx",*cp)) break;
8509       }
8510       if (will_taint) break;
8511     }
8512   }
8513
8514   for (tabidx = 0;
8515        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8516        tabidx++) {
8517     if (!tabidx) {
8518       tabvec = (struct dsc$descriptor_s **)
8519             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8520       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8521     }
8522     else if (tabidx >= tabct) {
8523       tabct += 8;
8524       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8525       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8526     }
8527     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8528     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8529     tabvec[tabidx]->dsc$w_length  = 0;
8530     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
8531     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
8532     tabvec[tabidx]->dsc$a_pointer = NULL;
8533     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8534   }
8535   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8536
8537   getredirection(argcp,argvp);
8538 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8539   {
8540 # include <reentrancy.h>
8541   decc$set_reentrancy(C$C_MULTITHREAD);
8542   }
8543 #endif
8544   return;
8545 }
8546 /*}}}*/
8547
8548
8549 /* trim_unixpath()
8550  * Trim Unix-style prefix off filespec, so it looks like what a shell
8551  * glob expansion would return (i.e. from specified prefix on, not
8552  * full path).  Note that returned filespec is Unix-style, regardless
8553  * of whether input filespec was VMS-style or Unix-style.
8554  *
8555  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8556  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
8557  * vector of options; at present, only bit 0 is used, and if set tells
8558  * trim unixpath to try the current default directory as a prefix when
8559  * presented with a possibly ambiguous ... wildcard.
8560  *
8561  * Returns !=0 on success, with trimmed filespec replacing contents of
8562  * fspec, and 0 on failure, with contents of fpsec unchanged.
8563  */
8564 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8565 int
8566 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8567 {
8568   char *unixified, *unixwild,
8569        *template, *base, *end, *cp1, *cp2;
8570   register int tmplen, reslen = 0, dirs = 0;
8571
8572   unixwild = PerlMem_malloc(VMS_MAXRSS);
8573   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8574   if (!wildspec || !fspec) return 0;
8575   template = unixwild;
8576   if (strpbrk(wildspec,"]>:") != NULL) {
8577     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8578         PerlMem_free(unixwild);
8579         return 0;
8580     }
8581   }
8582   else {
8583     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8584     unixwild[VMS_MAXRSS-1] = 0;
8585   }
8586   unixified = PerlMem_malloc(VMS_MAXRSS);
8587   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8588   if (strpbrk(fspec,"]>:") != NULL) {
8589     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8590         PerlMem_free(unixwild);
8591         PerlMem_free(unixified);
8592         return 0;
8593     }
8594     else base = unixified;
8595     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8596      * check to see that final result fits into (isn't longer than) fspec */
8597     reslen = strlen(fspec);
8598   }
8599   else base = fspec;
8600
8601   /* No prefix or absolute path on wildcard, so nothing to remove */
8602   if (!*template || *template == '/') {
8603     PerlMem_free(unixwild);
8604     if (base == fspec) {
8605         PerlMem_free(unixified);
8606         return 1;
8607     }
8608     tmplen = strlen(unixified);
8609     if (tmplen > reslen) {
8610         PerlMem_free(unixified);
8611         return 0;  /* not enough space */
8612     }
8613     /* Copy unixified resultant, including trailing NUL */
8614     memmove(fspec,unixified,tmplen+1);
8615     PerlMem_free(unixified);
8616     return 1;
8617   }
8618
8619   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
8620   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8621     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8622     for (cp1 = end ;cp1 >= base; cp1--)
8623       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8624         { cp1++; break; }
8625     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8626     PerlMem_free(unixified);
8627     PerlMem_free(unixwild);
8628     return 1;
8629   }
8630   else {
8631     char *tpl, *lcres;
8632     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8633     int ells = 1, totells, segdirs, match;
8634     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8635                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8636
8637     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8638     totells = ells;
8639     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8640     tpl = PerlMem_malloc(VMS_MAXRSS);
8641     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8642     if (ellipsis == template && opts & 1) {
8643       /* Template begins with an ellipsis.  Since we can't tell how many
8644        * directory names at the front of the resultant to keep for an
8645        * arbitrary starting point, we arbitrarily choose the current
8646        * default directory as a starting point.  If it's there as a prefix,
8647        * clip it off.  If not, fall through and act as if the leading
8648        * ellipsis weren't there (i.e. return shortest possible path that
8649        * could match template).
8650        */
8651       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8652           PerlMem_free(tpl);
8653           PerlMem_free(unixified);
8654           PerlMem_free(unixwild);
8655           return 0;
8656       }
8657       if (!decc_efs_case_preserve) {
8658         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8659           if (_tolower(*cp1) != _tolower(*cp2)) break;
8660       }
8661       segdirs = dirs - totells;  /* Min # of dirs we must have left */
8662       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8663       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8664         memmove(fspec,cp2+1,end - cp2);
8665         PerlMem_free(tpl);
8666         PerlMem_free(unixified);
8667         PerlMem_free(unixwild);
8668         return 1;
8669       }
8670     }
8671     /* First off, back up over constant elements at end of path */
8672     if (dirs) {
8673       for (front = end ; front >= base; front--)
8674          if (*front == '/' && !dirs--) { front++; break; }
8675     }
8676     lcres = PerlMem_malloc(VMS_MAXRSS);
8677     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8678     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8679          cp1++,cp2++) {
8680             if (!decc_efs_case_preserve) {
8681                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
8682             }
8683             else {
8684                 *cp2 = *cp1;
8685             }
8686     }
8687     if (cp1 != '\0') {
8688         PerlMem_free(tpl);
8689         PerlMem_free(unixified);
8690         PerlMem_free(unixwild);
8691         PerlMem_free(lcres);
8692         return 0;  /* Path too long. */
8693     }
8694     lcend = cp2;
8695     *cp2 = '\0';  /* Pick up with memcpy later */
8696     lcfront = lcres + (front - base);
8697     /* Now skip over each ellipsis and try to match the path in front of it. */
8698     while (ells--) {
8699       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8700         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
8701             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
8702       if (cp1 < template) break; /* template started with an ellipsis */
8703       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8704         ellipsis = cp1; continue;
8705       }
8706       wilddsc.dsc$a_pointer = tpl;
8707       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8708       nextell = cp1;
8709       for (segdirs = 0, cp2 = tpl;
8710            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8711            cp1++, cp2++) {
8712          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8713          else {
8714             if (!decc_efs_case_preserve) {
8715               *cp2 = _tolower(*cp1);  /* else lowercase for match */
8716             }
8717             else {
8718               *cp2 = *cp1;  /* else preserve case for match */
8719             }
8720          }
8721          if (*cp2 == '/') segdirs++;
8722       }
8723       if (cp1 != ellipsis - 1) {
8724           PerlMem_free(tpl);
8725           PerlMem_free(unixified);
8726           PerlMem_free(unixwild);
8727           PerlMem_free(lcres);
8728           return 0; /* Path too long */
8729       }
8730       /* Back up at least as many dirs as in template before matching */
8731       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8732         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8733       for (match = 0; cp1 > lcres;) {
8734         resdsc.dsc$a_pointer = cp1;
8735         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8736           match++;
8737           if (match == 1) lcfront = cp1;
8738         }
8739         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8740       }
8741       if (!match) {
8742         PerlMem_free(tpl);
8743         PerlMem_free(unixified);
8744         PerlMem_free(unixwild);
8745         PerlMem_free(lcres);
8746         return 0;  /* Can't find prefix ??? */
8747       }
8748       if (match > 1 && opts & 1) {
8749         /* This ... wildcard could cover more than one set of dirs (i.e.
8750          * a set of similar dir names is repeated).  If the template
8751          * contains more than 1 ..., upstream elements could resolve the
8752          * ambiguity, but it's not worth a full backtracking setup here.
8753          * As a quick heuristic, clip off the current default directory
8754          * if it's present to find the trimmed spec, else use the
8755          * shortest string that this ... could cover.
8756          */
8757         char def[NAM$C_MAXRSS+1], *st;
8758
8759         if (getcwd(def, sizeof def,0) == NULL) {
8760             Safefree(unixified);
8761             Safefree(unixwild);
8762             Safefree(lcres);
8763             Safefree(tpl);
8764             return 0;
8765         }
8766         if (!decc_efs_case_preserve) {
8767           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8768             if (_tolower(*cp1) != _tolower(*cp2)) break;
8769         }
8770         segdirs = dirs - totells;  /* Min # of dirs we must have left */
8771         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8772         if (*cp1 == '\0' && *cp2 == '/') {
8773           memmove(fspec,cp2+1,end - cp2);
8774           PerlMem_free(tpl);
8775           PerlMem_free(unixified);
8776           PerlMem_free(unixwild);
8777           PerlMem_free(lcres);
8778           return 1;
8779         }
8780         /* Nope -- stick with lcfront from above and keep going. */
8781       }
8782     }
8783     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8784     PerlMem_free(tpl);
8785     PerlMem_free(unixified);
8786     PerlMem_free(unixwild);
8787     PerlMem_free(lcres);
8788     return 1;
8789     ellipsis = nextell;
8790   }
8791
8792 }  /* end of trim_unixpath() */
8793 /*}}}*/
8794
8795
8796 /*
8797  *  VMS readdir() routines.
8798  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8799  *
8800  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
8801  *  Minor modifications to original routines.
8802  */
8803
8804 /* readdir may have been redefined by reentr.h, so make sure we get
8805  * the local version for what we do here.
8806  */
8807 #ifdef readdir
8808 # undef readdir
8809 #endif
8810 #if !defined(PERL_IMPLICIT_CONTEXT)
8811 # define readdir Perl_readdir
8812 #else
8813 # define readdir(a) Perl_readdir(aTHX_ a)
8814 #endif
8815
8816     /* Number of elements in vms_versions array */
8817 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
8818
8819 /*
8820  *  Open a directory, return a handle for later use.
8821  */
8822 /*{{{ DIR *opendir(char*name) */
8823 DIR *
8824 Perl_opendir(pTHX_ const char *name)
8825 {
8826     DIR *dd;
8827     char *dir;
8828     Stat_t sb;
8829
8830     Newx(dir, VMS_MAXRSS, char);
8831     if (do_tovmspath(name,dir,0,NULL) == NULL) {
8832       Safefree(dir);
8833       return NULL;
8834     }
8835     /* Check access before stat; otherwise stat does not
8836      * accurately report whether it's a directory.
8837      */
8838     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8839       /* cando_by_name has already set errno */
8840       Safefree(dir);
8841       return NULL;
8842     }
8843     if (flex_stat(dir,&sb) == -1) return NULL;
8844     if (!S_ISDIR(sb.st_mode)) {
8845       Safefree(dir);
8846       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
8847       return NULL;
8848     }
8849     /* Get memory for the handle, and the pattern. */
8850     Newx(dd,1,DIR);
8851     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8852
8853     /* Fill in the fields; mainly playing with the descriptor. */
8854     sprintf(dd->pattern, "%s*.*",dir);
8855     Safefree(dir);
8856     dd->context = 0;
8857     dd->count = 0;
8858     dd->flags = 0;
8859     /* By saying we always want the result of readdir() in unix format, we
8860      * are really saying we want all the escapes removed.  Otherwise the caller,
8861      * having no way to know whether it's already in VMS format, might send it
8862      * through tovmsspec again, thus double escaping.
8863      */
8864     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8865     dd->pat.dsc$a_pointer = dd->pattern;
8866     dd->pat.dsc$w_length = strlen(dd->pattern);
8867     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8868     dd->pat.dsc$b_class = DSC$K_CLASS_S;
8869 #if defined(USE_ITHREADS)
8870     Newx(dd->mutex,1,perl_mutex);
8871     MUTEX_INIT( (perl_mutex *) dd->mutex );
8872 #else
8873     dd->mutex = NULL;
8874 #endif
8875
8876     return dd;
8877 }  /* end of opendir() */
8878 /*}}}*/
8879
8880 /*
8881  *  Set the flag to indicate we want versions or not.
8882  */
8883 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8884 void
8885 vmsreaddirversions(DIR *dd, int flag)
8886 {
8887     if (flag)
8888         dd->flags |= PERL_VMSDIR_M_VERSIONS;
8889     else
8890         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8891 }
8892 /*}}}*/
8893
8894 /*
8895  *  Free up an opened directory.
8896  */
8897 /*{{{ void closedir(DIR *dd)*/
8898 void
8899 Perl_closedir(DIR *dd)
8900 {
8901     int sts;
8902
8903     sts = lib$find_file_end(&dd->context);
8904     Safefree(dd->pattern);
8905 #if defined(USE_ITHREADS)
8906     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8907     Safefree(dd->mutex);
8908 #endif
8909     Safefree(dd);
8910 }
8911 /*}}}*/
8912
8913 /*
8914  *  Collect all the version numbers for the current file.
8915  */
8916 static void
8917 collectversions(pTHX_ DIR *dd)
8918 {
8919     struct dsc$descriptor_s     pat;
8920     struct dsc$descriptor_s     res;
8921     struct dirent *e;
8922     char *p, *text, *buff;
8923     int i;
8924     unsigned long context, tmpsts;
8925
8926     /* Convenient shorthand. */
8927     e = &dd->entry;
8928
8929     /* Add the version wildcard, ignoring the "*.*" put on before */
8930     i = strlen(dd->pattern);
8931     Newx(text,i + e->d_namlen + 3,char);
8932     strcpy(text, dd->pattern);
8933     sprintf(&text[i - 3], "%s;*", e->d_name);
8934
8935     /* Set up the pattern descriptor. */
8936     pat.dsc$a_pointer = text;
8937     pat.dsc$w_length = i + e->d_namlen - 1;
8938     pat.dsc$b_dtype = DSC$K_DTYPE_T;
8939     pat.dsc$b_class = DSC$K_CLASS_S;
8940
8941     /* Set up result descriptor. */
8942     Newx(buff, VMS_MAXRSS, char);
8943     res.dsc$a_pointer = buff;
8944     res.dsc$w_length = VMS_MAXRSS - 1;
8945     res.dsc$b_dtype = DSC$K_DTYPE_T;
8946     res.dsc$b_class = DSC$K_CLASS_S;
8947
8948     /* Read files, collecting versions. */
8949     for (context = 0, e->vms_verscount = 0;
8950          e->vms_verscount < VERSIZE(e);
8951          e->vms_verscount++) {
8952         unsigned long rsts;
8953         unsigned long flags = 0;
8954
8955 #ifdef VMS_LONGNAME_SUPPORT
8956         flags = LIB$M_FIL_LONG_NAMES;
8957 #endif
8958         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8959         if (tmpsts == RMS$_NMF || context == 0) break;
8960         _ckvmssts(tmpsts);
8961         buff[VMS_MAXRSS - 1] = '\0';
8962         if ((p = strchr(buff, ';')))
8963             e->vms_versions[e->vms_verscount] = atoi(p + 1);
8964         else
8965             e->vms_versions[e->vms_verscount] = -1;
8966     }
8967
8968     _ckvmssts(lib$find_file_end(&context));
8969     Safefree(text);
8970     Safefree(buff);
8971
8972 }  /* end of collectversions() */
8973
8974 /*
8975  *  Read the next entry from the directory.
8976  */
8977 /*{{{ struct dirent *readdir(DIR *dd)*/
8978 struct dirent *
8979 Perl_readdir(pTHX_ DIR *dd)
8980 {
8981     struct dsc$descriptor_s     res;
8982     char *p, *buff;
8983     unsigned long int tmpsts;
8984     unsigned long rsts;
8985     unsigned long flags = 0;
8986     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8987     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8988
8989     /* Set up result descriptor, and get next file. */
8990     Newx(buff, VMS_MAXRSS, char);
8991     res.dsc$a_pointer = buff;
8992     res.dsc$w_length = VMS_MAXRSS - 1;
8993     res.dsc$b_dtype = DSC$K_DTYPE_T;
8994     res.dsc$b_class = DSC$K_CLASS_S;
8995
8996 #ifdef VMS_LONGNAME_SUPPORT
8997     flags = LIB$M_FIL_LONG_NAMES;
8998 #endif
8999
9000     tmpsts = lib$find_file
9001         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
9002     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
9003     if (!(tmpsts & 1)) {
9004       set_vaxc_errno(tmpsts);
9005       switch (tmpsts) {
9006         case RMS$_PRV:
9007           set_errno(EACCES); break;
9008         case RMS$_DEV:
9009           set_errno(ENODEV); break;
9010         case RMS$_DIR:
9011           set_errno(ENOTDIR); break;
9012         case RMS$_FNF: case RMS$_DNF:
9013           set_errno(ENOENT); break;
9014         default:
9015           set_errno(EVMSERR);
9016       }
9017       Safefree(buff);
9018       return NULL;
9019     }
9020     dd->count++;
9021     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
9022     if (!decc_efs_case_preserve) {
9023       buff[VMS_MAXRSS - 1] = '\0';
9024       for (p = buff; *p; p++) *p = _tolower(*p);
9025     }
9026     else {
9027       /* we don't want to force to lowercase, just null terminate */
9028       buff[res.dsc$w_length] = '\0';
9029     }
9030     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
9031     *p = '\0';
9032
9033     /* Skip any directory component and just copy the name. */
9034     sts = vms_split_path
9035        (buff,
9036         &v_spec,
9037         &v_len,
9038         &r_spec,
9039         &r_len,
9040         &d_spec,
9041         &d_len,
9042         &n_spec,
9043         &n_len,
9044         &e_spec,
9045         &e_len,
9046         &vs_spec,
9047         &vs_len);
9048
9049     /* Drop NULL extensions on UNIX file specification */
9050     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
9051         (e_len == 1) && decc_readdir_dropdotnotype)) {
9052         e_len = 0;
9053         e_spec[0] = '\0';
9054     }
9055
9056     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9057     dd->entry.d_name[n_len + e_len] = '\0';
9058     dd->entry.d_namlen = strlen(dd->entry.d_name);
9059
9060     /* Convert the filename to UNIX format if needed */
9061     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9062
9063         /* Translate the encoded characters. */
9064         /* Fixme: Unicode handling could result in embedded 0 characters */
9065         if (strchr(dd->entry.d_name, '^') != NULL) {
9066             char new_name[256];
9067             char * q;
9068             p = dd->entry.d_name;
9069             q = new_name;
9070             while (*p != 0) {
9071                 int inchars_read, outchars_added;
9072                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9073                 p += inchars_read;
9074                 q += outchars_added;
9075                 /* fix-me */
9076                 /* if outchars_added > 1, then this is a wide file specification */
9077                 /* Wide file specifications need to be passed in Perl */
9078                 /* counted strings apparently with a Unicode flag */
9079             }
9080             *q = 0;
9081             strcpy(dd->entry.d_name, new_name);
9082             dd->entry.d_namlen = strlen(dd->entry.d_name);
9083         }
9084     }
9085
9086     dd->entry.vms_verscount = 0;
9087     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9088     Safefree(buff);
9089     return &dd->entry;
9090
9091 }  /* end of readdir() */
9092 /*}}}*/
9093
9094 /*
9095  *  Read the next entry from the directory -- thread-safe version.
9096  */
9097 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9098 int
9099 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9100 {
9101     int retval;
9102
9103     MUTEX_LOCK( (perl_mutex *) dd->mutex );
9104
9105     entry = readdir(dd);
9106     *result = entry;
9107     retval = ( *result == NULL ? errno : 0 );
9108
9109     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9110
9111     return retval;
9112
9113 }  /* end of readdir_r() */
9114 /*}}}*/
9115
9116 /*
9117  *  Return something that can be used in a seekdir later.
9118  */
9119 /*{{{ long telldir(DIR *dd)*/
9120 long
9121 Perl_telldir(DIR *dd)
9122 {
9123     return dd->count;
9124 }
9125 /*}}}*/
9126
9127 /*
9128  *  Return to a spot where we used to be.  Brute force.
9129  */
9130 /*{{{ void seekdir(DIR *dd,long count)*/
9131 void
9132 Perl_seekdir(pTHX_ DIR *dd, long count)
9133 {
9134     int old_flags;
9135
9136     /* If we haven't done anything yet... */
9137     if (dd->count == 0)
9138         return;
9139
9140     /* Remember some state, and clear it. */
9141     old_flags = dd->flags;
9142     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9143     _ckvmssts(lib$find_file_end(&dd->context));
9144     dd->context = 0;
9145
9146     /* The increment is in readdir(). */
9147     for (dd->count = 0; dd->count < count; )
9148         readdir(dd);
9149
9150     dd->flags = old_flags;
9151
9152 }  /* end of seekdir() */
9153 /*}}}*/
9154
9155 /* VMS subprocess management
9156  *
9157  * my_vfork() - just a vfork(), after setting a flag to record that
9158  * the current script is trying a Unix-style fork/exec.
9159  *
9160  * vms_do_aexec() and vms_do_exec() are called in response to the
9161  * perl 'exec' function.  If this follows a vfork call, then they
9162  * call out the regular perl routines in doio.c which do an
9163  * execvp (for those who really want to try this under VMS).
9164  * Otherwise, they do exactly what the perl docs say exec should
9165  * do - terminate the current script and invoke a new command
9166  * (See below for notes on command syntax.)
9167  *
9168  * do_aspawn() and do_spawn() implement the VMS side of the perl
9169  * 'system' function.
9170  *
9171  * Note on command arguments to perl 'exec' and 'system': When handled
9172  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9173  * are concatenated to form a DCL command string.  If the first arg
9174  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
9175  * the command string is handed off to DCL directly.  Otherwise,
9176  * the first token of the command is taken as the filespec of an image
9177  * to run.  The filespec is expanded using a default type of '.EXE' and
9178  * the process defaults for device, directory, etc., and if found, the resultant
9179  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9180  * the command string as parameters.  This is perhaps a bit complicated,
9181  * but I hope it will form a happy medium between what VMS folks expect
9182  * from lib$spawn and what Unix folks expect from exec.
9183  */
9184
9185 static int vfork_called;
9186
9187 /*{{{int my_vfork()*/
9188 int
9189 my_vfork()
9190 {
9191   vfork_called++;
9192   return vfork();
9193 }
9194 /*}}}*/
9195
9196
9197 static void
9198 vms_execfree(struct dsc$descriptor_s *vmscmd)
9199 {
9200   if (vmscmd) {
9201       if (vmscmd->dsc$a_pointer) {
9202           PerlMem_free(vmscmd->dsc$a_pointer);
9203       }
9204       PerlMem_free(vmscmd);
9205   }
9206 }
9207
9208 static char *
9209 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9210 {
9211   char *junk, *tmps = Nullch;
9212   register size_t cmdlen = 0;
9213   size_t rlen;
9214   register SV **idx;
9215   STRLEN n_a;
9216
9217   idx = mark;
9218   if (really) {
9219     tmps = SvPV(really,rlen);
9220     if (*tmps) {
9221       cmdlen += rlen + 1;
9222       idx++;
9223     }
9224   }
9225
9226   for (idx++; idx <= sp; idx++) {
9227     if (*idx) {
9228       junk = SvPVx(*idx,rlen);
9229       cmdlen += rlen ? rlen + 1 : 0;
9230     }
9231   }
9232   Newx(PL_Cmd, cmdlen+1, char);
9233
9234   if (tmps && *tmps) {
9235     strcpy(PL_Cmd,tmps);
9236     mark++;
9237   }
9238   else *PL_Cmd = '\0';
9239   while (++mark <= sp) {
9240     if (*mark) {
9241       char *s = SvPVx(*mark,n_a);
9242       if (!*s) continue;
9243       if (*PL_Cmd) strcat(PL_Cmd," ");
9244       strcat(PL_Cmd,s);
9245     }
9246   }
9247   return PL_Cmd;
9248
9249 }  /* end of setup_argstr() */
9250
9251
9252 static unsigned long int
9253 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9254                    struct dsc$descriptor_s **pvmscmd)
9255 {
9256   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9257   char image_name[NAM$C_MAXRSS+1];
9258   char image_argv[NAM$C_MAXRSS+1];
9259   $DESCRIPTOR(defdsc,".EXE");
9260   $DESCRIPTOR(defdsc2,".");
9261   $DESCRIPTOR(resdsc,resspec);
9262   struct dsc$descriptor_s *vmscmd;
9263   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9264   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9265   register char *s, *rest, *cp, *wordbreak;
9266   char * cmd;
9267   int cmdlen;
9268   register int isdcl;
9269
9270   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9271   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9272
9273   /* Make a copy for modification */
9274   cmdlen = strlen(incmd);
9275   cmd = PerlMem_malloc(cmdlen+1);
9276   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9277   strncpy(cmd, incmd, cmdlen);
9278   cmd[cmdlen] = 0;
9279   image_name[0] = 0;
9280   image_argv[0] = 0;
9281
9282   vmscmd->dsc$a_pointer = NULL;
9283   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
9284   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
9285   vmscmd->dsc$w_length = 0;
9286   if (pvmscmd) *pvmscmd = vmscmd;
9287
9288   if (suggest_quote) *suggest_quote = 0;
9289
9290   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9291     PerlMem_free(cmd);
9292     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
9293   }
9294
9295   s = cmd;
9296
9297   while (*s && isspace(*s)) s++;
9298
9299   if (*s == '@' || *s == '$') {
9300     vmsspec[0] = *s;  rest = s + 1;
9301     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9302   }
9303   else { cp = vmsspec; rest = s; }
9304   if (*rest == '.' || *rest == '/') {
9305     char *cp2;
9306     for (cp2 = resspec;
9307          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9308          rest++, cp2++) *cp2 = *rest;
9309     *cp2 = '\0';
9310     if (do_tovmsspec(resspec,cp,0,NULL)) {
9311       s = vmsspec;
9312       if (*rest) {
9313         for (cp2 = vmsspec + strlen(vmsspec);
9314              *rest && cp2 - vmsspec < sizeof vmsspec;
9315              rest++, cp2++) *cp2 = *rest;
9316         *cp2 = '\0';
9317       }
9318     }
9319   }
9320   /* Intuit whether verb (first word of cmd) is a DCL command:
9321    *   - if first nonspace char is '@', it's a DCL indirection
9322    * otherwise
9323    *   - if verb contains a filespec separator, it's not a DCL command
9324    *   - if it doesn't, caller tells us whether to default to a DCL
9325    *     command, or to a local image unless told it's DCL (by leading '$')
9326    */
9327   if (*s == '@') {
9328       isdcl = 1;
9329       if (suggest_quote) *suggest_quote = 1;
9330   } else {
9331     register char *filespec = strpbrk(s,":<[.;");
9332     rest = wordbreak = strpbrk(s," \"\t/");
9333     if (!wordbreak) wordbreak = s + strlen(s);
9334     if (*s == '$') check_img = 0;
9335     if (filespec && (filespec < wordbreak)) isdcl = 0;
9336     else isdcl = !check_img;
9337   }
9338
9339   if (!isdcl) {
9340     int rsts;
9341     imgdsc.dsc$a_pointer = s;
9342     imgdsc.dsc$w_length = wordbreak - s;
9343     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9344     if (!(retsts&1)) {
9345         _ckvmssts(lib$find_file_end(&cxt));
9346         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9347       if (!(retsts & 1) && *s == '$') {
9348         _ckvmssts(lib$find_file_end(&cxt));
9349         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9350         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9351         if (!(retsts&1)) {
9352           _ckvmssts(lib$find_file_end(&cxt));
9353           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9354         }
9355       }
9356     }
9357     _ckvmssts(lib$find_file_end(&cxt));
9358
9359     if (retsts & 1) {
9360       FILE *fp;
9361       s = resspec;
9362       while (*s && !isspace(*s)) s++;
9363       *s = '\0';
9364
9365       /* check that it's really not DCL with no file extension */
9366       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9367       if (fp) {
9368         char b[256] = {0,0,0,0};
9369         read(fileno(fp), b, 256);
9370         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9371         if (isdcl) {
9372           int shebang_len;
9373
9374           /* Check for script */
9375           shebang_len = 0;
9376           if ((b[0] == '#') && (b[1] == '!'))
9377              shebang_len = 2;
9378 #ifdef ALTERNATE_SHEBANG
9379           else {
9380             shebang_len = strlen(ALTERNATE_SHEBANG);
9381             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9382               char * perlstr;
9383                 perlstr = strstr("perl",b);
9384                 if (perlstr == NULL)
9385                   shebang_len = 0;
9386             }
9387             else
9388               shebang_len = 0;
9389           }
9390 #endif
9391
9392           if (shebang_len > 0) {
9393           int i;
9394           int j;
9395           char tmpspec[NAM$C_MAXRSS + 1];
9396
9397             i = shebang_len;
9398              /* Image is following after white space */
9399             /*--------------------------------------*/
9400             while (isprint(b[i]) && isspace(b[i]))
9401                 i++;
9402
9403             j = 0;
9404             while (isprint(b[i]) && !isspace(b[i])) {
9405                 tmpspec[j++] = b[i++];
9406                 if (j >= NAM$C_MAXRSS)
9407                    break;
9408             }
9409             tmpspec[j] = '\0';
9410
9411              /* There may be some default parameters to the image */
9412             /*---------------------------------------------------*/
9413             j = 0;
9414             while (isprint(b[i])) {
9415                 image_argv[j++] = b[i++];
9416                 if (j >= NAM$C_MAXRSS)
9417                    break;
9418             }
9419             while ((j > 0) && !isprint(image_argv[j-1]))
9420                 j--;
9421             image_argv[j] = 0;
9422
9423             /* It will need to be converted to VMS format and validated */
9424             if (tmpspec[0] != '\0') {
9425               char * iname;
9426
9427                /* Try to find the exact program requested to be run */
9428               /*---------------------------------------------------*/
9429               iname = do_rmsexpand
9430                  (tmpspec, image_name, 0, ".exe",
9431                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
9432               if (iname != NULL) {
9433                 if (cando_by_name_int
9434                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9435                   /* MCR prefix needed */
9436                   isdcl = 0;
9437                 }
9438                 else {
9439                    /* Try again with a null type */
9440                   /*----------------------------*/
9441                   iname = do_rmsexpand
9442                     (tmpspec, image_name, 0, ".",
9443                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
9444                   if (iname != NULL) {
9445                     if (cando_by_name_int
9446                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9447                       /* MCR prefix needed */
9448                       isdcl = 0;
9449                     }
9450                   }
9451                 }
9452
9453                  /* Did we find the image to run the script? */
9454                 /*------------------------------------------*/
9455                 if (isdcl) {
9456                   char *tchr;
9457
9458                    /* Assume DCL or foreign command exists */
9459                   /*--------------------------------------*/
9460                   tchr = strrchr(tmpspec, '/');
9461                   if (tchr != NULL) {
9462                     tchr++;
9463                   }
9464                   else {
9465                     tchr = tmpspec;
9466                   }
9467                   strcpy(image_name, tchr);
9468                 }
9469               }
9470             }
9471           }
9472         }
9473         fclose(fp);
9474       }
9475       if (check_img && isdcl) return RMS$_FNF;
9476
9477       if (cando_by_name(S_IXUSR,0,resspec)) {
9478         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9479         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9480         if (!isdcl) {
9481             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9482             if (image_name[0] != 0) {
9483                 strcat(vmscmd->dsc$a_pointer, image_name);
9484                 strcat(vmscmd->dsc$a_pointer, " ");
9485             }
9486         } else if (image_name[0] != 0) {
9487             strcpy(vmscmd->dsc$a_pointer, image_name);
9488             strcat(vmscmd->dsc$a_pointer, " ");
9489         } else {
9490             strcpy(vmscmd->dsc$a_pointer,"@");
9491         }
9492         if (suggest_quote) *suggest_quote = 1;
9493
9494         /* If there is an image name, use original command */
9495         if (image_name[0] == 0)
9496             strcat(vmscmd->dsc$a_pointer,resspec);
9497         else {
9498             rest = cmd;
9499             while (*rest && isspace(*rest)) rest++;
9500         }
9501
9502         if (image_argv[0] != 0) {
9503           strcat(vmscmd->dsc$a_pointer,image_argv);
9504           strcat(vmscmd->dsc$a_pointer, " ");
9505         }
9506         if (rest) {
9507            int rest_len;
9508            int vmscmd_len;
9509
9510            rest_len = strlen(rest);
9511            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9512            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9513               strcat(vmscmd->dsc$a_pointer,rest);
9514            else
9515              retsts = CLI$_BUFOVF;
9516         }
9517         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9518         PerlMem_free(cmd);
9519         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9520       }
9521       else
9522         retsts = RMS$_PRV;
9523     }
9524   }
9525   /* It's either a DCL command or we couldn't find a suitable image */
9526   vmscmd->dsc$w_length = strlen(cmd);
9527
9528   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9529   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9530   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9531
9532   PerlMem_free(cmd);
9533
9534   /* check if it's a symbol (for quoting purposes) */
9535   if (suggest_quote && !*suggest_quote) {
9536     int iss;
9537     char equiv[LNM$C_NAMLENGTH];
9538     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9539     eqvdsc.dsc$a_pointer = equiv;
9540
9541     iss = lib$get_symbol(vmscmd,&eqvdsc);
9542     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9543   }
9544   if (!(retsts & 1)) {
9545     /* just hand off status values likely to be due to user error */
9546     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9547         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9548        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9549     else { _ckvmssts(retsts); }
9550   }
9551
9552   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9553
9554 }  /* end of setup_cmddsc() */
9555
9556
9557 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9558 bool
9559 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9560 {
9561 bool exec_sts;
9562 char * cmd;
9563
9564   if (sp > mark) {
9565     if (vfork_called) {           /* this follows a vfork - act Unixish */
9566       vfork_called--;
9567       if (vfork_called < 0) {
9568         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9569         vfork_called = 0;
9570       }
9571       else return do_aexec(really,mark,sp);
9572     }
9573                                            /* no vfork - act VMSish */
9574     cmd = setup_argstr(aTHX_ really,mark,sp);
9575     exec_sts = vms_do_exec(cmd);
9576     Safefree(cmd);  /* Clean up from setup_argstr() */
9577     return exec_sts;
9578   }
9579
9580   return FALSE;
9581 }  /* end of vms_do_aexec() */
9582 /*}}}*/
9583
9584 /* {{{bool vms_do_exec(char *cmd) */
9585 bool
9586 Perl_vms_do_exec(pTHX_ const char *cmd)
9587 {
9588   struct dsc$descriptor_s *vmscmd;
9589
9590   if (vfork_called) {             /* this follows a vfork - act Unixish */
9591     vfork_called--;
9592     if (vfork_called < 0) {
9593       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9594       vfork_called = 0;
9595     }
9596     else return do_exec(cmd);
9597   }
9598
9599   {                               /* no vfork - act VMSish */
9600     unsigned long int retsts;
9601
9602     TAINT_ENV();
9603     TAINT_PROPER("exec");
9604     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9605       retsts = lib$do_command(vmscmd);
9606
9607     switch (retsts) {
9608       case RMS$_FNF: case RMS$_DNF:
9609         set_errno(ENOENT); break;
9610       case RMS$_DIR:
9611         set_errno(ENOTDIR); break;
9612       case RMS$_DEV:
9613         set_errno(ENODEV); break;
9614       case RMS$_PRV:
9615         set_errno(EACCES); break;
9616       case RMS$_SYN:
9617         set_errno(EINVAL); break;
9618       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9619         set_errno(E2BIG); break;
9620       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9621         _ckvmssts(retsts); /* fall through */
9622       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9623         set_errno(EVMSERR);
9624     }
9625     set_vaxc_errno(retsts);
9626     if (ckWARN(WARN_EXEC)) {
9627       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9628              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9629     }
9630     vms_execfree(vmscmd);
9631   }
9632
9633   return FALSE;
9634
9635 }  /* end of vms_do_exec() */
9636 /*}}}*/
9637
9638 unsigned long int Perl_do_spawn(pTHX_ const char *);
9639
9640 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9641 unsigned long int
9642 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9643 {
9644 unsigned long int sts;
9645 char * cmd;
9646
9647   if (sp > mark) {
9648     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9649     sts = do_spawn(cmd);
9650     /* pp_sys will clean up cmd */
9651     return sts;
9652   }
9653   return SS$_ABORT;
9654 }  /* end of do_aspawn() */
9655 /*}}}*/
9656
9657 /* {{{unsigned long int do_spawn(char *cmd) */
9658 unsigned long int
9659 Perl_do_spawn(pTHX_ const char *cmd)
9660 {
9661   unsigned long int sts, substs;
9662
9663   /* The caller of this routine expects to Safefree(PL_Cmd) */
9664   Newx(PL_Cmd,10,char);
9665
9666   TAINT_ENV();
9667   TAINT_PROPER("spawn");
9668   if (!cmd || !*cmd) {
9669     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9670     if (!(sts & 1)) {
9671       switch (sts) {
9672         case RMS$_FNF:  case RMS$_DNF:
9673           set_errno(ENOENT); break;
9674         case RMS$_DIR:
9675           set_errno(ENOTDIR); break;
9676         case RMS$_DEV:
9677           set_errno(ENODEV); break;
9678         case RMS$_PRV:
9679           set_errno(EACCES); break;
9680         case RMS$_SYN:
9681           set_errno(EINVAL); break;
9682         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9683           set_errno(E2BIG); break;
9684         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9685           _ckvmssts(sts); /* fall through */
9686         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9687           set_errno(EVMSERR);
9688       }
9689       set_vaxc_errno(sts);
9690       if (ckWARN(WARN_EXEC)) {
9691         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9692                     Strerror(errno));
9693       }
9694     }
9695     sts = substs;
9696   }
9697   else {
9698     PerlIO * fp;
9699     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9700     if (fp != NULL)
9701       my_pclose(fp);
9702   }
9703   return sts;
9704 }  /* end of do_spawn() */
9705 /*}}}*/
9706
9707
9708 static unsigned int *sockflags, sockflagsize;
9709
9710 /*
9711  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9712  * routines found in some versions of the CRTL can't deal with sockets.
9713  * We don't shim the other file open routines since a socket isn't
9714  * likely to be opened by a name.
9715  */
9716 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9717 FILE *my_fdopen(int fd, const char *mode)
9718 {
9719   FILE *fp = fdopen(fd, mode);
9720
9721   if (fp) {
9722     unsigned int fdoff = fd / sizeof(unsigned int);
9723     Stat_t sbuf; /* native stat; we don't need flex_stat */
9724     if (!sockflagsize || fdoff > sockflagsize) {
9725       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
9726       else           Newx  (sockflags,fdoff+2,unsigned int);
9727       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9728       sockflagsize = fdoff + 2;
9729     }
9730     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9731       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9732   }
9733   return fp;
9734
9735 }
9736 /*}}}*/
9737
9738
9739 /*
9740  * Clear the corresponding bit when the (possibly) socket stream is closed.
9741  * There still a small hole: we miss an implicit close which might occur
9742  * via freopen().  >> Todo
9743  */
9744 /*{{{ int my_fclose(FILE *fp)*/
9745 int my_fclose(FILE *fp) {
9746   if (fp) {
9747     unsigned int fd = fileno(fp);
9748     unsigned int fdoff = fd / sizeof(unsigned int);
9749
9750     if (sockflagsize && fdoff <= sockflagsize)
9751       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9752   }
9753   return fclose(fp);
9754 }
9755 /*}}}*/
9756
9757
9758 /*
9759  * A simple fwrite replacement which outputs itmsz*nitm chars without
9760  * introducing record boundaries every itmsz chars.
9761  * We are using fputs, which depends on a terminating null.  We may
9762  * well be writing binary data, so we need to accommodate not only
9763  * data with nulls sprinkled in the middle but also data with no null
9764  * byte at the end.
9765  */
9766 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9767 int
9768 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9769 {
9770   register char *cp, *end, *cpd, *data;
9771   register unsigned int fd = fileno(dest);
9772   register unsigned int fdoff = fd / sizeof(unsigned int);
9773   int retval;
9774   int bufsize = itmsz * nitm + 1;
9775
9776   if (fdoff < sockflagsize &&
9777       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9778     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9779     return nitm;
9780   }
9781
9782   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9783   memcpy( data, src, itmsz*nitm );
9784   data[itmsz*nitm] = '\0';
9785
9786   end = data + itmsz * nitm;
9787   retval = (int) nitm; /* on success return # items written */
9788
9789   cpd = data;
9790   while (cpd <= end) {
9791     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9792     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9793     if (cp < end)
9794       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9795     cpd = cp + 1;
9796   }
9797
9798   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9799   return retval;
9800
9801 }  /* end of my_fwrite() */
9802 /*}}}*/
9803
9804 /*{{{ int my_flush(FILE *fp)*/
9805 int
9806 Perl_my_flush(pTHX_ FILE *fp)
9807 {
9808     int res;
9809     if ((res = fflush(fp)) == 0 && fp) {
9810 #ifdef VMS_DO_SOCKETS
9811         Stat_t s;
9812         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9813 #endif
9814             res = fsync(fileno(fp));
9815     }
9816 /*
9817  * If the flush succeeded but set end-of-file, we need to clear
9818  * the error because our caller may check ferror().  BTW, this
9819  * probably means we just flushed an empty file.
9820  */
9821     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9822
9823     return res;
9824 }
9825 /*}}}*/
9826
9827 /*
9828  * Here are replacements for the following Unix routines in the VMS environment:
9829  *      getpwuid    Get information for a particular UIC or UID
9830  *      getpwnam    Get information for a named user
9831  *      getpwent    Get information for each user in the rights database
9832  *      setpwent    Reset search to the start of the rights database
9833  *      endpwent    Finish searching for users in the rights database
9834  *
9835  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9836  * (defined in pwd.h), which contains the following fields:-
9837  *      struct passwd {
9838  *              char        *pw_name;    Username (in lower case)
9839  *              char        *pw_passwd;  Hashed password
9840  *              unsigned int pw_uid;     UIC
9841  *              unsigned int pw_gid;     UIC group  number
9842  *              char        *pw_unixdir; Default device/directory (VMS-style)
9843  *              char        *pw_gecos;   Owner name
9844  *              char        *pw_dir;     Default device/directory (Unix-style)
9845  *              char        *pw_shell;   Default CLI name (eg. DCL)
9846  *      };
9847  * If the specified user does not exist, getpwuid and getpwnam return NULL.
9848  *
9849  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9850  * not the UIC member number (eg. what's returned by getuid()),
9851  * getpwuid() can accept either as input (if uid is specified, the caller's
9852  * UIC group is used), though it won't recognise gid=0.
9853  *
9854  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9855  * information about other users in your group or in other groups, respectively.
9856  * If the required privilege is not available, then these routines fill only
9857  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9858  * string).
9859  *
9860  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9861  */
9862
9863 /* sizes of various UAF record fields */
9864 #define UAI$S_USERNAME 12
9865 #define UAI$S_IDENT    31
9866 #define UAI$S_OWNER    31
9867 #define UAI$S_DEFDEV   31
9868 #define UAI$S_DEFDIR   63
9869 #define UAI$S_DEFCLI   31
9870 #define UAI$S_PWD       8
9871
9872 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
9873                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9874                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
9875
9876 static char __empty[]= "";
9877 static struct passwd __passwd_empty=
9878     {(char *) __empty, (char *) __empty, 0, 0,
9879      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9880 static int contxt= 0;
9881 static struct passwd __pwdcache;
9882 static char __pw_namecache[UAI$S_IDENT+1];
9883
9884 /*
9885  * This routine does most of the work extracting the user information.
9886  */
9887 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9888 {
9889     static struct {
9890         unsigned char length;
9891         char pw_gecos[UAI$S_OWNER+1];
9892     } owner;
9893     static union uicdef uic;
9894     static struct {
9895         unsigned char length;
9896         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9897     } defdev;
9898     static struct {
9899         unsigned char length;
9900         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9901     } defdir;
9902     static struct {
9903         unsigned char length;
9904         char pw_shell[UAI$S_DEFCLI+1];
9905     } defcli;
9906     static char pw_passwd[UAI$S_PWD+1];
9907
9908     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9909     struct dsc$descriptor_s name_desc;
9910     unsigned long int sts;
9911
9912     static struct itmlst_3 itmlst[]= {
9913         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
9914         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
9915         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
9916         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
9917         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
9918         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
9919         {0,                0,           NULL,    NULL}};
9920
9921     name_desc.dsc$w_length=  strlen(name);
9922     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9923     name_desc.dsc$b_class=   DSC$K_CLASS_S;
9924     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9925
9926 /*  Note that sys$getuai returns many fields as counted strings. */
9927     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9928     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9929       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9930     }
9931     else { _ckvmssts(sts); }
9932     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
9933
9934     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
9935     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9936     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9937     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9938     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9939     owner.pw_gecos[lowner]=            '\0';
9940     defdev.pw_dir[ldefdev+ldefdir]= '\0';
9941     defcli.pw_shell[ldefcli]=          '\0';
9942     if (valid_uic(uic)) {
9943         pwd->pw_uid= uic.uic$l_uic;
9944         pwd->pw_gid= uic.uic$v_group;
9945     }
9946     else
9947       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9948     pwd->pw_passwd=  pw_passwd;
9949     pwd->pw_gecos=   owner.pw_gecos;
9950     pwd->pw_dir=     defdev.pw_dir;
9951     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9952     pwd->pw_shell=   defcli.pw_shell;
9953     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9954         int ldir;
9955         ldir= strlen(pwd->pw_unixdir) - 1;
9956         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9957     }
9958     else
9959         strcpy(pwd->pw_unixdir, pwd->pw_dir);
9960     if (!decc_efs_case_preserve)
9961         __mystrtolower(pwd->pw_unixdir);
9962     return 1;
9963 }
9964
9965 /*
9966  * Get information for a named user.
9967 */
9968 /*{{{struct passwd *getpwnam(char *name)*/
9969 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9970 {
9971     struct dsc$descriptor_s name_desc;
9972     union uicdef uic;
9973     unsigned long int status, sts;
9974
9975     __pwdcache = __passwd_empty;
9976     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9977       /* We still may be able to determine pw_uid and pw_gid */
9978       name_desc.dsc$w_length=  strlen(name);
9979       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9980       name_desc.dsc$b_class=   DSC$K_CLASS_S;
9981       name_desc.dsc$a_pointer= (char *) name;
9982       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9983         __pwdcache.pw_uid= uic.uic$l_uic;
9984         __pwdcache.pw_gid= uic.uic$v_group;
9985       }
9986       else {
9987         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9988           set_vaxc_errno(sts);
9989           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9990           return NULL;
9991         }
9992         else { _ckvmssts(sts); }
9993       }
9994     }
9995     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9996     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9997     __pwdcache.pw_name= __pw_namecache;
9998     return &__pwdcache;
9999 }  /* end of my_getpwnam() */
10000 /*}}}*/
10001
10002 /*
10003  * Get information for a particular UIC or UID.
10004  * Called by my_getpwent with uid=-1 to list all users.
10005 */
10006 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
10007 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
10008 {
10009     const $DESCRIPTOR(name_desc,__pw_namecache);
10010     unsigned short lname;
10011     union uicdef uic;
10012     unsigned long int status;
10013
10014     if (uid == (unsigned int) -1) {
10015       do {
10016         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
10017         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
10018           set_vaxc_errno(status);
10019           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10020           my_endpwent();
10021           return NULL;
10022         }
10023         else { _ckvmssts(status); }
10024       } while (!valid_uic (uic));
10025     }
10026     else {
10027       uic.uic$l_uic= uid;
10028       if (!uic.uic$v_group)
10029         uic.uic$v_group= PerlProc_getgid();
10030       if (valid_uic(uic))
10031         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
10032       else status = SS$_IVIDENT;
10033       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
10034           status == RMS$_PRV) {
10035         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10036         return NULL;
10037       }
10038       else { _ckvmssts(status); }
10039     }
10040     __pw_namecache[lname]= '\0';
10041     __mystrtolower(__pw_namecache);
10042
10043     __pwdcache = __passwd_empty;
10044     __pwdcache.pw_name = __pw_namecache;
10045
10046 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10047     The identifier's value is usually the UIC, but it doesn't have to be,
10048     so if we can, we let fillpasswd update this. */
10049     __pwdcache.pw_uid =  uic.uic$l_uic;
10050     __pwdcache.pw_gid =  uic.uic$v_group;
10051
10052     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10053     return &__pwdcache;
10054
10055 }  /* end of my_getpwuid() */
10056 /*}}}*/
10057
10058 /*
10059  * Get information for next user.
10060 */
10061 /*{{{struct passwd *my_getpwent()*/
10062 struct passwd *Perl_my_getpwent(pTHX)
10063 {
10064     return (my_getpwuid((unsigned int) -1));
10065 }
10066 /*}}}*/
10067
10068 /*
10069  * Finish searching rights database for users.
10070 */
10071 /*{{{void my_endpwent()*/
10072 void Perl_my_endpwent(pTHX)
10073 {
10074     if (contxt) {
10075       _ckvmssts(sys$finish_rdb(&contxt));
10076       contxt= 0;
10077     }
10078 }
10079 /*}}}*/
10080
10081 #ifdef HOMEGROWN_POSIX_SIGNALS
10082   /* Signal handling routines, pulled into the core from POSIX.xs.
10083    *
10084    * We need these for threads, so they've been rolled into the core,
10085    * rather than left in POSIX.xs.
10086    *
10087    * (DRS, Oct 23, 1997)
10088    */
10089
10090   /* sigset_t is atomic under VMS, so these routines are easy */
10091 /*{{{int my_sigemptyset(sigset_t *) */
10092 int my_sigemptyset(sigset_t *set) {
10093     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10094     *set = 0; return 0;
10095 }
10096 /*}}}*/
10097
10098
10099 /*{{{int my_sigfillset(sigset_t *)*/
10100 int my_sigfillset(sigset_t *set) {
10101     int i;
10102     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10103     for (i = 0; i < NSIG; i++) *set |= (1 << i);
10104     return 0;
10105 }
10106 /*}}}*/
10107
10108
10109 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10110 int my_sigaddset(sigset_t *set, int sig) {
10111     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10112     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10113     *set |= (1 << (sig - 1));
10114     return 0;
10115 }
10116 /*}}}*/
10117
10118
10119 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10120 int my_sigdelset(sigset_t *set, int sig) {
10121     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10122     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10123     *set &= ~(1 << (sig - 1));
10124     return 0;
10125 }
10126 /*}}}*/
10127
10128
10129 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10130 int my_sigismember(sigset_t *set, int sig) {
10131     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10132     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10133     return *set & (1 << (sig - 1));
10134 }
10135 /*}}}*/
10136
10137
10138 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10139 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10140     sigset_t tempmask;
10141
10142     /* If set and oset are both null, then things are badly wrong. Bail out. */
10143     if ((oset == NULL) && (set == NULL)) {
10144       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10145       return -1;
10146     }
10147
10148     /* If set's null, then we're just handling a fetch. */
10149     if (set == NULL) {
10150         tempmask = sigblock(0);
10151     }
10152     else {
10153       switch (how) {
10154       case SIG_SETMASK:
10155         tempmask = sigsetmask(*set);
10156         break;
10157       case SIG_BLOCK:
10158         tempmask = sigblock(*set);
10159         break;
10160       case SIG_UNBLOCK:
10161         tempmask = sigblock(0);
10162         sigsetmask(*oset & ~tempmask);
10163         break;
10164       default:
10165         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10166         return -1;
10167       }
10168     }
10169
10170     /* Did they pass us an oset? If so, stick our holding mask into it */
10171     if (oset)
10172       *oset = tempmask;
10173
10174     return 0;
10175 }
10176 /*}}}*/
10177 #endif  /* HOMEGROWN_POSIX_SIGNALS */
10178
10179
10180 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10181  * my_utime(), and flex_stat(), all of which operate on UTC unless
10182  * VMSISH_TIMES is true.
10183  */
10184 /* method used to handle UTC conversions:
10185  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
10186  */
10187 static int gmtime_emulation_type;
10188 /* number of secs to add to UTC POSIX-style time to get local time */
10189 static long int utc_offset_secs;
10190
10191 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10192  * in vmsish.h.  #undef them here so we can call the CRTL routines
10193  * directly.
10194  */
10195 #undef gmtime
10196 #undef localtime
10197 #undef time
10198
10199
10200 /*
10201  * DEC C previous to 6.0 corrupts the behavior of the /prefix
10202  * qualifier with the extern prefix pragma.  This provisional
10203  * hack circumvents this prefix pragma problem in previous
10204  * precompilers.
10205  */
10206 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10207 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10208 #    pragma __extern_prefix save
10209 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
10210 #    define gmtime decc$__utctz_gmtime
10211 #    define localtime decc$__utctz_localtime
10212 #    define time decc$__utc_time
10213 #    pragma __extern_prefix restore
10214
10215      struct tm *gmtime(), *localtime();
10216
10217 #  endif
10218 #endif
10219
10220
10221 static time_t toutc_dst(time_t loc) {
10222   struct tm *rsltmp;
10223
10224   if ((rsltmp = localtime(&loc)) == NULL) return -1;
10225   loc -= utc_offset_secs;
10226   if (rsltmp->tm_isdst) loc -= 3600;
10227   return loc;
10228 }
10229 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10230        ((gmtime_emulation_type || my_time(NULL)), \
10231        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10232        ((secs) - utc_offset_secs))))
10233
10234 static time_t toloc_dst(time_t utc) {
10235   struct tm *rsltmp;
10236
10237   utc += utc_offset_secs;
10238   if ((rsltmp = localtime(&utc)) == NULL) return -1;
10239   if (rsltmp->tm_isdst) utc += 3600;
10240   return utc;
10241 }
10242 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10243        ((gmtime_emulation_type || my_time(NULL)), \
10244        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10245        ((secs) + utc_offset_secs))))
10246
10247 #ifndef RTL_USES_UTC
10248 /*
10249
10250     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
10251         DST starts on 1st sun of april      at 02:00  std time
10252             ends on last sun of october     at 02:00  dst time
10253     see the UCX management command reference, SET CONFIG TIMEZONE
10254     for formatting info.
10255
10256     No, it's not as general as it should be, but then again, NOTHING
10257     will handle UK times in a sensible way.
10258 */
10259
10260
10261 /*
10262     parse the DST start/end info:
10263     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10264 */
10265
10266 static char *
10267 tz_parse_startend(char *s, struct tm *w, int *past)
10268 {
10269     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10270     int ly, dozjd, d, m, n, hour, min, sec, j, k;
10271     time_t g;
10272
10273     if (!s)    return 0;
10274     if (!w) return 0;
10275     if (!past) return 0;
10276
10277     ly = 0;
10278     if (w->tm_year % 4        == 0) ly = 1;
10279     if (w->tm_year % 100      == 0) ly = 0;
10280     if (w->tm_year+1900 % 400 == 0) ly = 1;
10281     if (ly) dinm[1]++;
10282
10283     dozjd = isdigit(*s);
10284     if (*s == 'J' || *s == 'j' || dozjd) {
10285         if (!dozjd && !isdigit(*++s)) return 0;
10286         d = *s++ - '0';
10287         if (isdigit(*s)) {
10288             d = d*10 + *s++ - '0';
10289             if (isdigit(*s)) {
10290                 d = d*10 + *s++ - '0';
10291             }
10292         }
10293         if (d == 0) return 0;
10294         if (d > 366) return 0;
10295         d--;
10296         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
10297         g = d * 86400;
10298         dozjd = 1;
10299     } else if (*s == 'M' || *s == 'm') {
10300         if (!isdigit(*++s)) return 0;
10301         m = *s++ - '0';
10302         if (isdigit(*s)) m = 10*m + *s++ - '0';
10303         if (*s != '.') return 0;
10304         if (!isdigit(*++s)) return 0;
10305         n = *s++ - '0';
10306         if (n < 1 || n > 5) return 0;
10307         if (*s != '.') return 0;
10308         if (!isdigit(*++s)) return 0;
10309         d = *s++ - '0';
10310         if (d > 6) return 0;
10311     }
10312
10313     if (*s == '/') {
10314         if (!isdigit(*++s)) return 0;
10315         hour = *s++ - '0';
10316         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10317         if (*s == ':') {
10318             if (!isdigit(*++s)) return 0;
10319             min = *s++ - '0';
10320             if (isdigit(*s)) min = 10*min + *s++ - '0';
10321             if (*s == ':') {
10322                 if (!isdigit(*++s)) return 0;
10323                 sec = *s++ - '0';
10324                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10325             }
10326         }
10327     } else {
10328         hour = 2;
10329         min = 0;
10330         sec = 0;
10331     }
10332
10333     if (dozjd) {
10334         if (w->tm_yday < d) goto before;
10335         if (w->tm_yday > d) goto after;
10336     } else {
10337         if (w->tm_mon+1 < m) goto before;
10338         if (w->tm_mon+1 > m) goto after;
10339
10340         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
10341         k = d - j; /* mday of first d */
10342         if (k <= 0) k += 7;
10343         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
10344         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10345         if (w->tm_mday < k) goto before;
10346         if (w->tm_mday > k) goto after;
10347     }
10348
10349     if (w->tm_hour < hour) goto before;
10350     if (w->tm_hour > hour) goto after;
10351     if (w->tm_min  < min)  goto before;
10352     if (w->tm_min  > min)  goto after;
10353     if (w->tm_sec  < sec)  goto before;
10354     goto after;
10355
10356 before:
10357     *past = 0;
10358     return s;
10359 after:
10360     *past = 1;
10361     return s;
10362 }
10363
10364
10365
10366
10367 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
10368
10369 static char *
10370 tz_parse_offset(char *s, int *offset)
10371 {
10372     int hour = 0, min = 0, sec = 0;
10373     int neg = 0;
10374     if (!s) return 0;
10375     if (!offset) return 0;
10376
10377     if (*s == '-') {neg++; s++;}
10378     if (*s == '+') s++;
10379     if (!isdigit(*s)) return 0;
10380     hour = *s++ - '0';
10381     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10382     if (hour > 24) return 0;
10383     if (*s == ':') {
10384         if (!isdigit(*++s)) return 0;
10385         min = *s++ - '0';
10386         if (isdigit(*s)) min = min*10 + (*s++ - '0');
10387         if (min > 59) return 0;
10388         if (*s == ':') {
10389             if (!isdigit(*++s)) return 0;
10390             sec = *s++ - '0';
10391             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10392             if (sec > 59) return 0;
10393         }
10394     }
10395
10396     *offset = (hour*60+min)*60 + sec;
10397     if (neg) *offset = -*offset;
10398     return s;
10399 }
10400
10401 /*
10402     input time is w, whatever type of time the CRTL localtime() uses.
10403     sets dst, the zone, and the gmtoff (seconds)
10404
10405     caches the value of TZ and UCX$TZ env variables; note that
10406     my_setenv looks for these and sets a flag if they're changed
10407     for efficiency.
10408
10409     We have to watch out for the "australian" case (dst starts in
10410     october, ends in april)...flagged by "reverse" and checked by
10411     scanning through the months of the previous year.
10412
10413 */
10414
10415 static int
10416 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10417 {
10418     time_t when;
10419     struct tm *w2;
10420     char *s,*s2;
10421     char *dstzone, *tz, *s_start, *s_end;
10422     int std_off, dst_off, isdst;
10423     int y, dststart, dstend;
10424     static char envtz[1025];  /* longer than any logical, symbol, ... */
10425     static char ucxtz[1025];
10426     static char reversed = 0;
10427
10428     if (!w) return 0;
10429
10430     if (tz_updated) {
10431         tz_updated = 0;
10432         reversed = -1;  /* flag need to check  */
10433         envtz[0] = ucxtz[0] = '\0';
10434         tz = my_getenv("TZ",0);
10435         if (tz) strcpy(envtz, tz);
10436         tz = my_getenv("UCX$TZ",0);
10437         if (tz) strcpy(ucxtz, tz);
10438         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
10439     }
10440     tz = envtz;
10441     if (!*tz) tz = ucxtz;
10442
10443     s = tz;
10444     while (isalpha(*s)) s++;
10445     s = tz_parse_offset(s, &std_off);
10446     if (!s) return 0;
10447     if (!*s) {                  /* no DST, hurray we're done! */
10448         isdst = 0;
10449         goto done;
10450     }
10451
10452     dstzone = s;
10453     while (isalpha(*s)) s++;
10454     s2 = tz_parse_offset(s, &dst_off);
10455     if (s2) {
10456         s = s2;
10457     } else {
10458         dst_off = std_off - 3600;
10459     }
10460
10461     if (!*s) {      /* default dst start/end?? */
10462         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
10463             s = strchr(ucxtz,',');
10464         }
10465         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
10466     }
10467     if (*s != ',') return 0;
10468
10469     when = *w;
10470     when = _toutc(when);      /* convert to utc */
10471     when = when - std_off;    /* convert to pseudolocal time*/
10472
10473     w2 = localtime(&when);
10474     y = w2->tm_year;
10475     s_start = s+1;
10476     s = tz_parse_startend(s_start,w2,&dststart);
10477     if (!s) return 0;
10478     if (*s != ',') return 0;
10479
10480     when = *w;
10481     when = _toutc(when);      /* convert to utc */
10482     when = when - dst_off;    /* convert to pseudolocal time*/
10483     w2 = localtime(&when);
10484     if (w2->tm_year != y) {   /* spans a year, just check one time */
10485         when += dst_off - std_off;
10486         w2 = localtime(&when);
10487     }
10488     s_end = s+1;
10489     s = tz_parse_startend(s_end,w2,&dstend);
10490     if (!s) return 0;
10491
10492     if (reversed == -1) {  /* need to check if start later than end */
10493         int j, ds, de;
10494
10495         when = *w;
10496         if (when < 2*365*86400) {
10497             when += 2*365*86400;
10498         } else {
10499             when -= 365*86400;
10500         }
10501         w2 =localtime(&when);
10502         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
10503
10504         for (j = 0; j < 12; j++) {
10505             w2 =localtime(&when);
10506             tz_parse_startend(s_start,w2,&ds);
10507             tz_parse_startend(s_end,w2,&de);
10508             if (ds != de) break;
10509             when += 30*86400;
10510         }
10511         reversed = 0;
10512         if (de && !ds) reversed = 1;
10513     }
10514
10515     isdst = dststart && !dstend;
10516     if (reversed) isdst = dststart  || !dstend;
10517
10518 done:
10519     if (dst)    *dst = isdst;
10520     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10521     if (isdst)  tz = dstzone;
10522     if (zone) {
10523         while(isalpha(*tz))  *zone++ = *tz++;
10524         *zone = '\0';
10525     }
10526     return 1;
10527 }
10528
10529 #endif /* !RTL_USES_UTC */
10530
10531 /* my_time(), my_localtime(), my_gmtime()
10532  * By default traffic in UTC time values, using CRTL gmtime() or
10533  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10534  * Note: We need to use these functions even when the CRTL has working
10535  * UTC support, since they also handle C<use vmsish qw(times);>
10536  *
10537  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
10538  * Modified by Charles Bailey <bailey@newman.upenn.edu>
10539  */
10540
10541 /*{{{time_t my_time(time_t *timep)*/
10542 time_t Perl_my_time(pTHX_ time_t *timep)
10543 {
10544   time_t when;
10545   struct tm *tm_p;
10546
10547   if (gmtime_emulation_type == 0) {
10548     int dstnow;
10549     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
10550                               /* results of calls to gmtime() and localtime() */
10551                               /* for same &base */
10552
10553     gmtime_emulation_type++;
10554     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10555       char off[LNM$C_NAMLENGTH+1];;
10556
10557       gmtime_emulation_type++;
10558       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10559         gmtime_emulation_type++;
10560         utc_offset_secs = 0;
10561         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10562       }
10563       else { utc_offset_secs = atol(off); }
10564     }
10565     else { /* We've got a working gmtime() */
10566       struct tm gmt, local;
10567
10568       gmt = *tm_p;
10569       tm_p = localtime(&base);
10570       local = *tm_p;
10571       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
10572       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10573       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
10574       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
10575     }
10576   }
10577
10578   when = time(NULL);
10579 # ifdef VMSISH_TIME
10580 # ifdef RTL_USES_UTC
10581   if (VMSISH_TIME) when = _toloc(when);
10582 # else
10583   if (!VMSISH_TIME) when = _toutc(when);
10584 # endif
10585 # endif
10586   if (timep != NULL) *timep = when;
10587   return when;
10588
10589 }  /* end of my_time() */
10590 /*}}}*/
10591
10592
10593 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10594 struct tm *
10595 Perl_my_gmtime(pTHX_ const time_t *timep)
10596 {
10597   char *p;
10598   time_t when;
10599   struct tm *rsltmp;
10600
10601   if (timep == NULL) {
10602     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10603     return NULL;
10604   }
10605   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10606
10607   when = *timep;
10608 # ifdef VMSISH_TIME
10609   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10610 #  endif
10611 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
10612   return gmtime(&when);
10613 # else
10614   /* CRTL localtime() wants local time as input, so does no tz correction */
10615   rsltmp = localtime(&when);
10616   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
10617   return rsltmp;
10618 #endif
10619 }  /* end of my_gmtime() */
10620 /*}}}*/
10621
10622
10623 /*{{{struct tm *my_localtime(const time_t *timep)*/
10624 struct tm *
10625 Perl_my_localtime(pTHX_ const time_t *timep)
10626 {
10627   time_t when, whenutc;
10628   struct tm *rsltmp;
10629   int dst, offset;
10630
10631   if (timep == NULL) {
10632     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10633     return NULL;
10634   }
10635   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10636   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10637
10638   when = *timep;
10639 # ifdef RTL_USES_UTC
10640 # ifdef VMSISH_TIME
10641   if (VMSISH_TIME) when = _toutc(when);
10642 # endif
10643   /* CRTL localtime() wants UTC as input, does tz correction itself */
10644   return localtime(&when);
10645
10646 # else /* !RTL_USES_UTC */
10647   whenutc = when;
10648 # ifdef VMSISH_TIME
10649   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
10650   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
10651 # endif
10652   dst = -1;
10653 #ifndef RTL_USES_UTC
10654   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
10655       when = whenutc - offset;                   /* pseudolocal time*/
10656   }
10657 # endif
10658   /* CRTL localtime() wants local time as input, so does no tz correction */
10659   rsltmp = localtime(&when);
10660   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10661   return rsltmp;
10662 # endif
10663
10664 } /*  end of my_localtime() */
10665 /*}}}*/
10666
10667 /* Reset definitions for later calls */
10668 #define gmtime(t)    my_gmtime(t)
10669 #define localtime(t) my_localtime(t)
10670 #define time(t)      my_time(t)
10671
10672
10673 /* my_utime - update modification/access time of a file
10674  *
10675  * VMS 7.3 and later implementation
10676  * Only the UTC translation is home-grown. The rest is handled by the
10677  * CRTL utime(), which will take into account the relevant feature
10678  * logicals and ODS-5 volume characteristics for true access times.
10679  *
10680  * pre VMS 7.3 implementation:
10681  * The calling sequence is identical to POSIX utime(), but under
10682  * VMS with ODS-2, only the modification time is changed; ODS-2 does
10683  * not maintain access times.  Restrictions differ from the POSIX
10684  * definition in that the time can be changed as long as the
10685  * caller has permission to execute the necessary IO$_MODIFY $QIO;
10686  * no separate checks are made to insure that the caller is the
10687  * owner of the file or has special privs enabled.
10688  * Code here is based on Joe Meadows' FILE utility.
10689  *
10690  */
10691
10692 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10693  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
10694  * in 100 ns intervals.
10695  */
10696 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10697
10698 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10699 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10700 {
10701 #if __CRTL_VER >= 70300000
10702   struct utimbuf utc_utimes, *utc_utimesp;
10703
10704   if (utimes != NULL) {
10705     utc_utimes.actime = utimes->actime;
10706     utc_utimes.modtime = utimes->modtime;
10707 # ifdef VMSISH_TIME
10708     /* If input was local; convert to UTC for sys svc */
10709     if (VMSISH_TIME) {
10710       utc_utimes.actime = _toutc(utimes->actime);
10711       utc_utimes.modtime = _toutc(utimes->modtime);
10712     }
10713 # endif
10714     utc_utimesp = &utc_utimes;
10715   }
10716   else {
10717     utc_utimesp = NULL;
10718   }
10719
10720   return utime(file, utc_utimesp);
10721
10722 #else /* __CRTL_VER < 70300000 */
10723
10724   register int i;
10725   int sts;
10726   long int bintime[2], len = 2, lowbit, unixtime,
10727            secscale = 10000000; /* seconds --> 100 ns intervals */
10728   unsigned long int chan, iosb[2], retsts;
10729   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10730   struct FAB myfab = cc$rms_fab;
10731   struct NAM mynam = cc$rms_nam;
10732 #if defined (__DECC) && defined (__VAX)
10733   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10734    * at least through VMS V6.1, which causes a type-conversion warning.
10735    */
10736 #  pragma message save
10737 #  pragma message disable cvtdiftypes
10738 #endif
10739   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10740   struct fibdef myfib;
10741 #if defined (__DECC) && defined (__VAX)
10742   /* This should be right after the declaration of myatr, but due
10743    * to a bug in VAX DEC C, this takes effect a statement early.
10744    */
10745 #  pragma message restore
10746 #endif
10747   /* cast ok for read only parameter */
10748   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10749                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10750                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10751
10752   if (file == NULL || *file == '\0') {
10753     SETERRNO(ENOENT, LIB$_INVARG);
10754     return -1;
10755   }
10756
10757   /* Convert to VMS format ensuring that it will fit in 255 characters */
10758   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10759       SETERRNO(ENOENT, LIB$_INVARG);
10760       return -1;
10761   }
10762   if (utimes != NULL) {
10763     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
10764      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10765      * Since time_t is unsigned long int, and lib$emul takes a signed long int
10766      * as input, we force the sign bit to be clear by shifting unixtime right
10767      * one bit, then multiplying by an extra factor of 2 in lib$emul().
10768      */
10769     lowbit = (utimes->modtime & 1) ? secscale : 0;
10770     unixtime = (long int) utimes->modtime;
10771 #   ifdef VMSISH_TIME
10772     /* If input was UTC; convert to local for sys svc */
10773     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10774 #   endif
10775     unixtime >>= 1;  secscale <<= 1;
10776     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10777     if (!(retsts & 1)) {
10778       SETERRNO(EVMSERR, retsts);
10779       return -1;
10780     }
10781     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10782     if (!(retsts & 1)) {
10783       SETERRNO(EVMSERR, retsts);
10784       return -1;
10785     }
10786   }
10787   else {
10788     /* Just get the current time in VMS format directly */
10789     retsts = sys$gettim(bintime);
10790     if (!(retsts & 1)) {
10791       SETERRNO(EVMSERR, retsts);
10792       return -1;
10793     }
10794   }
10795
10796   myfab.fab$l_fna = vmsspec;
10797   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10798   myfab.fab$l_nam = &mynam;
10799   mynam.nam$l_esa = esa;
10800   mynam.nam$b_ess = (unsigned char) sizeof esa;
10801   mynam.nam$l_rsa = rsa;
10802   mynam.nam$b_rss = (unsigned char) sizeof rsa;
10803   if (decc_efs_case_preserve)
10804       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10805
10806   /* Look for the file to be affected, letting RMS parse the file
10807    * specification for us as well.  I have set errno using only
10808    * values documented in the utime() man page for VMS POSIX.
10809    */
10810   retsts = sys$parse(&myfab,0,0);
10811   if (!(retsts & 1)) {
10812     set_vaxc_errno(retsts);
10813     if      (retsts == RMS$_PRV) set_errno(EACCES);
10814     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10815     else                         set_errno(EVMSERR);
10816     return -1;
10817   }
10818   retsts = sys$search(&myfab,0,0);
10819   if (!(retsts & 1)) {
10820     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10821     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10822     set_vaxc_errno(retsts);
10823     if      (retsts == RMS$_PRV) set_errno(EACCES);
10824     else if (retsts == RMS$_FNF) set_errno(ENOENT);
10825     else                         set_errno(EVMSERR);
10826     return -1;
10827   }
10828
10829   devdsc.dsc$w_length = mynam.nam$b_dev;
10830   /* cast ok for read only parameter */
10831   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10832
10833   retsts = sys$assign(&devdsc,&chan,0,0);
10834   if (!(retsts & 1)) {
10835     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10836     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10837     set_vaxc_errno(retsts);
10838     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
10839     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
10840     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
10841     else                               set_errno(EVMSERR);
10842     return -1;
10843   }
10844
10845   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10846   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10847
10848   memset((void *) &myfib, 0, sizeof myfib);
10849 #if defined(__DECC) || defined(__DECCXX)
10850   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10851   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10852   /* This prevents the revision time of the file being reset to the current
10853    * time as a result of our IO$_MODIFY $QIO. */
10854   myfib.fib$l_acctl = FIB$M_NORECORD;
10855 #else
10856   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10857   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10858   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10859 #endif
10860   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10861   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10862   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10863   _ckvmssts(sys$dassgn(chan));
10864   if (retsts & 1) retsts = iosb[0];
10865   if (!(retsts & 1)) {
10866     set_vaxc_errno(retsts);
10867     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10868     else                      set_errno(EVMSERR);
10869     return -1;
10870   }
10871
10872   return 0;
10873
10874 #endif /* #if __CRTL_VER >= 70300000 */
10875
10876 }  /* end of my_utime() */
10877 /*}}}*/
10878
10879 /*
10880  * flex_stat, flex_lstat, flex_fstat
10881  * basic stat, but gets it right when asked to stat
10882  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10883  */
10884
10885 #ifndef _USE_STD_STAT
10886 /* encode_dev packs a VMS device name string into an integer to allow
10887  * simple comparisons. This can be used, for example, to check whether two
10888  * files are located on the same device, by comparing their encoded device
10889  * names. Even a string comparison would not do, because stat() reuses the
10890  * device name buffer for each call; so without encode_dev, it would be
10891  * necessary to save the buffer and use strcmp (this would mean a number of
10892  * changes to the standard Perl code, to say nothing of what a Perl script
10893  * would have to do.
10894  *
10895  * The device lock id, if it exists, should be unique (unless perhaps compared
10896  * with lock ids transferred from other nodes). We have a lock id if the disk is
10897  * mounted cluster-wide, which is when we tend to get long (host-qualified)
10898  * device names. Thus we use the lock id in preference, and only if that isn't
10899  * available, do we try to pack the device name into an integer (flagged by
10900  * the sign bit (LOCKID_MASK) being set).
10901  *
10902  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10903  * name and its encoded form, but it seems very unlikely that we will find
10904  * two files on different disks that share the same encoded device names,
10905  * and even more remote that they will share the same file id (if the test
10906  * is to check for the same file).
10907  *
10908  * A better method might be to use sys$device_scan on the first call, and to
10909  * search for the device, returning an index into the cached array.
10910  * The number returned would be more intelligible.
10911  * This is probably not worth it, and anyway would take quite a bit longer
10912  * on the first call.
10913  */
10914 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
10915 static mydev_t encode_dev (pTHX_ const char *dev)
10916 {
10917   int i;
10918   unsigned long int f;
10919   mydev_t enc;
10920   char c;
10921   const char *q;
10922
10923   if (!dev || !dev[0]) return 0;
10924
10925 #if LOCKID_MASK
10926   {
10927     struct dsc$descriptor_s dev_desc;
10928     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10929
10930     /* For cluster-mounted disks, the disk lock identifier is unique, so we
10931        can try that first. */
10932     dev_desc.dsc$w_length =  strlen (dev);
10933     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
10934     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
10935     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
10936     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10937     if (!$VMS_STATUS_SUCCESS(status)) {
10938       switch (status) {
10939         case SS$_NOSUCHDEV:
10940           SETERRNO(ENODEV, status);
10941           return 0;
10942         default:
10943           _ckvmssts(status);
10944       }
10945     }
10946     if (lockid) return (lockid & ~LOCKID_MASK);
10947   }
10948 #endif
10949
10950   /* Otherwise we try to encode the device name */
10951   enc = 0;
10952   f = 1;
10953   i = 0;
10954   for (q = dev + strlen(dev); q--; q >= dev) {
10955     if (*q == ':')
10956         break;
10957     if (isdigit (*q))
10958       c= (*q) - '0';
10959     else if (isalpha (toupper (*q)))
10960       c= toupper (*q) - 'A' + (char)10;
10961     else
10962       continue; /* Skip '$'s */
10963     i++;
10964     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
10965     if (i>1) f *= 36;
10966     enc += f * (unsigned long int) c;
10967   }
10968   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
10969
10970 }  /* end of encode_dev() */
10971 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10972         device_no = encode_dev(aTHX_ devname)
10973 #else
10974 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10975         device_no = new_dev_no
10976 #endif
10977
10978 static int
10979 is_null_device(name)
10980     const char *name;
10981 {
10982   if (decc_bug_devnull != 0) {
10983     if (strncmp("/dev/null", name, 9) == 0)
10984       return 1;
10985   }
10986     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10987        The underscore prefix, controller letter, and unit number are
10988        independently optional; for our purposes, the colon punctuation
10989        is not.  The colon can be trailed by optional directory and/or
10990        filename, but two consecutive colons indicates a nodename rather
10991        than a device.  [pr]  */
10992   if (*name == '_') ++name;
10993   if (tolower(*name++) != 'n') return 0;
10994   if (tolower(*name++) != 'l') return 0;
10995   if (tolower(*name) == 'a') ++name;
10996   if (*name == '0') ++name;
10997   return (*name++ == ':') && (*name != ':');
10998 }
10999
11000
11001 static I32
11002 Perl_cando_by_name_int
11003    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11004 {
11005   char usrname[L_cuserid];
11006   struct dsc$descriptor_s usrdsc =
11007          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11008   char *vmsname = NULL, *fileified = NULL;
11009   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11010   unsigned short int retlen, trnlnm_iter_count;
11011   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11012   union prvdef curprv;
11013   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11014          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11015          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11016   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11017          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11018          {0,0,0,0}};
11019   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11020          {0,0,0,0}};
11021   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11022   Stat_t st;
11023   static int profile_context = -1;
11024
11025   if (!fname || !*fname) return FALSE;
11026
11027   /* Make sure we expand logical names, since sys$check_access doesn't */
11028   fileified = PerlMem_malloc(VMS_MAXRSS);
11029   if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
11030   if (!strpbrk(fname,"/]>:")) {
11031       strcpy(fileified,fname);
11032       trnlnm_iter_count = 0;
11033       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11034         trnlnm_iter_count++;
11035         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11036       }
11037       fname = fileified;
11038   }
11039
11040   vmsname = PerlMem_malloc(VMS_MAXRSS);
11041   if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11042   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11043     /* Don't know if already in VMS format, so make sure */
11044     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11045       PerlMem_free(fileified);
11046       PerlMem_free(vmsname);
11047       return FALSE;
11048     }
11049   }
11050   else {
11051     strcpy(vmsname,fname);
11052   }
11053
11054   /* sys$check_access needs a file spec, not a directory spec.
11055    * Don't use flex_stat here, as that depends on thread context
11056    * having been initialized, and we may get here during startup.
11057    */
11058
11059   retlen = namdsc.dsc$w_length = strlen(vmsname);
11060   if (vmsname[retlen-1] == ']'
11061       || vmsname[retlen-1] == '>'
11062       || vmsname[retlen-1] == ':'
11063       || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11064
11065       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11066         PerlMem_free(fileified);
11067         PerlMem_free(vmsname);
11068         return FALSE;
11069       }
11070       fname = fileified;
11071   }
11072   else {
11073       fname = vmsname;
11074   }
11075
11076   retlen = namdsc.dsc$w_length = strlen(fname);
11077   namdsc.dsc$a_pointer = (char *)fname;
11078
11079   switch (bit) {
11080     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11081       access = ARM$M_EXECUTE;
11082       flags = CHP$M_READ;
11083       break;
11084     case S_IRUSR: case S_IRGRP: case S_IROTH:
11085       access = ARM$M_READ;
11086       flags = CHP$M_READ | CHP$M_USEREADALL;
11087       break;
11088     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11089       access = ARM$M_WRITE;
11090       flags = CHP$M_READ | CHP$M_WRITE;
11091       break;
11092     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11093       access = ARM$M_DELETE;
11094       flags = CHP$M_READ | CHP$M_WRITE;
11095       break;
11096     default:
11097       if (fileified != NULL)
11098         PerlMem_free(fileified);
11099       if (vmsname != NULL)
11100         PerlMem_free(vmsname);
11101       return FALSE;
11102   }
11103
11104   /* Before we call $check_access, create a user profile with the current
11105    * process privs since otherwise it just uses the default privs from the
11106    * UAF and might give false positives or negatives.  This only works on
11107    * VMS versions v6.0 and later since that's when sys$create_user_profile
11108    * became available.
11109    */
11110
11111   /* get current process privs and username */
11112   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11113   _ckvmssts(iosb[0]);
11114
11115 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11116
11117   /* find out the space required for the profile */
11118   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11119                                     &usrprodsc.dsc$w_length,&profile_context));
11120
11121   /* allocate space for the profile and get it filled in */
11122   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11123   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11124   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11125                                     &usrprodsc.dsc$w_length,&profile_context));
11126
11127   /* use the profile to check access to the file; free profile & analyze results */
11128   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11129   PerlMem_free(usrprodsc.dsc$a_pointer);
11130   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11131
11132 #else
11133
11134   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11135
11136 #endif
11137
11138   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11139       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11140       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11141     set_vaxc_errno(retsts);
11142     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11143     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11144     else set_errno(ENOENT);
11145     if (fileified != NULL)
11146       PerlMem_free(fileified);
11147     if (vmsname != NULL)
11148       PerlMem_free(vmsname);
11149     return FALSE;
11150   }
11151   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11152     if (fileified != NULL)
11153       PerlMem_free(fileified);
11154     if (vmsname != NULL)
11155       PerlMem_free(vmsname);
11156     return TRUE;
11157   }
11158   _ckvmssts(retsts);
11159
11160   if (fileified != NULL)
11161     PerlMem_free(fileified);
11162   if (vmsname != NULL)
11163     PerlMem_free(vmsname);
11164   return FALSE;  /* Should never get here */
11165
11166 }
11167
11168 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
11169 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11170  * subset of the applicable information.
11171  */
11172 bool
11173 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11174 {
11175   return cando_by_name_int
11176         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11177 }  /* end of cando() */
11178 /*}}}*/
11179
11180
11181 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11182 I32
11183 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11184 {
11185    return cando_by_name_int(bit, effective, fname, 0);
11186
11187 }  /* end of cando_by_name() */
11188 /*}}}*/
11189
11190
11191 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11192 int
11193 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11194 {
11195   if (!fstat(fd,(stat_t *) statbufp)) {
11196     char *cptr;
11197     char *vms_filename;
11198     vms_filename = PerlMem_malloc(VMS_MAXRSS);
11199     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11200
11201     /* Save name for cando by name in VMS format */
11202     cptr = getname(fd, vms_filename, 1);
11203
11204     /* This should not happen, but just in case */
11205     if (cptr == NULL) {
11206         statbufp->st_devnam[0] = 0;
11207     }
11208     else {
11209         /* Make sure that the saved name fits in 255 characters */
11210         cptr = do_rmsexpand
11211                        (vms_filename,
11212                         statbufp->st_devnam,
11213                         0,
11214                         NULL,
11215                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11216                         NULL,
11217                         NULL);
11218         if (cptr == NULL)
11219             statbufp->st_devnam[0] = 0;
11220     }
11221     PerlMem_free(vms_filename);
11222
11223     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11224     VMS_DEVICE_ENCODE
11225         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11226
11227 #   ifdef RTL_USES_UTC
11228 #   ifdef VMSISH_TIME
11229     if (VMSISH_TIME) {
11230       statbufp->st_mtime = _toloc(statbufp->st_mtime);
11231       statbufp->st_atime = _toloc(statbufp->st_atime);
11232       statbufp->st_ctime = _toloc(statbufp->st_ctime);
11233     }
11234 #   endif
11235 #   else
11236 #   ifdef VMSISH_TIME
11237     if (!VMSISH_TIME) { /* Return UTC instead of local time */
11238 #   else
11239     if (1) {
11240 #   endif
11241       statbufp->st_mtime = _toutc(statbufp->st_mtime);
11242       statbufp->st_atime = _toutc(statbufp->st_atime);
11243       statbufp->st_ctime = _toutc(statbufp->st_ctime);
11244     }
11245 #endif
11246     return 0;
11247   }
11248   return -1;
11249
11250 }  /* end of flex_fstat() */
11251 /*}}}*/
11252
11253 #if !defined(__VAX) && __CRTL_VER >= 80200000
11254 #ifdef lstat
11255 #undef lstat
11256 #endif
11257 #else
11258 #ifdef lstat
11259 #undef lstat
11260 #endif
11261 #define lstat(_x, _y) stat(_x, _y)
11262 #endif
11263
11264 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11265
11266 static int
11267 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11268 {
11269     char fileified[VMS_MAXRSS];
11270     char temp_fspec[VMS_MAXRSS];
11271     char *save_spec;
11272     int retval = -1;
11273     int saved_errno, saved_vaxc_errno;
11274
11275     if (!fspec) return retval;
11276     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11277     strcpy(temp_fspec, fspec);
11278
11279     if (decc_bug_devnull != 0) {
11280       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11281         memset(statbufp,0,sizeof *statbufp);
11282         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11283         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11284         statbufp->st_uid = 0x00010001;
11285         statbufp->st_gid = 0x0001;
11286         time((time_t *)&statbufp->st_mtime);
11287         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11288         return 0;
11289       }
11290     }
11291
11292     /* Try for a directory name first.  If fspec contains a filename without
11293      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11294      * and sea:[wine.dark]water. exist, we prefer the directory here.
11295      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11296      * not sea:[wine.dark]., if the latter exists.  If the intended target is
11297      * the file with null type, specify this by calling flex_stat() with
11298      * a '.' at the end of fspec.
11299      *
11300      * If we are in Posix filespec mode, accept the filename as is.
11301      */
11302
11303
11304 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11305   /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11306    * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11307    */
11308   if (!decc_efs_charset)
11309     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11310 #endif
11311
11312 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11313   if (decc_posix_compliant_pathnames == 0) {
11314 #endif
11315     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11316       if (lstat_flag == 0)
11317         retval = stat(fileified,(stat_t *) statbufp);
11318       else
11319         retval = lstat(fileified,(stat_t *) statbufp);
11320       save_spec = fileified;
11321     }
11322     if (retval) {
11323       if (lstat_flag == 0)
11324         retval = stat(temp_fspec,(stat_t *) statbufp);
11325       else
11326         retval = lstat(temp_fspec,(stat_t *) statbufp);
11327       save_spec = temp_fspec;
11328     }
11329 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11330   } else {
11331     if (lstat_flag == 0)
11332       retval = stat(temp_fspec,(stat_t *) statbufp);
11333     else
11334       retval = lstat(temp_fspec,(stat_t *) statbufp);
11335       save_spec = temp_fspec;
11336   }
11337 #endif
11338
11339 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11340   /* As you were... */
11341   if (!decc_efs_charset)
11342     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11343 #endif
11344
11345     if (!retval) {
11346     char * cptr;
11347       cptr = do_rmsexpand
11348        (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
11349       if (cptr == NULL)
11350         statbufp->st_devnam[0] = 0;
11351
11352       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11353       VMS_DEVICE_ENCODE
11354         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11355 #     ifdef RTL_USES_UTC
11356 #     ifdef VMSISH_TIME
11357       if (VMSISH_TIME) {
11358         statbufp->st_mtime = _toloc(statbufp->st_mtime);
11359         statbufp->st_atime = _toloc(statbufp->st_atime);
11360         statbufp->st_ctime = _toloc(statbufp->st_ctime);
11361       }
11362 #     endif
11363 #     else
11364 #     ifdef VMSISH_TIME
11365       if (!VMSISH_TIME) { /* Return UTC instead of local time */
11366 #     else
11367       if (1) {
11368 #     endif
11369         statbufp->st_mtime = _toutc(statbufp->st_mtime);
11370         statbufp->st_atime = _toutc(statbufp->st_atime);
11371         statbufp->st_ctime = _toutc(statbufp->st_ctime);
11372       }
11373 #     endif
11374     }
11375     /* If we were successful, leave errno where we found it */
11376     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
11377     return retval;
11378
11379 }  /* end of flex_stat_int() */
11380
11381
11382 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
11383 int
11384 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
11385 {
11386    return flex_stat_int(fspec, statbufp, 0);
11387 }
11388 /*}}}*/
11389
11390 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
11391 int
11392 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
11393 {
11394    return flex_stat_int(fspec, statbufp, 1);
11395 }
11396 /*}}}*/
11397
11398
11399 /*{{{char *my_getlogin()*/
11400 /* VMS cuserid == Unix getlogin, except calling sequence */
11401 char *
11402 my_getlogin(void)
11403 {
11404     static char user[L_cuserid];
11405     return cuserid(user);
11406 }
11407 /*}}}*/
11408
11409
11410 /*  rmscopy - copy a file using VMS RMS routines
11411  *
11412  *  Copies contents and attributes of spec_in to spec_out, except owner
11413  *  and protection information.  Name and type of spec_in are used as
11414  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
11415  *  should try to propagate timestamps from the input file to the output file.
11416  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
11417  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
11418  *  propagated to the output file at creation iff the output file specification
11419  *  did not contain an explicit name or type, and the revision date is always
11420  *  updated at the end of the copy operation.  If it is greater than 0, then
11421  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11422  *  other than the revision date should be propagated, and bit 1 indicates
11423  *  that the revision date should be propagated.
11424  *
11425  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11426  *
11427  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11428  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
11429  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
11430  * as part of the Perl standard distribution under the terms of the
11431  * GNU General Public License or the Perl Artistic License.  Copies
11432  * of each may be found in the Perl standard distribution.
11433  */ /* FIXME */
11434 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11435 int
11436 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11437 {
11438     char *vmsin, * vmsout, *esa, *esa_out,
11439          *rsa, *ubf;
11440     unsigned long int i, sts, sts2;
11441     int dna_len;
11442     struct FAB fab_in, fab_out;
11443     struct RAB rab_in, rab_out;
11444     rms_setup_nam(nam);
11445     rms_setup_nam(nam_out);
11446     struct XABDAT xabdat;
11447     struct XABFHC xabfhc;
11448     struct XABRDT xabrdt;
11449     struct XABSUM xabsum;
11450
11451     vmsin = PerlMem_malloc(VMS_MAXRSS);
11452     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11453     vmsout = PerlMem_malloc(VMS_MAXRSS);
11454     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11455     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11456         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11457       PerlMem_free(vmsin);
11458       PerlMem_free(vmsout);
11459       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11460       return 0;
11461     }
11462
11463     esa = PerlMem_malloc(VMS_MAXRSS);
11464     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11465     fab_in = cc$rms_fab;
11466     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11467     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11468     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11469     fab_in.fab$l_fop = FAB$M_SQO;
11470     rms_bind_fab_nam(fab_in, nam);
11471     fab_in.fab$l_xab = (void *) &xabdat;
11472
11473     rsa = PerlMem_malloc(VMS_MAXRSS);
11474     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11475     rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11476     rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11477     rms_nam_esl(nam) = 0;
11478     rms_nam_rsl(nam) = 0;
11479     rms_nam_esll(nam) = 0;
11480     rms_nam_rsll(nam) = 0;
11481 #ifdef NAM$M_NO_SHORT_UPCASE
11482     if (decc_efs_case_preserve)
11483         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11484 #endif
11485
11486     xabdat = cc$rms_xabdat;        /* To get creation date */
11487     xabdat.xab$l_nxt = (void *) &xabfhc;
11488
11489     xabfhc = cc$rms_xabfhc;        /* To get record length */
11490     xabfhc.xab$l_nxt = (void *) &xabsum;
11491
11492     xabsum = cc$rms_xabsum;        /* To get key and area information */
11493
11494     if (!((sts = sys$open(&fab_in)) & 1)) {
11495       PerlMem_free(vmsin);
11496       PerlMem_free(vmsout);
11497       PerlMem_free(esa);
11498       PerlMem_free(rsa);
11499       set_vaxc_errno(sts);
11500       switch (sts) {
11501         case RMS$_FNF: case RMS$_DNF:
11502           set_errno(ENOENT); break;
11503         case RMS$_DIR:
11504           set_errno(ENOTDIR); break;
11505         case RMS$_DEV:
11506           set_errno(ENODEV); break;
11507         case RMS$_SYN:
11508           set_errno(EINVAL); break;
11509         case RMS$_PRV:
11510           set_errno(EACCES); break;
11511         default:
11512           set_errno(EVMSERR);
11513       }
11514       return 0;
11515     }
11516
11517     nam_out = nam;
11518     fab_out = fab_in;
11519     fab_out.fab$w_ifi = 0;
11520     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11521     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11522     fab_out.fab$l_fop = FAB$M_SQO;
11523     rms_bind_fab_nam(fab_out, nam_out);
11524     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11525     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11526     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11527     esa_out = PerlMem_malloc(VMS_MAXRSS);
11528     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11529     rms_set_rsa(nam_out, NULL, 0);
11530     rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11531
11532     if (preserve_dates == 0) {  /* Act like DCL COPY */
11533       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11534       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
11535       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11536         PerlMem_free(vmsin);
11537         PerlMem_free(vmsout);
11538         PerlMem_free(esa);
11539         PerlMem_free(rsa);
11540         PerlMem_free(esa_out);
11541         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11542         set_vaxc_errno(sts);
11543         return 0;
11544       }
11545       fab_out.fab$l_xab = (void *) &xabdat;
11546       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11547         preserve_dates = 1;
11548     }
11549     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
11550       preserve_dates =0;      /* bitmask from this point forward   */
11551
11552     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11553     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11554       PerlMem_free(vmsin);
11555       PerlMem_free(vmsout);
11556       PerlMem_free(esa);
11557       PerlMem_free(rsa);
11558       PerlMem_free(esa_out);
11559       set_vaxc_errno(sts);
11560       switch (sts) {
11561         case RMS$_DNF:
11562           set_errno(ENOENT); break;
11563         case RMS$_DIR:
11564           set_errno(ENOTDIR); break;
11565         case RMS$_DEV:
11566           set_errno(ENODEV); break;
11567         case RMS$_SYN:
11568           set_errno(EINVAL); break;
11569         case RMS$_PRV:
11570           set_errno(EACCES); break;
11571         default:
11572           set_errno(EVMSERR);
11573       }
11574       return 0;
11575     }
11576     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
11577     if (preserve_dates & 2) {
11578       /* sys$close() will process xabrdt, not xabdat */
11579       xabrdt = cc$rms_xabrdt;
11580 #ifndef __GNUC__
11581       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11582 #else
11583       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11584        * is unsigned long[2], while DECC & VAXC use a struct */
11585       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11586 #endif
11587       fab_out.fab$l_xab = (void *) &xabrdt;
11588     }
11589
11590     ubf = PerlMem_malloc(32256);
11591     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11592     rab_in = cc$rms_rab;
11593     rab_in.rab$l_fab = &fab_in;
11594     rab_in.rab$l_rop = RAB$M_BIO;
11595     rab_in.rab$l_ubf = ubf;
11596     rab_in.rab$w_usz = 32256;
11597     if (!((sts = sys$connect(&rab_in)) & 1)) {
11598       sys$close(&fab_in); sys$close(&fab_out);
11599       PerlMem_free(vmsin);
11600       PerlMem_free(vmsout);
11601       PerlMem_free(esa);
11602       PerlMem_free(ubf);
11603       PerlMem_free(rsa);
11604       PerlMem_free(esa_out);
11605       set_errno(EVMSERR); set_vaxc_errno(sts);
11606       return 0;
11607     }
11608
11609     rab_out = cc$rms_rab;
11610     rab_out.rab$l_fab = &fab_out;
11611     rab_out.rab$l_rbf = ubf;
11612     if (!((sts = sys$connect(&rab_out)) & 1)) {
11613       sys$close(&fab_in); sys$close(&fab_out);
11614       PerlMem_free(vmsin);
11615       PerlMem_free(vmsout);
11616       PerlMem_free(esa);
11617       PerlMem_free(ubf);
11618       PerlMem_free(rsa);
11619       PerlMem_free(esa_out);
11620       set_errno(EVMSERR); set_vaxc_errno(sts);
11621       return 0;
11622     }
11623
11624     while ((sts = sys$read(&rab_in))) {  /* always true  */
11625       if (sts == RMS$_EOF) break;
11626       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11627       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11628         sys$close(&fab_in); sys$close(&fab_out);
11629         PerlMem_free(vmsin);
11630         PerlMem_free(vmsout);
11631         PerlMem_free(esa);
11632         PerlMem_free(ubf);
11633         PerlMem_free(rsa);
11634         PerlMem_free(esa_out);
11635         set_errno(EVMSERR); set_vaxc_errno(sts);
11636         return 0;
11637       }
11638     }
11639
11640
11641     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
11642     sys$close(&fab_in);  sys$close(&fab_out);
11643     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11644     if (!(sts & 1)) {
11645       PerlMem_free(vmsin);
11646       PerlMem_free(vmsout);
11647       PerlMem_free(esa);
11648       PerlMem_free(ubf);
11649       PerlMem_free(rsa);
11650       PerlMem_free(esa_out);
11651       set_errno(EVMSERR); set_vaxc_errno(sts);
11652       return 0;
11653     }
11654
11655     PerlMem_free(vmsin);
11656     PerlMem_free(vmsout);
11657     PerlMem_free(esa);
11658     PerlMem_free(ubf);
11659     PerlMem_free(rsa);
11660     PerlMem_free(esa_out);
11661     return 1;
11662
11663 }  /* end of rmscopy() */
11664 /*}}}*/
11665
11666
11667 /***  The following glue provides 'hooks' to make some of the routines
11668  * from this file available from Perl.  These routines are sufficiently
11669  * basic, and are required sufficiently early in the build process,
11670  * that's it's nice to have them available to miniperl as well as the
11671  * full Perl, so they're set up here instead of in an extension.  The
11672  * Perl code which handles importation of these names into a given
11673  * package lives in [.VMS]Filespec.pm in @INC.
11674  */
11675
11676 void
11677 rmsexpand_fromperl(pTHX_ CV *cv)
11678 {
11679   dXSARGS;
11680   char *fspec, *defspec = NULL, *rslt;
11681   STRLEN n_a;
11682   int fs_utf8, dfs_utf8;
11683
11684   fs_utf8 = 0;
11685   dfs_utf8 = 0;
11686   if (!items || items > 2)
11687     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11688   fspec = SvPV(ST(0),n_a);
11689   fs_utf8 = SvUTF8(ST(0));
11690   if (!fspec || !*fspec) XSRETURN_UNDEF;
11691   if (items == 2) {
11692     defspec = SvPV(ST(1),n_a);
11693     dfs_utf8 = SvUTF8(ST(1));
11694   }
11695   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11696   ST(0) = sv_newmortal();
11697   if (rslt != NULL) {
11698     sv_usepvn(ST(0),rslt,strlen(rslt));
11699     if (fs_utf8) {
11700         SvUTF8_on(ST(0));
11701     }
11702   }
11703   XSRETURN(1);
11704 }
11705
11706 void
11707 vmsify_fromperl(pTHX_ CV *cv)
11708 {
11709   dXSARGS;
11710   char *vmsified;
11711   STRLEN n_a;
11712   int utf8_fl;
11713
11714   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11715   utf8_fl = SvUTF8(ST(0));
11716   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11717   ST(0) = sv_newmortal();
11718   if (vmsified != NULL) {
11719     sv_usepvn(ST(0),vmsified,strlen(vmsified));
11720     if (utf8_fl) {
11721         SvUTF8_on(ST(0));
11722     }
11723   }
11724   XSRETURN(1);
11725 }
11726
11727 void
11728 unixify_fromperl(pTHX_ CV *cv)
11729 {
11730   dXSARGS;
11731   char *unixified;
11732   STRLEN n_a;
11733   int utf8_fl;
11734
11735   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11736   utf8_fl = SvUTF8(ST(0));
11737   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11738   ST(0) = sv_newmortal();
11739   if (unixified != NULL) {
11740     sv_usepvn(ST(0),unixified,strlen(unixified));
11741     if (utf8_fl) {
11742         SvUTF8_on(ST(0));
11743     }
11744   }
11745   XSRETURN(1);
11746 }
11747
11748 void
11749 fileify_fromperl(pTHX_ CV *cv)
11750 {
11751   dXSARGS;
11752   char *fileified;
11753   STRLEN n_a;
11754   int utf8_fl;
11755
11756   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11757   utf8_fl = SvUTF8(ST(0));
11758   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11759   ST(0) = sv_newmortal();
11760   if (fileified != NULL) {
11761     sv_usepvn(ST(0),fileified,strlen(fileified));
11762     if (utf8_fl) {
11763         SvUTF8_on(ST(0));
11764     }
11765   }
11766   XSRETURN(1);
11767 }
11768
11769 void
11770 pathify_fromperl(pTHX_ CV *cv)
11771 {
11772   dXSARGS;
11773   char *pathified;
11774   STRLEN n_a;
11775   int utf8_fl;
11776
11777   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11778   utf8_fl = SvUTF8(ST(0));
11779   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11780   ST(0) = sv_newmortal();
11781   if (pathified != NULL) {
11782     sv_usepvn(ST(0),pathified,strlen(pathified));
11783     if (utf8_fl) {
11784         SvUTF8_on(ST(0));
11785     }
11786   }
11787   XSRETURN(1);
11788 }
11789
11790 void
11791 vmspath_fromperl(pTHX_ CV *cv)
11792 {
11793   dXSARGS;
11794   char *vmspath;
11795   STRLEN n_a;
11796   int utf8_fl;
11797
11798   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11799   utf8_fl = SvUTF8(ST(0));
11800   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11801   ST(0) = sv_newmortal();
11802   if (vmspath != NULL) {
11803     sv_usepvn(ST(0),vmspath,strlen(vmspath));
11804     if (utf8_fl) {
11805         SvUTF8_on(ST(0));
11806     }
11807   }
11808   XSRETURN(1);
11809 }
11810
11811 void
11812 unixpath_fromperl(pTHX_ CV *cv)
11813 {
11814   dXSARGS;
11815   char *unixpath;
11816   STRLEN n_a;
11817   int utf8_fl;
11818
11819   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11820   utf8_fl = SvUTF8(ST(0));
11821   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11822   ST(0) = sv_newmortal();
11823   if (unixpath != NULL) {
11824     sv_usepvn(ST(0),unixpath,strlen(unixpath));
11825     if (utf8_fl) {
11826         SvUTF8_on(ST(0));
11827     }
11828   }
11829   XSRETURN(1);
11830 }
11831
11832 void
11833 candelete_fromperl(pTHX_ CV *cv)
11834 {
11835   dXSARGS;
11836   char *fspec, *fsp;
11837   SV *mysv;
11838   IO *io;
11839   STRLEN n_a;
11840
11841   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11842
11843   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11844   Newx(fspec, VMS_MAXRSS, char);
11845   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11846   if (SvTYPE(mysv) == SVt_PVGV) {
11847     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11848       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11849       ST(0) = &PL_sv_no;
11850       Safefree(fspec);
11851       XSRETURN(1);
11852     }
11853     fsp = fspec;
11854   }
11855   else {
11856     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11857       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11858       ST(0) = &PL_sv_no;
11859       Safefree(fspec);
11860       XSRETURN(1);
11861     }
11862   }
11863
11864   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11865   Safefree(fspec);
11866   XSRETURN(1);
11867 }
11868
11869 void
11870 rmscopy_fromperl(pTHX_ CV *cv)
11871 {
11872   dXSARGS;
11873   char *inspec, *outspec, *inp, *outp;
11874   int date_flag;
11875   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11876                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11877   unsigned long int sts;
11878   SV *mysv;
11879   IO *io;
11880   STRLEN n_a;
11881
11882   if (items < 2 || items > 3)
11883     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11884
11885   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11886   Newx(inspec, VMS_MAXRSS, char);
11887   if (SvTYPE(mysv) == SVt_PVGV) {
11888     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11889       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11890       ST(0) = &PL_sv_no;
11891       Safefree(inspec);
11892       XSRETURN(1);
11893     }
11894     inp = inspec;
11895   }
11896   else {
11897     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11898       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11899       ST(0) = &PL_sv_no;
11900       Safefree(inspec);
11901       XSRETURN(1);
11902     }
11903   }
11904   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11905   Newx(outspec, VMS_MAXRSS, char);
11906   if (SvTYPE(mysv) == SVt_PVGV) {
11907     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11908       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11909       ST(0) = &PL_sv_no;
11910       Safefree(inspec);
11911       Safefree(outspec);
11912       XSRETURN(1);
11913     }
11914     outp = outspec;
11915   }
11916   else {
11917     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11918       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11919       ST(0) = &PL_sv_no;
11920       Safefree(inspec);
11921       Safefree(outspec);
11922       XSRETURN(1);
11923     }
11924   }
11925   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11926
11927   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11928   Safefree(inspec);
11929   Safefree(outspec);
11930   XSRETURN(1);
11931 }
11932
11933 /* The mod2fname is limited to shorter filenames by design, so it should
11934  * not be modified to support longer EFS pathnames
11935  */
11936 void
11937 mod2fname(pTHX_ CV *cv)
11938 {
11939   dXSARGS;
11940   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11941        workbuff[NAM$C_MAXRSS*1 + 1];
11942   int total_namelen = 3, counter, num_entries;
11943   /* ODS-5 ups this, but we want to be consistent, so... */
11944   int max_name_len = 39;
11945   AV *in_array = (AV *)SvRV(ST(0));
11946
11947   num_entries = av_len(in_array);
11948
11949   /* All the names start with PL_. */
11950   strcpy(ultimate_name, "PL_");
11951
11952   /* Clean up our working buffer */
11953   Zero(work_name, sizeof(work_name), char);
11954
11955   /* Run through the entries and build up a working name */
11956   for(counter = 0; counter <= num_entries; counter++) {
11957     /* If it's not the first name then tack on a __ */
11958     if (counter) {
11959       strcat(work_name, "__");
11960     }
11961     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11962                            PL_na));
11963   }
11964
11965   /* Check to see if we actually have to bother...*/
11966   if (strlen(work_name) + 3 <= max_name_len) {
11967     strcat(ultimate_name, work_name);
11968   } else {
11969     /* It's too darned big, so we need to go strip. We use the same */
11970     /* algorithm as xsubpp does. First, strip out doubled __ */
11971     char *source, *dest, last;
11972     dest = workbuff;
11973     last = 0;
11974     for (source = work_name; *source; source++) {
11975       if (last == *source && last == '_') {
11976         continue;
11977       }
11978       *dest++ = *source;
11979       last = *source;
11980     }
11981     /* Go put it back */
11982     strcpy(work_name, workbuff);
11983     /* Is it still too big? */
11984     if (strlen(work_name) + 3 > max_name_len) {
11985       /* Strip duplicate letters */
11986       last = 0;
11987       dest = workbuff;
11988       for (source = work_name; *source; source++) {
11989         if (last == toupper(*source)) {
11990         continue;
11991         }
11992         *dest++ = *source;
11993         last = toupper(*source);
11994       }
11995       strcpy(work_name, workbuff);
11996     }
11997
11998     /* Is it *still* too big? */
11999     if (strlen(work_name) + 3 > max_name_len) {
12000       /* Too bad, we truncate */
12001       work_name[max_name_len - 2] = 0;
12002     }
12003     strcat(ultimate_name, work_name);
12004   }
12005
12006   /* Okay, return it */
12007   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12008   XSRETURN(1);
12009 }
12010
12011 void
12012 hushexit_fromperl(pTHX_ CV *cv)
12013 {
12014     dXSARGS;
12015
12016     if (items > 0) {
12017         VMSISH_HUSHED = SvTRUE(ST(0));
12018     }
12019     ST(0) = boolSV(VMSISH_HUSHED);
12020     XSRETURN(1);
12021 }
12022
12023
12024 PerlIO *
12025 Perl_vms_start_glob
12026    (pTHX_ SV *tmpglob,
12027     IO *io)
12028 {
12029     PerlIO *fp;
12030     struct vs_str_st *rslt;
12031     char *vmsspec;
12032     char *rstr;
12033     char *begin, *cp;
12034     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12035     PerlIO *tmpfp;
12036     STRLEN i;
12037     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12038     struct dsc$descriptor_vs rsdsc;
12039     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12040     unsigned long hasver = 0, isunix = 0;
12041     unsigned long int lff_flags = 0;
12042     int rms_sts;
12043
12044 #ifdef VMS_LONGNAME_SUPPORT
12045     lff_flags = LIB$M_FIL_LONG_NAMES;
12046 #endif
12047     /* The Newx macro will not allow me to assign a smaller array
12048      * to the rslt pointer, so we will assign it to the begin char pointer
12049      * and then copy the value into the rslt pointer.
12050      */
12051     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12052     rslt = (struct vs_str_st *)begin;
12053     rslt->length = 0;
12054     rstr = &rslt->str[0];
12055     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12056     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12057     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12058     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12059
12060     Newx(vmsspec, VMS_MAXRSS, char);
12061
12062         /* We could find out if there's an explicit dev/dir or version
12063            by peeking into lib$find_file's internal context at
12064            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12065            but that's unsupported, so I don't want to do it now and
12066            have it bite someone in the future. */
12067         /* Fix-me: vms_split_path() is the only way to do this, the
12068            existing method will fail with many legal EFS or UNIX specifications
12069          */
12070
12071     cp = SvPV(tmpglob,i);
12072
12073     for (; i; i--) {
12074         if (cp[i] == ';') hasver = 1;
12075         if (cp[i] == '.') {
12076             if (sts) hasver = 1;
12077             else sts = 1;
12078         }
12079         if (cp[i] == '/') {
12080             hasdir = isunix = 1;
12081             break;
12082         }
12083         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12084             hasdir = 1;
12085             break;
12086         }
12087     }
12088     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12089         int found = 0;
12090         Stat_t st;
12091         int stat_sts;
12092         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12093         if (!stat_sts && S_ISDIR(st.st_mode)) {
12094             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12095             ok = (wilddsc.dsc$a_pointer != NULL);
12096             /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12097             hasdir = 1;
12098         }
12099         else {
12100             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12101             ok = (wilddsc.dsc$a_pointer != NULL);
12102         }
12103         if (ok)
12104             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12105
12106         /* If not extended character set, replace ? with % */
12107         /* With extended character set, ? is a wildcard single character */
12108         if (!decc_efs_case_preserve) {
12109             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12110                 if (*cp == '?') *cp = '%';
12111         }
12112         sts = SS$_NORMAL;
12113         while (ok && $VMS_STATUS_SUCCESS(sts)) {
12114          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12115          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12116
12117             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12118                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
12119             if (!$VMS_STATUS_SUCCESS(sts))
12120                 break;
12121
12122             found++;
12123
12124             /* with varying string, 1st word of buffer contains result length */
12125             rstr[rslt->length] = '\0';
12126
12127              /* Find where all the components are */
12128              v_sts = vms_split_path
12129                        (rstr,
12130                         &v_spec,
12131                         &v_len,
12132                         &r_spec,
12133                         &r_len,
12134                         &d_spec,
12135                         &d_len,
12136                         &n_spec,
12137                         &n_len,
12138                         &e_spec,
12139                         &e_len,
12140                         &vs_spec,
12141                         &vs_len);
12142
12143             /* If no version on input, truncate the version on output */
12144             if (!hasver && (vs_len > 0)) {
12145                 *vs_spec = '\0';
12146                 vs_len = 0;
12147
12148                 /* No version & a null extension on UNIX handling */
12149                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12150                     e_len = 0;
12151                     *e_spec = '\0';
12152                 }
12153             }
12154
12155             if (!decc_efs_case_preserve) {
12156                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12157             }
12158
12159             if (hasdir) {
12160                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12161                 begin = rstr;
12162             }
12163             else {
12164                 /* Start with the name */
12165                 begin = n_spec;
12166             }
12167             strcat(begin,"\n");
12168             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12169         }
12170         if (cxt) (void)lib$find_file_end(&cxt);
12171
12172         if (!found) {
12173             /* Be POSIXish: return the input pattern when no matches */
12174             begin = SvPVX(tmpglob);
12175             strcat(begin,"\n");
12176             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12177         }
12178
12179         if (ok && sts != RMS$_NMF &&
12180             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12181         if (!ok) {
12182             if (!(sts & 1)) {
12183                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12184             }
12185             PerlIO_close(tmpfp);
12186             fp = NULL;
12187         }
12188         else {
12189             PerlIO_rewind(tmpfp);
12190             IoTYPE(io) = IoTYPE_RDONLY;
12191             IoIFP(io) = fp = tmpfp;
12192             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
12193         }
12194     }
12195     Safefree(vmsspec);
12196     Safefree(rslt);
12197     return fp;
12198 }
12199
12200
12201 #ifdef HAS_SYMLINK
12202 static char *
12203 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
12204                    const int *utf8_fl);
12205
12206 void
12207 vms_realpath_fromperl(pTHX_ CV *cv)
12208 {
12209   dXSARGS;
12210   char *fspec, *rslt_spec, *rslt;
12211   STRLEN n_a;
12212
12213   if (!items || items != 1)
12214     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12215
12216   fspec = SvPV(ST(0),n_a);
12217   if (!fspec || !*fspec) XSRETURN_UNDEF;
12218
12219   Newx(rslt_spec, VMS_MAXRSS + 1, char);
12220   rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12221   ST(0) = sv_newmortal();
12222   if (rslt != NULL)
12223     sv_usepvn(ST(0),rslt,strlen(rslt));
12224   else
12225     Safefree(rslt_spec);
12226   XSRETURN(1);
12227 }
12228 #endif
12229
12230 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12231 int do_vms_case_tolerant(void);
12232
12233 void
12234 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12235 {
12236   dXSARGS;
12237   ST(0) = boolSV(do_vms_case_tolerant());
12238   XSRETURN(1);
12239 }
12240 #endif
12241
12242 void
12243 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12244                           struct interp_intern *dst)
12245 {
12246     memcpy(dst,src,sizeof(struct interp_intern));
12247 }
12248
12249 void
12250 Perl_sys_intern_clear(pTHX)
12251 {
12252 }
12253
12254 void
12255 Perl_sys_intern_init(pTHX)
12256 {
12257     unsigned int ix = RAND_MAX;
12258     double x;
12259
12260     VMSISH_HUSHED = 0;
12261
12262     /* fix me later to track running under GNV */
12263     /* this allows some limited testing */
12264     MY_POSIX_EXIT = decc_filename_unix_report;
12265
12266     x = (float)ix;
12267     MY_INV_RAND_MAX = 1./x;
12268 }
12269
12270 void
12271 init_os_extras(void)
12272 {
12273   dTHX;
12274   char* file = __FILE__;
12275   if (decc_disable_to_vms_logname_translation) {
12276     no_translate_barewords = TRUE;
12277   } else {
12278     no_translate_barewords = FALSE;
12279   }
12280
12281   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
12282   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
12283   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
12284   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
12285   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
12286   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
12287   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
12288   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
12289   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
12290   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
12291   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
12292 #ifdef HAS_SYMLINK
12293   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
12294 #endif
12295 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12296   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
12297 #endif
12298
12299   store_pipelocs(aTHX);         /* will redo any earlier attempts */
12300
12301   return;
12302 }
12303
12304 #ifdef HAS_SYMLINK
12305
12306 #if __CRTL_VER == 80200000
12307 /* This missed getting in to the DECC SDK for 8.2 */
12308 char *realpath(const char *file_name, char * resolved_name, ...);
12309 #endif
12310
12311 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
12312 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
12313  * The perl fallback routine to provide realpath() is not as efficient
12314  * on OpenVMS.
12315  */
12316 static char *
12317 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
12318                    const int *utf8_fl)
12319 {
12320     return realpath(filespec, outbuf);
12321 }
12322
12323 /*}}}*/
12324 /* External entry points */
12325 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12326 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
12327 #else
12328 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12329 { return NULL; }
12330 #endif
12331
12332
12333 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12334 /* case_tolerant */
12335
12336 /*{{{int do_vms_case_tolerant(void)*/
12337 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
12338  * controlled by a process setting.
12339  */
12340 int do_vms_case_tolerant(void)
12341 {
12342     return vms_process_case_tolerant;
12343 }
12344 /*}}}*/
12345 /* External entry points */
12346 int Perl_vms_case_tolerant(void)
12347 { return do_vms_case_tolerant(); }
12348 #else
12349 int Perl_vms_case_tolerant(void)
12350 { return vms_process_case_tolerant; }
12351 #endif
12352
12353
12354  /* Start of DECC RTL Feature handling */
12355
12356 static int sys_trnlnm
12357    (const char * logname,
12358     char * value,
12359     int value_len)
12360 {
12361     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
12362     const unsigned long attr = LNM$M_CASE_BLIND;
12363     struct dsc$descriptor_s name_dsc;
12364     int status;
12365     unsigned short result;
12366     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
12367                                 {0, 0, 0, 0}};
12368
12369     name_dsc.dsc$w_length = strlen(logname);
12370     name_dsc.dsc$a_pointer = (char *)logname;
12371     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12372     name_dsc.dsc$b_class = DSC$K_CLASS_S;
12373
12374     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
12375
12376     if ($VMS_STATUS_SUCCESS(status)) {
12377
12378          /* Null terminate and return the string */
12379         /*--------------------------------------*/
12380         value[result] = 0;
12381     }
12382
12383     return status;
12384 }
12385
12386 static int sys_crelnm
12387    (const char * logname,
12388     const char * value)
12389 {
12390     int ret_val;
12391     const char * proc_table = "LNM$PROCESS_TABLE";
12392     struct dsc$descriptor_s proc_table_dsc;
12393     struct dsc$descriptor_s logname_dsc;
12394     struct itmlst_3 item_list[2];
12395
12396     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
12397     proc_table_dsc.dsc$w_length = strlen(proc_table);
12398     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12399     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
12400
12401     logname_dsc.dsc$a_pointer = (char *) logname;
12402     logname_dsc.dsc$w_length = strlen(logname);
12403     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12404     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
12405
12406     item_list[0].buflen = strlen(value);
12407     item_list[0].itmcode = LNM$_STRING;
12408     item_list[0].bufadr = (char *)value;
12409     item_list[0].retlen = NULL;
12410
12411     item_list[1].buflen = 0;
12412     item_list[1].itmcode = 0;
12413
12414     ret_val = sys$crelnm
12415                        (NULL,
12416                         (const struct dsc$descriptor_s *)&proc_table_dsc,
12417                         (const struct dsc$descriptor_s *)&logname_dsc,
12418                         NULL,
12419                         (const struct item_list_3 *) item_list);
12420
12421     return ret_val;
12422 }
12423
12424 /* C RTL Feature settings */
12425
12426 static int set_features
12427    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
12428     int (* cli_routine)(void),  /* Not documented */
12429     void *image_info)           /* Not documented */
12430 {
12431     int status;
12432     int s;
12433     int dflt;
12434     char* str;
12435     char val_str[10];
12436 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12437     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12438     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12439     unsigned long case_perm;
12440     unsigned long case_image;
12441 #endif
12442
12443     /* Allow an exception to bring Perl into the VMS debugger */
12444     vms_debug_on_exception = 0;
12445     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12446     if ($VMS_STATUS_SUCCESS(status)) {
12447        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12448          vms_debug_on_exception = 1;
12449        else
12450          vms_debug_on_exception = 0;
12451     }
12452
12453     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
12454     vms_vtf7_filenames = 0;
12455     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12456     if ($VMS_STATUS_SUCCESS(status)) {
12457        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12458          vms_vtf7_filenames = 1;
12459        else
12460          vms_vtf7_filenames = 0;
12461     }
12462
12463     /* Dectect running under GNV Bash or other UNIX like shell */
12464 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12465     gnv_unix_shell = 0;
12466     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12467     if ($VMS_STATUS_SUCCESS(status)) {
12468        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12469          gnv_unix_shell = 1;
12470          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12471          set_feature_default("DECC$EFS_CHARSET", 1);
12472          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12473          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12474          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12475          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12476        }
12477        else
12478          gnv_unix_shell = 0;
12479     }
12480 #endif
12481
12482     /* hacks to see if known bugs are still present for testing */
12483
12484     /* Readdir is returning filenames in VMS syntax always */
12485     decc_bug_readdir_efs1 = 1;
12486     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12487     if ($VMS_STATUS_SUCCESS(status)) {
12488        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12489          decc_bug_readdir_efs1 = 1;
12490        else
12491          decc_bug_readdir_efs1 = 0;
12492     }
12493
12494     /* PCP mode requires creating /dev/null special device file */
12495     decc_bug_devnull = 0;
12496     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12497     if ($VMS_STATUS_SUCCESS(status)) {
12498        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12499           decc_bug_devnull = 1;
12500        else
12501           decc_bug_devnull = 0;
12502     }
12503
12504     /* fgetname returning a VMS name in UNIX mode */
12505     decc_bug_fgetname = 1;
12506     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12507     if ($VMS_STATUS_SUCCESS(status)) {
12508       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12509         decc_bug_fgetname = 1;
12510       else
12511         decc_bug_fgetname = 0;
12512     }
12513
12514     /* UNIX directory names with no paths are broken in a lot of places */
12515     decc_dir_barename = 1;
12516     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12517     if ($VMS_STATUS_SUCCESS(status)) {
12518       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12519         decc_dir_barename = 1;
12520       else
12521         decc_dir_barename = 0;
12522     }
12523
12524 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12525     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12526     if (s >= 0) {
12527         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12528         if (decc_disable_to_vms_logname_translation < 0)
12529             decc_disable_to_vms_logname_translation = 0;
12530     }
12531
12532     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12533     if (s >= 0) {
12534         decc_efs_case_preserve = decc$feature_get_value(s, 1);
12535         if (decc_efs_case_preserve < 0)
12536             decc_efs_case_preserve = 0;
12537     }
12538
12539     s = decc$feature_get_index("DECC$EFS_CHARSET");
12540     if (s >= 0) {
12541         decc_efs_charset = decc$feature_get_value(s, 1);
12542         if (decc_efs_charset < 0)
12543             decc_efs_charset = 0;
12544     }
12545
12546     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12547     if (s >= 0) {
12548         decc_filename_unix_report = decc$feature_get_value(s, 1);
12549         if (decc_filename_unix_report > 0)
12550             decc_filename_unix_report = 1;
12551         else
12552             decc_filename_unix_report = 0;
12553     }
12554
12555     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12556     if (s >= 0) {
12557         decc_filename_unix_only = decc$feature_get_value(s, 1);
12558         if (decc_filename_unix_only > 0) {
12559             decc_filename_unix_only = 1;
12560         }
12561         else {
12562             decc_filename_unix_only = 0;
12563         }
12564     }
12565
12566     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12567     if (s >= 0) {
12568         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12569         if (decc_filename_unix_no_version < 0)
12570             decc_filename_unix_no_version = 0;
12571     }
12572
12573     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12574     if (s >= 0) {
12575         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12576         if (decc_readdir_dropdotnotype < 0)
12577             decc_readdir_dropdotnotype = 0;
12578     }
12579
12580     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12581     if ($VMS_STATUS_SUCCESS(status)) {
12582         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12583         if (s >= 0) {
12584             dflt = decc$feature_get_value(s, 4);
12585             if (dflt > 0) {
12586                 decc_disable_posix_root = decc$feature_get_value(s, 1);
12587                 if (decc_disable_posix_root <= 0) {
12588                     decc$feature_set_value(s, 1, 1);
12589                     decc_disable_posix_root = 1;
12590                 }
12591             }
12592             else {
12593                 /* Traditionally Perl assumes this is off */
12594                 decc_disable_posix_root = 1;
12595                 decc$feature_set_value(s, 1, 1);
12596             }
12597         }
12598     }
12599
12600 #if __CRTL_VER >= 80200000
12601     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12602     if (s >= 0) {
12603         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12604         if (decc_posix_compliant_pathnames < 0)
12605             decc_posix_compliant_pathnames = 0;
12606         if (decc_posix_compliant_pathnames > 4)
12607             decc_posix_compliant_pathnames = 0;
12608     }
12609
12610 #endif
12611 #else
12612     status = sys_trnlnm
12613         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12614     if ($VMS_STATUS_SUCCESS(status)) {
12615         val_str[0] = _toupper(val_str[0]);
12616         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12617            decc_disable_to_vms_logname_translation = 1;
12618         }
12619     }
12620
12621 #ifndef __VAX
12622     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12623     if ($VMS_STATUS_SUCCESS(status)) {
12624         val_str[0] = _toupper(val_str[0]);
12625         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12626            decc_efs_case_preserve = 1;
12627         }
12628     }
12629 #endif
12630
12631     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12632     if ($VMS_STATUS_SUCCESS(status)) {
12633         val_str[0] = _toupper(val_str[0]);
12634         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12635            decc_filename_unix_report = 1;
12636         }
12637     }
12638     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12639     if ($VMS_STATUS_SUCCESS(status)) {
12640         val_str[0] = _toupper(val_str[0]);
12641         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12642            decc_filename_unix_only = 1;
12643            decc_filename_unix_report = 1;
12644         }
12645     }
12646     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12647     if ($VMS_STATUS_SUCCESS(status)) {
12648         val_str[0] = _toupper(val_str[0]);
12649         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12650            decc_filename_unix_no_version = 1;
12651         }
12652     }
12653     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12654     if ($VMS_STATUS_SUCCESS(status)) {
12655         val_str[0] = _toupper(val_str[0]);
12656         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12657            decc_readdir_dropdotnotype = 1;
12658         }
12659     }
12660 #endif
12661
12662 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12663
12664      /* Report true case tolerance */
12665     /*----------------------------*/
12666     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12667     if (!$VMS_STATUS_SUCCESS(status))
12668         case_perm = PPROP$K_CASE_BLIND;
12669     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12670     if (!$VMS_STATUS_SUCCESS(status))
12671         case_image = PPROP$K_CASE_BLIND;
12672     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12673         (case_image == PPROP$K_CASE_SENSITIVE))
12674         vms_process_case_tolerant = 0;
12675
12676 #endif
12677
12678
12679     /* CRTL can be initialized past this point, but not before. */
12680 /*    DECC$CRTL_INIT(); */
12681
12682     return SS$_NORMAL;
12683 }
12684
12685 #ifdef __DECC
12686 #pragma nostandard
12687 #pragma extern_model save
12688 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12689         const __align (LONGWORD) int spare[8] = {0};
12690
12691 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
12692 #if __DECC_VER >= 60560002
12693 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
12694 #else
12695 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
12696 #endif
12697 #endif /* __DECC */
12698
12699 const long vms_cc_features = (const long)set_features;
12700
12701 /*
12702 ** Force a reference to LIB$INITIALIZE to ensure it
12703 ** exists in the image.
12704 */
12705 int lib$initialize(void);
12706 #ifdef __DECC
12707 #pragma extern_model strict_refdef
12708 #endif
12709     int lib_init_ref = (int) lib$initialize;
12710
12711 #ifdef __DECC
12712 #pragma extern_model restore
12713 #pragma standard
12714 #endif
12715
12716 /*  End of vms.c */