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 static int vms_unlink_all_versions = 0;
 291
 292 /* bug workarounds if needed */
 293 int decc_bug_readdir_efs1 = 0;
 294 int decc_bug_devnull = 1;
 295 int decc_bug_fgetname = 0;
 296 int decc_dir_barename = 0;
 297
 298 static int vms_debug_on_exception = 0;
 299
 300 /* Is this a UNIX file specification?
 301  *   No longer a simple check with EFS file specs
 302  *   For now, not a full check, but need to
 303  *   handle POSIX ^UP^ specifications
 304  *   Fixing to handle ^/ cases would require
 305  *   changes to many other conversion routines.
 306  */
 307
 308 static int is_unix_filespec(const char *path)
 309 {
 310 int ret_val;
 311 const char * pch1;
 312
 313     ret_val = 0;
 314     if (strncmp(path,"\"^UP^",5) != 0) {
 315         pch1 = strchr(path, '/');
 316         if (pch1 != NULL)
 317             ret_val = 1;
 318         else {
 319
 320             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 321             if (decc_filename_unix_report || decc_filename_unix_only) {
 322             if (strcmp(path,".") == 0)
 323                 ret_val = 1;
 324             }
 325         }
 326     }
 327     return ret_val;
 328 }
 329
 330 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 331  */
 332
 333 static void ucs2_to_vtf7
 334    (char *outspec,
 335     unsigned long ucs2_char,
 336     int * output_cnt)
 337 {
 338 unsigned char * ucs_ptr;
 339 int hex;
 340
 341     ucs_ptr = (unsigned char *)&ucs2_char;
 342
 343     outspec[0] = '^';
 344     outspec[1] = 'U';
 345     hex = (ucs_ptr[1] >> 4) & 0xf;
 346     if (hex < 0xA)
 347         outspec[2] = hex + '0';
 348     else
 349         outspec[2] = (hex - 9) + 'A';
 350     hex = ucs_ptr[1] & 0xF;
 351     if (hex < 0xA)
 352         outspec[3] = hex + '0';
 353     else {
 354         outspec[3] = (hex - 9) + 'A';
 355     }
 356     hex = (ucs_ptr[0] >> 4) & 0xf;
 357     if (hex < 0xA)
 358         outspec[4] = hex + '0';
 359     else
 360         outspec[4] = (hex - 9) + 'A';
 361     hex = ucs_ptr[1] & 0xF;
 362     if (hex < 0xA)
 363         outspec[5] = hex + '0';
 364     else {
 365         outspec[5] = (hex - 9) + 'A';
 366     }
 367     *output_cnt = 6;
 368 }
 369
 370
 371 /* This handles the conversion of a UNIX extended character set to a ^
 372  * escaped VMS character.
 373  * in a UNIX file specification.
 374  *
 375  * The output count variable contains the number of characters added
 376  * to the output string.
 377  *
 378  * The return value is the number of characters read from the input string
 379  */
 380 static int copy_expand_unix_filename_escape
 381   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 382 {
 383 int count;
 384 int scnt;
 385 int utf8_flag;
 386
 387     utf8_flag = 0;
 388     if (utf8_fl)
 389       utf8_flag = *utf8_fl;
 390
 391     count = 0;
 392     *output_cnt = 0;
 393     if (*inspec >= 0x80) {
 394         if (utf8_fl && vms_vtf7_filenames) {
 395         unsigned long ucs_char;
 396
 397             ucs_char = 0;
 398
 399             if ((*inspec & 0xE0) == 0xC0) {
 400                 /* 2 byte Unicode */
 401                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 402                 if (ucs_char >= 0x80) {
 403                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 404                     return 2;
 405                 }
 406             } else if ((*inspec & 0xF0) == 0xE0) {
 407                 /* 3 byte Unicode */
 408                 ucs_char = ((inspec[0] & 0xF) << 12) +
 409                    ((inspec[1] & 0x3f) << 6) +
 410                    (inspec[2] & 0x3f);
 411                 if (ucs_char >= 0x800) {
 412                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 413                     return 3;
 414                 }
 415
 416 #if 0 /* I do not see longer sequences supported by OpenVMS */
 417       /* Maybe some one can fix this later */
 418             } else if ((*inspec & 0xF8) == 0xF0) {
 419                 /* 4 byte Unicode */
 420                 /* UCS-4 to UCS-2 */
 421             } else if ((*inspec & 0xFC) == 0xF8) {
 422                 /* 5 byte Unicode */
 423                 /* UCS-4 to UCS-2 */
 424             } else if ((*inspec & 0xFE) == 0xFC) {
 425                 /* 6 byte Unicode */
 426                 /* UCS-4 to UCS-2 */
 427 #endif
 428             }
 429         }
 430
 431         /* High bit set, but not a Unicode character! */
 432
 433         /* Non printing DECMCS or ISO Latin-1 character? */
 434         if (*inspec <= 0x9F) {
 435         int hex;
 436             outspec[0] = '^';
 437             outspec++;
 438             hex = (*inspec >> 4) & 0xF;
 439             if (hex < 0xA)
 440                 outspec[1] = hex + '0';
 441             else {
 442                 outspec[1] = (hex - 9) + 'A';
 443             }
 444             hex = *inspec & 0xF;
 445             if (hex < 0xA)
 446                 outspec[2] = hex + '0';
 447             else {
 448                 outspec[2] = (hex - 9) + 'A';
 449             }
 450             *output_cnt = 3;
 451             return 1;
 452         } else if (*inspec == 0xA0) {
 453             outspec[0] = '^';
 454             outspec[1] = 'A';
 455             outspec[2] = '0';
 456             *output_cnt = 3;
 457             return 1;
 458         } else if (*inspec == 0xFF) {
 459             outspec[0] = '^';
 460             outspec[1] = 'F';
 461             outspec[2] = 'F';
 462             *output_cnt = 3;
 463             return 1;
 464         }
 465         *outspec = *inspec;
 466         *output_cnt = 1;
 467         return 1;
 468     }
 469
 470     /* Is this a macro that needs to be passed through?
 471      * Macros start with $( and an alpha character, followed
 472      * by a string of alpha numeric characters ending with a )
 473      * If this does not match, then encode it as ODS-5.
 474      */
 475     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 476     int tcnt;
 477
 478         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 479             tcnt = 3;
 480             outspec[0] = inspec[0];
 481             outspec[1] = inspec[1];
 482             outspec[2] = inspec[2];
 483
 484             while(isalnum(inspec[tcnt]) ||
 485                   (inspec[2] == '.') || (inspec[2] == '_')) {
 486                 outspec[tcnt] = inspec[tcnt];
 487                 tcnt++;
 488             }
 489             if (inspec[tcnt] == ')') {
 490                 outspec[tcnt] = inspec[tcnt];
 491                 tcnt++;
 492                 *output_cnt = tcnt;
 493                 return tcnt;
 494             }
 495         }
 496     }
 497
 498     switch (*inspec) {
 499     case 0x7f:
 500         outspec[0] = '^';
 501         outspec[1] = '7';
 502         outspec[2] = 'F';
 503         *output_cnt = 3;
 504         return 1;
 505         break;
 506     case '?':
 507         if (decc_efs_charset == 0)
 508           outspec[0] = '%';
 509         else
 510           outspec[0] = '?';
 511         *output_cnt = 1;
 512         return 1;
 513         break;
 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     case '^':
 533         /* Don't escape again if following character is
 534          * already something we escape.
 535          */
 536         if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
 537             *outspec = *inspec;
 538             *output_cnt = 1;
 539             return 1;
 540             break;
 541         }
 542         /* But otherwise fall through and escape it. */
 543     case '=':
 544         /* Assume that this is to be escaped */
 545         outspec[0] = '^';
 546         outspec[1] = *inspec;
 547         *output_cnt = 2;
 548         return 1;
 549         break;
 550     case ' ': /* space */
 551         /* Assume that this is to be escaped */
 552         outspec[0] = '^';
 553         outspec[1] = '_';
 554         *output_cnt = 2;
 555         return 1;
 556         break;
 557     default:
 558         *outspec = *inspec;
 559         *output_cnt = 1;
 560         return 1;
 561         break;
 562     }
 563 }
 564
 565
 566 /* This handles the expansion of a '^' prefix to the proper character
 567  * in a UNIX file specification.
 568  *
 569  * The output count variable contains the number of characters added
 570  * to the output string.
 571  *
 572  * The return value is the number of characters read from the input
 573  * string
 574  */
 575 static int copy_expand_vms_filename_escape
 576   (char *outspec, const char *inspec, int *output_cnt)
 577 {
 578 int count;
 579 int scnt;
 580
 581     count = 0;
 582     *output_cnt = 0;
 583     if (*inspec == '^') {
 584         inspec++;
 585         switch (*inspec) {
 586         /* Spaces and non-trailing dots should just be passed through,
 587          * but eat the escape character.
 588          */
 589         case '.':
 590             *outspec = *inspec;
 591             count += 2;
 592             (*output_cnt)++;
 593             break;
 594         case '_': /* space */
 595             *outspec = ' ';
 596             count += 2;
 597             (*output_cnt)++;
 598             break;
 599         case '^':
 600             /* Hmm.  Better leave the escape escaped. */
 601             outspec[0] = '^';
 602             outspec[1] = '^';
 603             count += 2;
 604             (*output_cnt) += 2;
 605             break;
 606         case 'U': /* Unicode - FIX-ME this is wrong. */
 607             inspec++;
 608             count++;
 609             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 610             if (scnt == 4) {
 611                 unsigned int c1, c2;
 612                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 613                 outspec[0] == c1 & 0xff;
 614                 outspec[1] == c2 & 0xff;
 615                 if (scnt > 1) {
 616                     (*output_cnt) += 2;
 617                     count += 4;
 618                 }
 619             }
 620             else {
 621                 /* Error - do best we can to continue */
 622                 *outspec = 'U';
 623                 outspec++;
 624                 (*output_cnt++);
 625                 *outspec = *inspec;
 626                 count++;
 627                 (*output_cnt++);
 628             }
 629             break;
 630         default:
 631             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 632             if (scnt == 2) {
 633                 /* Hex encoded */
 634                 unsigned int c1;
 635                 scnt = sscanf(inspec, "%2x", &c1);
 636                 outspec[0] = c1 & 0xff;
 637                 if (scnt > 0) {
 638                     (*output_cnt++);
 639                     count += 2;
 640                 }
 641             }
 642             else {
 643                 *outspec = *inspec;
 644                 count++;
 645                 (*output_cnt++);
 646             }
 647         }
 648     }
 649     else {
 650         *outspec = *inspec;
 651         count++;
 652         (*output_cnt)++;
 653     }
 654     return count;
 655 }
 656
 657 #ifdef sys$filescan
 658 #undef sys$filescan
 659 int sys$filescan
 660    (const struct dsc$descriptor_s * srcstr,
 661     struct filescan_itmlst_2 * valuelist,
 662     unsigned long * fldflags,
 663     struct dsc$descriptor_s *auxout,
 664     unsigned short * retlen);
 665 #endif
 666
 667 /* vms_split_path - Verify that the input file specification is a
 668  * VMS format file specification, and provide pointers to the components of
 669  * it.  With EFS format filenames, this is virtually the only way to
 670  * parse a VMS path specification into components.
 671  *
 672  * If the sum of the components do not add up to the length of the
 673  * string, then the passed file specification is probably a UNIX style
 674  * path.
 675  */
 676 static int vms_split_path
 677    (const char * path,
 678     char * * volume,
 679     int * vol_len,
 680     char * * root,
 681     int * root_len,
 682     char * * dir,
 683     int * dir_len,
 684     char * * name,
 685     int * name_len,
 686     char * * ext,
 687     int * ext_len,
 688     char * * version,
 689     int * ver_len)
 690 {
 691 struct dsc$descriptor path_desc;
 692 int status;
 693 unsigned long flags;
 694 int ret_stat;
 695 struct filescan_itmlst_2 item_list[9];
 696 const int filespec = 0;
 697 const int nodespec = 1;
 698 const int devspec = 2;
 699 const int rootspec = 3;
 700 const int dirspec = 4;
 701 const int namespec = 5;
 702 const int typespec = 6;
 703 const int verspec = 7;
 704
 705     /* Assume the worst for an easy exit */
 706     ret_stat = -1;
 707     *volume = NULL;
 708     *vol_len = 0;
 709     *root = NULL;
 710     *root_len = 0;
 711     *dir = NULL;
 712     *dir_len;
 713     *name = NULL;
 714     *name_len = 0;
 715     *ext = NULL;
 716     *ext_len = 0;
 717     *version = NULL;
 718     *ver_len = 0;
 719
 720     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 721     path_desc.dsc$w_length = strlen(path);
 722     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 723     path_desc.dsc$b_class = DSC$K_CLASS_S;
 724
 725     /* Get the total length, if it is shorter than the string passed
 726      * then this was probably not a VMS formatted file specification
 727      */
 728     item_list[filespec].itmcode = FSCN$_FILESPEC;
 729     item_list[filespec].length = 0;
 730     item_list[filespec].component = NULL;
 731
 732     /* If the node is present, then it gets considered as part of the
 733      * volume name to hopefully make things simple.
 734      */
 735     item_list[nodespec].itmcode = FSCN$_NODE;
 736     item_list[nodespec].length = 0;
 737     item_list[nodespec].component = NULL;
 738
 739     item_list[devspec].itmcode = FSCN$_DEVICE;
 740     item_list[devspec].length = 0;
 741     item_list[devspec].component = NULL;
 742
 743     /* root is a special case,  adding it to either the directory or
 744      * the device components will probalby complicate things for the
 745      * callers of this routine, so leave it separate.
 746      */
 747     item_list[rootspec].itmcode = FSCN$_ROOT;
 748     item_list[rootspec].length = 0;
 749     item_list[rootspec].component = NULL;
 750
 751     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 752     item_list[dirspec].length = 0;
 753     item_list[dirspec].component = NULL;
 754
 755     item_list[namespec].itmcode = FSCN$_NAME;
 756     item_list[namespec].length = 0;
 757     item_list[namespec].component = NULL;
 758
 759     item_list[typespec].itmcode = FSCN$_TYPE;
 760     item_list[typespec].length = 0;
 761     item_list[typespec].component = NULL;
 762
 763     item_list[verspec].itmcode = FSCN$_VERSION;
 764     item_list[verspec].length = 0;
 765     item_list[verspec].component = NULL;
 766
 767     item_list[8].itmcode = 0;
 768     item_list[8].length = 0;
 769     item_list[8].component = NULL;
 770
 771     status = sys$filescan
 772        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 773         &flags, NULL, NULL);
 774     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 775
 776     /* If we parsed it successfully these two lengths should be the same */
 777     if (path_desc.dsc$w_length != item_list[filespec].length)
 778         return ret_stat;
 779
 780     /* If we got here, then it is a VMS file specification */
 781     ret_stat = 0;
 782
 783     /* set the volume name */
 784     if (item_list[nodespec].length > 0) {
 785         *volume = item_list[nodespec].component;
 786         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 787     }
 788     else {
 789         *volume = item_list[devspec].component;
 790         *vol_len = item_list[devspec].length;
 791     }
 792
 793     *root = item_list[rootspec].component;
 794     *root_len = item_list[rootspec].length;
 795
 796     *dir = item_list[dirspec].component;
 797     *dir_len = item_list[dirspec].length;
 798
 799     /* Now fun with versions and EFS file specifications
 800      * The parser can not tell the difference when a "." is a version
 801      * delimiter or a part of the file specification.
 802      */
 803     if ((decc_efs_charset) &&
 804         (item_list[verspec].length > 0) &&
 805         (item_list[verspec].component[0] == '.')) {
 806         *name = item_list[namespec].component;
 807         *name_len = item_list[namespec].length + item_list[typespec].length;
 808         *ext = item_list[verspec].component;
 809         *ext_len = item_list[verspec].length;
 810         *version = NULL;
 811         *ver_len = 0;
 812     }
 813     else {
 814         *name = item_list[namespec].component;
 815         *name_len = item_list[namespec].length;
 816         *ext = item_list[typespec].component;
 817         *ext_len = item_list[typespec].length;
 818         *version = item_list[verspec].component;
 819         *ver_len = item_list[verspec].length;
 820     }
 821     return ret_stat;
 822 }
 823
 824
 825 /* my_maxidx
 826  * Routine to retrieve the maximum equivalence index for an input
 827  * logical name.  Some calls to this routine have no knowledge if
 828  * the variable is a logical or not.  So on error we return a max
 829  * index of zero.
 830  */
 831 /*{{{int my_maxidx(const char *lnm) */
 832 static int
 833 my_maxidx(const char *lnm)
 834 {
 835     int status;
 836     int midx;
 837     int attr = LNM$M_CASE_BLIND;
 838     struct dsc$descriptor lnmdsc;
 839     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 840                                 {0, 0, 0, 0}};
 841
 842     lnmdsc.dsc$w_length = strlen(lnm);
 843     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 844     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 845     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 846
 847     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 848     if ((status & 1) == 0)
 849        midx = 0;
 850
 851     return (midx);
 852 }
 853 /*}}}*/
 854
 855 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 856 int
 857 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 858   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 859 {
 860     const char *cp1;
 861     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 862     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 863     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 864     int midx;
 865     unsigned char acmode;
 866     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 867                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 868     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 869                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 870                                  {0, 0, 0, 0}};
 871     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 872 #if defined(PERL_IMPLICIT_CONTEXT)
 873     pTHX = NULL;
 874     if (PL_curinterp) {
 875       aTHX = PERL_GET_INTERP;
 876     } else {
 877       aTHX = NULL;
 878     }
 879 #endif
 880
 881     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 882       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 883     }
 884     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 885       *cp2 = _toupper(*cp1);
 886       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 887         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 888         return 0;
 889       }
 890     }
 891     lnmdsc.dsc$w_length = cp1 - lnm;
 892     lnmdsc.dsc$a_pointer = uplnm;
 893     uplnm[lnmdsc.dsc$w_length] = '\0';
 894     secure = flags & PERL__TRNENV_SECURE;
 895     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 896     if (!tabvec || !*tabvec) tabvec = env_tables;
 897
 898     for (curtab = 0; tabvec[curtab]; curtab++) {
 899       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 900         if (!ivenv && !secure) {
 901           char *eq, *end;
 902           int i;
 903           if (!environ) {
 904             ivenv = 1;
 905             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 906             continue;
 907           }
 908           retsts = SS$_NOLOGNAM;
 909           for (i = 0; environ[i]; i++) {
 910             if ((eq = strchr(environ[i],'=')) &&
 911                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 912                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 913               eq++;
 914               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 915               if (!eqvlen) continue;
 916               retsts = SS$_NORMAL;
 917               break;
 918             }
 919           }
 920           if (retsts != SS$_NOLOGNAM) break;
 921         }
 922       }
 923       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 924                !str$case_blind_compare(&tmpdsc,&clisym)) {
 925         if (!ivsym && !secure) {
 926           unsigned short int deflen = LNM$C_NAMLENGTH;
 927           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 928           /* dynamic dsc to accomodate possible long value */
 929           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 930           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 931           if (retsts & 1) {
 932             if (eqvlen > MAX_DCL_SYMBOL) {
 933               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 934               eqvlen = MAX_DCL_SYMBOL;
 935               /* Special hack--we might be called before the interpreter's */
 936               /* fully initialized, in which case either thr or PL_curcop */
 937               /* might be bogus. We have to check, since ckWARN needs them */
 938               /* both to be valid if running threaded */
 939                 if (ckWARN(WARN_MISC)) {
 940                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 941                 }
 942             }
 943             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 944           }
 945           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 946           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 947           if (retsts == LIB$_NOSUCHSYM) continue;
 948           break;
 949         }
 950       }
 951       else if (!ivlnm) {
 952         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 953           midx = my_maxidx(lnm);
 954           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 955             lnmlst[1].bufadr = cp2;
 956             eqvlen = 0;
 957             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 958             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 959             if (retsts == SS$_NOLOGNAM) break;
 960             /* PPFs have a prefix */
 961             if (
 962 #if INTSIZE == 4
 963                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 964 #endif
 965                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 966                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 967                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 968                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 969                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 970               memmove(eqv,eqv+4,eqvlen-4);
 971               eqvlen -= 4;
 972             }
 973             cp2 += eqvlen;
 974             *cp2 = '\0';
 975           }
 976           if ((retsts == SS$_IVLOGNAM) ||
 977               (retsts == SS$_NOLOGNAM)) { continue; }
 978         }
 979         else {
 980           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 981           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 982           if (retsts == SS$_NOLOGNAM) continue;
 983           eqv[eqvlen] = '\0';
 984         }
 985         eqvlen = strlen(eqv);
 986         break;
 987       }
 988     }
 989     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 990     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 991              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 992              retsts == SS$_NOLOGNAM) {
 993       set_errno(EINVAL);  set_vaxc_errno(retsts);
 994     }
 995     else _ckvmssts(retsts);
 996     return 0;
 997 }  /* end of vmstrnenv */
 998 /*}}}*/
 999
1000 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1001 /* Define as a function so we can access statics. */
1002 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1003 {
1004   return vmstrnenv(lnm,eqv,idx,fildev,
1005 #ifdef SECURE_INTERNAL_GETENV
1006                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
1007 #else
1008                    0
1009 #endif
1010                                                                               );
1011 }
1012 /*}}}*/
1013
1014 /* my_getenv
1015  * Note: Uses Perl temp to store result so char * can be returned to
1016  * caller; this pointer will be invalidated at next Perl statement
1017  * transition.
1018  * We define this as a function rather than a macro in terms of my_getenv_len()
1019  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1020  * allocate SVs).
1021  */
1022 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1023 char *
1024 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1025 {
1026     const char *cp1;
1027     static char *__my_getenv_eqv = NULL;
1028     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1029     unsigned long int idx = 0;
1030     int trnsuccess, success, secure, saverr, savvmserr;
1031     int midx, flags;
1032     SV *tmpsv;
1033
1034     midx = my_maxidx(lnm) + 1;
1035
1036     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1037       /* Set up a temporary buffer for the return value; Perl will
1038        * clean it up at the next statement transition */
1039       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1040       if (!tmpsv) return NULL;
1041       eqv = SvPVX(tmpsv);
1042     }
1043     else {
1044       /* Assume no interpreter ==> single thread */
1045       if (__my_getenv_eqv != NULL) {
1046         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1047       }
1048       else {
1049         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1050       }
1051       eqv = __my_getenv_eqv;
1052     }
1053
1054     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1055     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1056       int len;
1057       getcwd(eqv,LNM$C_NAMLENGTH);
1058
1059       len = strlen(eqv);
1060
1061       /* Get rid of "000000/ in rooted filespecs */
1062       if (len > 7) {
1063         char * zeros;
1064         zeros = strstr(eqv, "/000000/");
1065         if (zeros != NULL) {
1066           int mlen;
1067           mlen = len - (zeros - eqv) - 7;
1068           memmove(zeros, &zeros[7], mlen);
1069           len = len - 7;
1070           eqv[len] = '\0';
1071         }
1072       }
1073       return eqv;
1074     }
1075     else {
1076       /* Impose security constraints only if tainting */
1077       if (sys) {
1078         /* Impose security constraints only if tainting */
1079         secure = PL_curinterp ? PL_tainting : will_taint;
1080         saverr = errno;  savvmserr = vaxc$errno;
1081       }
1082       else {
1083         secure = 0;
1084       }
1085
1086       flags =
1087 #ifdef SECURE_INTERNAL_GETENV
1088               secure ? PERL__TRNENV_SECURE : 0
1089 #else
1090               0
1091 #endif
1092       ;
1093
1094       /* For the getenv interface we combine all the equivalence names
1095        * of a search list logical into one value to acquire a maximum
1096        * value length of 255*128 (assuming %ENV is using logicals).
1097        */
1098       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1099
1100       /* If the name contains a semicolon-delimited index, parse it
1101        * off and make sure we only retrieve the equivalence name for
1102        * that index.  */
1103       if ((cp2 = strchr(lnm,';')) != NULL) {
1104         strcpy(uplnm,lnm);
1105         uplnm[cp2-lnm] = '\0';
1106         idx = strtoul(cp2+1,NULL,0);
1107         lnm = uplnm;
1108         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1109       }
1110
1111       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1112
1113       /* Discard NOLOGNAM on internal calls since we're often looking
1114        * for an optional name, and this "error" often shows up as the
1115        * (bogus) exit status for a die() call later on.  */
1116       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1117       return success ? eqv : Nullch;
1118     }
1119
1120 }  /* end of my_getenv() */
1121 /*}}}*/
1122
1123
1124 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1125 char *
1126 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1127 {
1128     const char *cp1;
1129     char *buf, *cp2;
1130     unsigned long idx = 0;
1131     int midx, flags;
1132     static char *__my_getenv_len_eqv = NULL;
1133     int secure, saverr, savvmserr;
1134     SV *tmpsv;
1135
1136     midx = my_maxidx(lnm) + 1;
1137
1138     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1139       /* Set up a temporary buffer for the return value; Perl will
1140        * clean it up at the next statement transition */
1141       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1142       if (!tmpsv) return NULL;
1143       buf = SvPVX(tmpsv);
1144     }
1145     else {
1146       /* Assume no interpreter ==> single thread */
1147       if (__my_getenv_len_eqv != NULL) {
1148         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1149       }
1150       else {
1151         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1152       }
1153       buf = __my_getenv_len_eqv;
1154     }
1155
1156     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1157     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1158     char * zeros;
1159
1160       getcwd(buf,LNM$C_NAMLENGTH);
1161       *len = strlen(buf);
1162
1163       /* Get rid of "000000/ in rooted filespecs */
1164       if (*len > 7) {
1165       zeros = strstr(buf, "/000000/");
1166       if (zeros != NULL) {
1167         int mlen;
1168         mlen = *len - (zeros - buf) - 7;
1169         memmove(zeros, &zeros[7], mlen);
1170         *len = *len - 7;
1171         buf[*len] = '\0';
1172         }
1173       }
1174       return buf;
1175     }
1176     else {
1177       if (sys) {
1178         /* Impose security constraints only if tainting */
1179         secure = PL_curinterp ? PL_tainting : will_taint;
1180         saverr = errno;  savvmserr = vaxc$errno;
1181       }
1182       else {
1183         secure = 0;
1184       }
1185
1186       flags =
1187 #ifdef SECURE_INTERNAL_GETENV
1188               secure ? PERL__TRNENV_SECURE : 0
1189 #else
1190               0
1191 #endif
1192       ;
1193
1194       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1195
1196       if ((cp2 = strchr(lnm,';')) != NULL) {
1197         strcpy(buf,lnm);
1198         buf[cp2-lnm] = '\0';
1199         idx = strtoul(cp2+1,NULL,0);
1200         lnm = buf;
1201         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1202       }
1203
1204       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1205
1206       /* Get rid of "000000/ in rooted filespecs */
1207       if (*len > 7) {
1208       char * zeros;
1209         zeros = strstr(buf, "/000000/");
1210         if (zeros != NULL) {
1211           int mlen;
1212           mlen = *len - (zeros - buf) - 7;
1213           memmove(zeros, &zeros[7], mlen);
1214           *len = *len - 7;
1215           buf[*len] = '\0';
1216         }
1217       }
1218
1219       /* Discard NOLOGNAM on internal calls since we're often looking
1220        * for an optional name, and this "error" often shows up as the
1221        * (bogus) exit status for a die() call later on.  */
1222       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1223       return *len ? buf : Nullch;
1224     }
1225
1226 }  /* end of my_getenv_len() */
1227 /*}}}*/
1228
1229 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1230
1231 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1232
1233 /*{{{ void prime_env_iter() */
1234 void
1235 prime_env_iter(void)
1236 /* Fill the %ENV associative array with all logical names we can
1237  * find, in preparation for iterating over it.
1238  */
1239 {
1240   static int primed = 0;
1241   HV *seenhv = NULL, *envhv;
1242   SV *sv = NULL;
1243   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1244   unsigned short int chan;
1245 #ifndef CLI$M_TRUSTED
1246 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1247 #endif
1248   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1249   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1250   long int i;
1251   bool have_sym = FALSE, have_lnm = FALSE;
1252   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1253   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1254   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1255   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1256   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1257 #if defined(PERL_IMPLICIT_CONTEXT)
1258   pTHX;
1259 #endif
1260 #if defined(USE_ITHREADS)
1261   static perl_mutex primenv_mutex;
1262   MUTEX_INIT(&primenv_mutex);
1263 #endif
1264
1265 #if defined(PERL_IMPLICIT_CONTEXT)
1266     /* We jump through these hoops because we can be called at */
1267     /* platform-specific initialization time, which is before anything is */
1268     /* set up--we can't even do a plain dTHX since that relies on the */
1269     /* interpreter structure to be initialized */
1270     if (PL_curinterp) {
1271       aTHX = PERL_GET_INTERP;
1272     } else {
1273       aTHX = NULL;
1274     }
1275 #endif
1276
1277   if (primed || !PL_envgv) return;
1278   MUTEX_LOCK(&primenv_mutex);
1279   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1280   envhv = GvHVn(PL_envgv);
1281   /* Perform a dummy fetch as an lval to insure that the hash table is
1282    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1283   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1284
1285   for (i = 0; env_tables[i]; i++) {
1286      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1287          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1288      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1289   }
1290   if (have_sym || have_lnm) {
1291     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1292     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1293     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1294     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1295   }
1296
1297   for (i--; i >= 0; i--) {
1298     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1299       char *start;
1300       int j;
1301       for (j = 0; environ[j]; j++) {
1302         if (!(start = strchr(environ[j],'='))) {
1303           if (ckWARN(WARN_INTERNAL))
1304             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1305         }
1306         else {
1307           start++;
1308           sv = newSVpv(start,0);
1309           SvTAINTED_on(sv);
1310           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1311         }
1312       }
1313       continue;
1314     }
1315     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1316              !str$case_blind_compare(&tmpdsc,&clisym)) {
1317       strcpy(cmd,"Show Symbol/Global *");
1318       cmddsc.dsc$w_length = 20;
1319       if (env_tables[i]->dsc$w_length == 12 &&
1320           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1321           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1322       flags = defflags | CLI$M_NOLOGNAM;
1323     }
1324     else {
1325       strcpy(cmd,"Show Logical *");
1326       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1327         strcat(cmd," /Table=");
1328         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1329         cmddsc.dsc$w_length = strlen(cmd);
1330       }
1331       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1332       flags = defflags | CLI$M_NOCLISYM;
1333     }
1334
1335     /* Create a new subprocess to execute each command, to exclude the
1336      * remote possibility that someone could subvert a mbx or file used
1337      * to write multiple commands to a single subprocess.
1338      */
1339     do {
1340       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1341                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1342       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1343       defflags &= ~CLI$M_TRUSTED;
1344     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1345     _ckvmssts(retsts);
1346     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1347     if (seenhv) SvREFCNT_dec(seenhv);
1348     seenhv = newHV();
1349     while (1) {
1350       char *cp1, *cp2, *key;
1351       unsigned long int sts, iosb[2], retlen, keylen;
1352       register U32 hash;
1353
1354       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1355       if (sts & 1) sts = iosb[0] & 0xffff;
1356       if (sts == SS$_ENDOFFILE) {
1357         int wakect = 0;
1358         while (substs == 0) { sys$hiber(); wakect++;}
1359         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1360         _ckvmssts(substs);
1361         break;
1362       }
1363       _ckvmssts(sts);
1364       retlen = iosb[0] >> 16;
1365       if (!retlen) continue;  /* blank line */
1366       buf[retlen] = '\0';
1367       if (iosb[1] != subpid) {
1368         if (iosb[1]) {
1369           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1370         }
1371         continue;
1372       }
1373       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1374         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1375
1376       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1377       if (*cp1 == '(' || /* Logical name table name */
1378           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1379       if (*cp1 == '"') cp1++;
1380       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1381       key = cp1;  keylen = cp2 - cp1;
1382       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1383       while (*cp2 && *cp2 != '=') cp2++;
1384       while (*cp2 && *cp2 == '=') cp2++;
1385       while (*cp2 && *cp2 == ' ') cp2++;
1386       if (*cp2 == '"') {  /* String translation; may embed "" */
1387         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1388         cp2++;  cp1--; /* Skip "" surrounding translation */
1389       }
1390       else {  /* Numeric translation */
1391         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1392         cp1--;  /* stop on last non-space char */
1393       }
1394       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1395         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1396         continue;
1397       }
1398       PERL_HASH(hash,key,keylen);
1399
1400       if (cp1 == cp2 && *cp2 == '.') {
1401         /* A single dot usually means an unprintable character, such as a null
1402          * to indicate a zero-length value.  Get the actual value to make sure.
1403          */
1404         char lnm[LNM$C_NAMLENGTH+1];
1405         char eqv[MAX_DCL_SYMBOL+1];
1406         int trnlen;
1407         strncpy(lnm, key, keylen);
1408         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1409         sv = newSVpvn(eqv, strlen(eqv));
1410       }
1411       else {
1412         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1413       }
1414
1415       SvTAINTED_on(sv);
1416       hv_store(envhv,key,keylen,sv,hash);
1417       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1418     }
1419     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1420       /* get the PPFs for this process, not the subprocess */
1421       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1422       char eqv[LNM$C_NAMLENGTH+1];
1423       int trnlen, i;
1424       for (i = 0; ppfs[i]; i++) {
1425         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1426         sv = newSVpv(eqv,trnlen);
1427         SvTAINTED_on(sv);
1428         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1429       }
1430     }
1431   }
1432   primed = 1;
1433   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1434   if (buf) Safefree(buf);
1435   if (seenhv) SvREFCNT_dec(seenhv);
1436   MUTEX_UNLOCK(&primenv_mutex);
1437   return;
1438
1439 }  /* end of prime_env_iter */
1440 /*}}}*/
1441
1442
1443 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1444 /* Define or delete an element in the same "environment" as
1445  * vmstrnenv().  If an element is to be deleted, it's removed from
1446  * the first place it's found.  If it's to be set, it's set in the
1447  * place designated by the first element of the table vector.
1448  * Like setenv() returns 0 for success, non-zero on error.
1449  */
1450 int
1451 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1452 {
1453     const char *cp1;
1454     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1455     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1456     int nseg = 0, j;
1457     unsigned long int retsts, usermode = PSL$C_USER;
1458     struct itmlst_3 *ile, *ilist;
1459     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1460                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1461                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1462     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1463     $DESCRIPTOR(local,"_LOCAL");
1464
1465     if (!lnm) {
1466         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1467         return SS$_IVLOGNAM;
1468     }
1469
1470     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1471       *cp2 = _toupper(*cp1);
1472       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1473         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1474         return SS$_IVLOGNAM;
1475       }
1476     }
1477     lnmdsc.dsc$w_length = cp1 - lnm;
1478     if (!tabvec || !*tabvec) tabvec = env_tables;
1479
1480     if (!eqv) {  /* we're deleting n element */
1481       for (curtab = 0; tabvec[curtab]; curtab++) {
1482         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1483         int i;
1484           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1485             if ((cp1 = strchr(environ[i],'=')) &&
1486                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1487                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1488 #ifdef HAS_SETENV
1489               return setenv(lnm,"",1) ? vaxc$errno : 0;
1490             }
1491           }
1492           ivenv = 1; retsts = SS$_NOLOGNAM;
1493 #else
1494               if (ckWARN(WARN_INTERNAL))
1495                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1496               ivenv = 1; retsts = SS$_NOSUCHPGM;
1497               break;
1498             }
1499           }
1500 #endif
1501         }
1502         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1503                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1504           unsigned int symtype;
1505           if (tabvec[curtab]->dsc$w_length == 12 &&
1506               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1507               !str$case_blind_compare(&tmpdsc,&local))
1508             symtype = LIB$K_CLI_LOCAL_SYM;
1509           else symtype = LIB$K_CLI_GLOBAL_SYM;
1510           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1511           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1512           if (retsts == LIB$_NOSUCHSYM) continue;
1513           break;
1514         }
1515         else if (!ivlnm) {
1516           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1517           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1518           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1519           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1520           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1521         }
1522       }
1523     }
1524     else {  /* we're defining a value */
1525       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1526 #ifdef HAS_SETENV
1527         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1528 #else
1529         if (ckWARN(WARN_INTERNAL))
1530           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1531         retsts = SS$_NOSUCHPGM;
1532 #endif
1533       }
1534       else {
1535         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1536         eqvdsc.dsc$w_length  = strlen(eqv);
1537         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1538             !str$case_blind_compare(&tmpdsc,&clisym)) {
1539           unsigned int symtype;
1540           if (tabvec[0]->dsc$w_length == 12 &&
1541               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1542                !str$case_blind_compare(&tmpdsc,&local))
1543             symtype = LIB$K_CLI_LOCAL_SYM;
1544           else symtype = LIB$K_CLI_GLOBAL_SYM;
1545           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1546         }
1547         else {
1548           if (!*eqv) eqvdsc.dsc$w_length = 1;
1549           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1550
1551             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1552             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1553               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1554                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1555               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1556               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1557             }
1558
1559             Newx(ilist,nseg+1,struct itmlst_3);
1560             ile = ilist;
1561             if (!ile) {
1562               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1563               return SS$_INSFMEM;
1564             }
1565             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1566
1567             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1568               ile->itmcode = LNM$_STRING;
1569               ile->bufadr = c;
1570               if ((j+1) == nseg) {
1571                 ile->buflen = strlen(c);
1572                 /* in case we are truncating one that's too long */
1573                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1574               }
1575               else {
1576                 ile->buflen = LNM$C_NAMLENGTH;
1577               }
1578             }
1579
1580             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1581             Safefree (ilist);
1582           }
1583           else {
1584             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1585           }
1586         }
1587       }
1588     }
1589     if (!(retsts & 1)) {
1590       switch (retsts) {
1591         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1592         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1593           set_errno(EVMSERR); break;
1594         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1595         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1596           set_errno(EINVAL); break;
1597         case SS$_NOPRIV:
1598           set_errno(EACCES); break;
1599         default:
1600           _ckvmssts(retsts);
1601           set_errno(EVMSERR);
1602        }
1603        set_vaxc_errno(retsts);
1604        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1605     }
1606     else {
1607       /* We reset error values on success because Perl does an hv_fetch()
1608        * before each hv_store(), and if the thing we're setting didn't
1609        * previously exist, we've got a leftover error message.  (Of course,
1610        * this fails in the face of
1611        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1612        * in that the error reported in $! isn't spurious,
1613        * but it's right more often than not.)
1614        */
1615       set_errno(0); set_vaxc_errno(retsts);
1616       return 0;
1617     }
1618
1619 }  /* end of vmssetenv() */
1620 /*}}}*/
1621
1622 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1623 /* This has to be a function since there's a prototype for it in proto.h */
1624 void
1625 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1626 {
1627     if (lnm && *lnm) {
1628       int len = strlen(lnm);
1629       if  (len == 7) {
1630         char uplnm[8];
1631         int i;
1632         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1633         if (!strcmp(uplnm,"DEFAULT")) {
1634           if (eqv && *eqv) my_chdir(eqv);
1635           return;
1636         }
1637     }
1638 #ifndef RTL_USES_UTC
1639     if (len == 6 || len == 2) {
1640       char uplnm[7];
1641       int i;
1642       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1643       uplnm[len] = '\0';
1644       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1645       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1646     }
1647 #endif
1648   }
1649   (void) vmssetenv(lnm,eqv,NULL);
1650 }
1651 /*}}}*/
1652
1653 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1654 /*  vmssetuserlnm
1655  *  sets a user-mode logical in the process logical name table
1656  *  used for redirection of sys$error
1657  */
1658 void
1659 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1660 {
1661     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1662     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1663     unsigned long int iss, attr = LNM$M_CONFINE;
1664     unsigned char acmode = PSL$C_USER;
1665     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1666                                  {0, 0, 0, 0}};
1667     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1668     d_name.dsc$w_length = strlen(name);
1669
1670     lnmlst[0].buflen = strlen(eqv);
1671     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1672
1673     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1674     if (!(iss&1)) lib$signal(iss);
1675 }
1676 /*}}}*/
1677
1678
1679 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1680 /* my_crypt - VMS password hashing
1681  * my_crypt() provides an interface compatible with the Unix crypt()
1682  * C library function, and uses sys$hash_password() to perform VMS
1683  * password hashing.  The quadword hashed password value is returned
1684  * as a NUL-terminated 8 character string.  my_crypt() does not change
1685  * the case of its string arguments; in order to match the behavior
1686  * of LOGINOUT et al., alphabetic characters in both arguments must
1687  *  be upcased by the caller.
1688  *
1689  * - fix me to call ACM services when available
1690  */
1691 char *
1692 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1693 {
1694 #   ifndef UAI$C_PREFERRED_ALGORITHM
1695 #     define UAI$C_PREFERRED_ALGORITHM 127
1696 #   endif
1697     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1698     unsigned short int salt = 0;
1699     unsigned long int sts;
1700     struct const_dsc {
1701         unsigned short int dsc$w_length;
1702         unsigned char      dsc$b_type;
1703         unsigned char      dsc$b_class;
1704         const char *       dsc$a_pointer;
1705     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1706        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1707     struct itmlst_3 uailst[3] = {
1708         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1709         { sizeof salt, UAI$_SALT,    &salt, 0},
1710         { 0,           0,            NULL,  NULL}};
1711     static char hash[9];
1712
1713     usrdsc.dsc$w_length = strlen(usrname);
1714     usrdsc.dsc$a_pointer = usrname;
1715     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1716       switch (sts) {
1717         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1718           set_errno(EACCES);
1719           break;
1720         case RMS$_RNF:
1721           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1722           break;
1723         default:
1724           set_errno(EVMSERR);
1725       }
1726       set_vaxc_errno(sts);
1727       if (sts != RMS$_RNF) return NULL;
1728     }
1729
1730     txtdsc.dsc$w_length = strlen(textpasswd);
1731     txtdsc.dsc$a_pointer = textpasswd;
1732     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1733       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1734     }
1735
1736     return (char *) hash;
1737
1738 }  /* end of my_crypt() */
1739 /*}}}*/
1740
1741
1742 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1743 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1744 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1745
1746 /* fixup barenames that are directories for internal use.
1747  * There have been problems with the consistent handling of UNIX
1748  * style directory names when routines are presented with a name that
1749  * has no directory delimitors at all.  So this routine will eventually
1750  * fix the issue.
1751  */
1752 static char * fixup_bare_dirnames(const char * name)
1753 {
1754   if (decc_disable_to_vms_logname_translation) {
1755 /* fix me */
1756   }
1757   return NULL;
1758 }
1759
1760 /* 8.3, remove() is now broken on symbolic links */
1761 static int rms_erase(const char * vmsname);
1762
1763
1764 /* mp_do_kill_file
1765  * A little hack to get around a bug in some implemenation of remove()
1766  * that do not know how to delete a directory
1767  *
1768  * Delete any file to which user has control access, regardless of whether
1769  * delete access is explicitly allowed.
1770  * Limitations: User must have write access to parent directory.
1771  *              Does not block signals or ASTs; if interrupted in midstream
1772  *              may leave file with an altered ACL.
1773  * HANDLE WITH CARE!
1774  */
1775 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1776 static int
1777 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1778 {
1779     char *vmsname;
1780     char *rslt;
1781     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1782     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1783     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1784     struct myacedef {
1785       unsigned char myace$b_length;
1786       unsigned char myace$b_type;
1787       unsigned short int myace$w_flags;
1788       unsigned long int myace$l_access;
1789       unsigned long int myace$l_ident;
1790     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1791                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1792       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1793      struct itmlst_3
1794        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1795                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1796        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1797        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1798        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1799        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1800
1801     /* Expand the input spec using RMS, since the CRTL remove() and
1802      * system services won't do this by themselves, so we may miss
1803      * a file "hiding" behind a logical name or search list. */
1804     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1805     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1806
1807     rslt = do_rmsexpand(name,
1808                         vmsname,
1809                         0,
1810                         NULL,
1811                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
1812                         NULL,
1813                         NULL);
1814     if (rslt == NULL) {
1815         PerlMem_free(vmsname);
1816         return -1;
1817       }
1818
1819     /* Erase the file */
1820     rmsts = rms_erase(vmsname);
1821
1822     /* Did it succeed */
1823     if ($VMS_STATUS_SUCCESS(rmsts)) {
1824         PerlMem_free(vmsname);
1825         return 0;
1826       }
1827
1828     /* If not, can changing protections help? */
1829     if (rmsts != RMS$_PRV) {
1830       set_vaxc_errno(rmsts);
1831       PerlMem_free(vmsname);
1832       return -1;
1833     }
1834
1835     /* No, so we get our own UIC to use as a rights identifier,
1836      * and the insert an ACE at the head of the ACL which allows us
1837      * to delete the file.
1838      */
1839     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1840     fildsc.dsc$w_length = strlen(vmsname);
1841     fildsc.dsc$a_pointer = vmsname;
1842     cxt = 0;
1843     newace.myace$l_ident = oldace.myace$l_ident;
1844     rmsts = -1;
1845     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1846       switch (aclsts) {
1847         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1848           set_errno(ENOENT); break;
1849         case RMS$_DIR:
1850           set_errno(ENOTDIR); break;
1851         case RMS$_DEV:
1852           set_errno(ENODEV); break;
1853         case RMS$_SYN: case SS$_INVFILFOROP:
1854           set_errno(EINVAL); break;
1855         case RMS$_PRV:
1856           set_errno(EACCES); break;
1857         default:
1858           _ckvmssts(aclsts);
1859       }
1860       set_vaxc_errno(aclsts);
1861       PerlMem_free(vmsname);
1862       return -1;
1863     }
1864     /* Grab any existing ACEs with this identifier in case we fail */
1865     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1866     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1867                     || fndsts == SS$_NOMOREACE ) {
1868       /* Add the new ACE . . . */
1869       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1870         goto yourroom;
1871
1872       rmsts = rms_erase(vmsname);
1873       if ($VMS_STATUS_SUCCESS(rmsts)) {
1874         rmsts = 0;
1875         }
1876         else {
1877         rmsts = -1;
1878         /* We blew it - dir with files in it, no write priv for
1879          * parent directory, etc.  Put things back the way they were. */
1880         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1881           goto yourroom;
1882         if (fndsts & 1) {
1883           addlst[0].bufadr = &oldace;
1884           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1885             goto yourroom;
1886         }
1887       }
1888     }
1889
1890     yourroom:
1891     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1892     /* We just deleted it, so of course it's not there.  Some versions of
1893      * VMS seem to return success on the unlock operation anyhow (after all
1894      * the unlock is successful), but others don't.
1895      */
1896     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1897     if (aclsts & 1) aclsts = fndsts;
1898     if (!(aclsts & 1)) {
1899       set_errno(EVMSERR);
1900       set_vaxc_errno(aclsts);
1901     }
1902
1903     PerlMem_free(vmsname);
1904     return rmsts;
1905
1906 }  /* end of kill_file() */
1907 /*}}}*/
1908
1909
1910 /*{{{int do_rmdir(char *name)*/
1911 int
1912 Perl_do_rmdir(pTHX_ const char *name)
1913 {
1914     char * dirfile;
1915     int retval;
1916     Stat_t st;
1917
1918     dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
1919     if (dirfile == NULL)
1920         _ckvmssts(SS$_INSFMEM);
1921
1922     /* Force to a directory specification */
1923     if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
1924         PerlMem_free(dirfile);
1925         return -1;
1926     }
1927     if (flex_lstat(dirfile, &st) || !S_ISDIR(st.st_mode)) {
1928         errno = ENOTDIR;
1929         retval = -1;
1930     }
1931     else
1932         retval = mp_do_kill_file(aTHX_ dirfile, 1);
1933
1934     PerlMem_free(dirfile);
1935     return retval;
1936
1937 }  /* end of do_rmdir */
1938 /*}}}*/
1939
1940 /* kill_file
1941  * Delete any file to which user has control access, regardless of whether
1942  * delete access is explicitly allowed.
1943  * Limitations: User must have write access to parent directory.
1944  *              Does not block signals or ASTs; if interrupted in midstream
1945  *              may leave file with an altered ACL.
1946  * HANDLE WITH CARE!
1947  */
1948 /*{{{int kill_file(char *name)*/
1949 int
1950 Perl_kill_file(pTHX_ const char *name)
1951 {
1952     char rspec[NAM$C_MAXRSS+1];
1953     char *tspec;
1954     Stat_t st;
1955     int rmsts;
1956
1957    /* Remove() is allowed to delete directories, according to the X/Open
1958     * specifications.
1959     * This needs special handling to work with the ACL hacks.
1960      */
1961    if (flex_stat(name, &st) && S_ISDIR(st.st_mode)) {
1962         rmsts = Perl_do_rmdir(name);
1963         return rmsts;
1964     }
1965
1966    rmsts = mp_do_kill_file(aTHX_ name, 0);
1967
1968     return rmsts;
1969
1970 }  /* end of kill_file() */
1971 /*}}}*/
1972
1973
1974 /*{{{int my_mkdir(char *,Mode_t)*/
1975 int
1976 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1977 {
1978   STRLEN dirlen = strlen(dir);
1979
1980   /* zero length string sometimes gives ACCVIO */
1981   if (dirlen == 0) return -1;
1982
1983   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1984    * null file name/type.  However, it's commonplace under Unix,
1985    * so we'll allow it for a gain in portability.
1986    */
1987   if (dir[dirlen-1] == '/') {
1988     char *newdir = savepvn(dir,dirlen-1);
1989     int ret = mkdir(newdir,mode);
1990     Safefree(newdir);
1991     return ret;
1992   }
1993   else return mkdir(dir,mode);
1994 }  /* end of my_mkdir */
1995 /*}}}*/
1996
1997 /*{{{int my_chdir(char *)*/
1998 int
1999 Perl_my_chdir(pTHX_ const char *dir)
2000 {
2001   STRLEN dirlen = strlen(dir);
2002
2003   /* zero length string sometimes gives ACCVIO */
2004   if (dirlen == 0) return -1;
2005   const char *dir1;
2006
2007   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2008    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2009    * so that existing scripts do not need to be changed.
2010    */
2011   dir1 = dir;
2012   while ((dirlen > 0) && (*dir1 == ' ')) {
2013     dir1++;
2014     dirlen--;
2015   }
2016
2017   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2018    * that implies
2019    * null file name/type.  However, it's commonplace under Unix,
2020    * so we'll allow it for a gain in portability.
2021    *
2022    * - Preview- '/' will be valid soon on VMS
2023    */
2024   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2025     char *newdir = savepvn(dir1,dirlen-1);
2026     int ret = chdir(newdir);
2027     Safefree(newdir);
2028     return ret;
2029   }
2030   else return chdir(dir1);
2031 }  /* end of my_chdir */
2032 /*}}}*/
2033
2034
2035 /*{{{FILE *my_tmpfile()*/
2036 FILE *
2037 my_tmpfile(void)
2038 {
2039   FILE *fp;
2040   char *cp;
2041
2042   if ((fp = tmpfile())) return fp;
2043
2044   cp = PerlMem_malloc(L_tmpnam+24);
2045   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2046
2047   if (decc_filename_unix_only == 0)
2048     strcpy(cp,"Sys$Scratch:");
2049   else
2050     strcpy(cp,"/tmp/");
2051   tmpnam(cp+strlen(cp));
2052   strcat(cp,".Perltmp");
2053   fp = fopen(cp,"w+","fop=dlt");
2054   PerlMem_free(cp);
2055   return fp;
2056 }
2057 /*}}}*/
2058
2059
2060 #ifndef HOMEGROWN_POSIX_SIGNALS
2061 /*
2062  * The C RTL's sigaction fails to check for invalid signal numbers so we
2063  * help it out a bit.  The docs are correct, but the actual routine doesn't
2064  * do what the docs say it will.
2065  */
2066 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2067 int
2068 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2069                    struct sigaction* oact)
2070 {
2071   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2072         SETERRNO(EINVAL, SS$_INVARG);
2073         return -1;
2074   }
2075   return sigaction(sig, act, oact);
2076 }
2077 /*}}}*/
2078 #endif
2079
2080 #ifdef KILL_BY_SIGPRC
2081 #include <errnodef.h>
2082
2083 /* We implement our own kill() using the undocumented system service
2084    sys$sigprc for one of two reasons:
2085
2086    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2087    target process to do a sys$exit, which usually can't be handled
2088    gracefully...certainly not by Perl and the %SIG{} mechanism.
2089
2090    2.) If the kill() in the CRTL can't be called from a signal
2091    handler without disappearing into the ether, i.e., the signal
2092    it purportedly sends is never trapped. Still true as of VMS 7.3.
2093
2094    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2095    in the target process rather than calling sys$exit.
2096
2097    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2098    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2099    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2100    with condition codes C$_SIG0+nsig*8, catching the exception on the
2101    target process and resignaling with appropriate arguments.
2102
2103    But we don't have that VMS 7.0+ exception handler, so if you
2104    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2105
2106    Also note that SIGTERM is listed in the docs as being "unimplemented",
2107    yet always seems to be signaled with a VMS condition code of 4 (and
2108    correctly handled for that code).  So we hardwire it in.
2109
2110    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2111    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2112    than signalling with an unrecognized (and unhandled by CRTL) code.
2113 */
2114
2115 #define _MY_SIG_MAX 28
2116
2117 static unsigned int
2118 Perl_sig_to_vmscondition_int(int sig)
2119 {
2120     static unsigned int sig_code[_MY_SIG_MAX+1] =
2121     {
2122         0,                  /*  0 ZERO     */
2123         SS$_HANGUP,         /*  1 SIGHUP   */
2124         SS$_CONTROLC,       /*  2 SIGINT   */
2125         SS$_CONTROLY,       /*  3 SIGQUIT  */
2126         SS$_RADRMOD,        /*  4 SIGILL   */
2127         SS$_BREAK,          /*  5 SIGTRAP  */
2128         SS$_OPCCUS,         /*  6 SIGABRT  */
2129         SS$_COMPAT,         /*  7 SIGEMT   */
2130 #ifdef __VAX
2131         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2132 #else
2133         SS$_HPARITH,        /*  8 SIGFPE AXP */
2134 #endif
2135         SS$_ABORT,          /*  9 SIGKILL  */
2136         SS$_ACCVIO,         /* 10 SIGBUS   */
2137         SS$_ACCVIO,         /* 11 SIGSEGV  */
2138         SS$_BADPARAM,       /* 12 SIGSYS   */
2139         SS$_NOMBX,          /* 13 SIGPIPE  */
2140         SS$_ASTFLT,         /* 14 SIGALRM  */
2141         4,                  /* 15 SIGTERM  */
2142         0,                  /* 16 SIGUSR1  */
2143         0,                  /* 17 SIGUSR2  */
2144         0,                  /* 18 */
2145         0,                  /* 19 */
2146         0,                  /* 20 SIGCHLD  */
2147         0,                  /* 21 SIGCONT  */
2148         0,                  /* 22 SIGSTOP  */
2149         0,                  /* 23 SIGTSTP  */
2150         0,                  /* 24 SIGTTIN  */
2151         0,                  /* 25 SIGTTOU  */
2152         0,                  /* 26 */
2153         0,                  /* 27 */
2154         0                   /* 28 SIGWINCH  */
2155     };
2156
2157 #if __VMS_VER >= 60200000
2158     static int initted = 0;
2159     if (!initted) {
2160         initted = 1;
2161         sig_code[16] = C$_SIGUSR1;
2162         sig_code[17] = C$_SIGUSR2;
2163 #if __CRTL_VER >= 70000000
2164         sig_code[20] = C$_SIGCHLD;
2165 #endif
2166 #if __CRTL_VER >= 70300000
2167         sig_code[28] = C$_SIGWINCH;
2168 #endif
2169     }
2170 #endif
2171
2172     if (sig < _SIG_MIN) return 0;
2173     if (sig > _MY_SIG_MAX) return 0;
2174     return sig_code[sig];
2175 }
2176
2177 unsigned int
2178 Perl_sig_to_vmscondition(int sig)
2179 {
2180 #ifdef SS$_DEBUG
2181     if (vms_debug_on_exception != 0)
2182         lib$signal(SS$_DEBUG);
2183 #endif
2184     return Perl_sig_to_vmscondition_int(sig);
2185 }
2186
2187
2188 int
2189 Perl_my_kill(int pid, int sig)
2190 {
2191     dTHX;
2192     int iss;
2193     unsigned int code;
2194     int sys$sigprc(unsigned int *pidadr,
2195                      struct dsc$descriptor_s *prcname,
2196                      unsigned int code);
2197
2198      /* sig 0 means validate the PID */
2199     /*------------------------------*/
2200     if (sig == 0) {
2201         const unsigned long int jpicode = JPI$_PID;
2202         pid_t ret_pid;
2203         int status;
2204         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2205         if ($VMS_STATUS_SUCCESS(status))
2206            return 0;
2207         switch (status) {
2208         case SS$_NOSUCHNODE:
2209         case SS$_UNREACHABLE:
2210         case SS$_NONEXPR:
2211            errno = ESRCH;
2212            break;
2213         case SS$_NOPRIV:
2214            errno = EPERM;
2215            break;
2216         default:
2217            errno = EVMSERR;
2218         }
2219         vaxc$errno=status;
2220         return -1;
2221     }
2222
2223     code = Perl_sig_to_vmscondition_int(sig);
2224
2225     if (!code) {
2226         SETERRNO(EINVAL, SS$_BADPARAM);
2227         return -1;
2228     }
2229
2230     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2231      * signals are to be sent to multiple processes.
2232      *  pid = 0 - all processes in group except ones that the system exempts
2233      *  pid = -1 - all processes except ones that the system exempts
2234      *  pid = -n - all processes in group (abs(n)) except ...
2235      * For now, just report as not supported.
2236      */
2237
2238     if (pid <= 0) {
2239         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2240         return -1;
2241     }
2242
2243     iss = sys$sigprc((unsigned int *)&pid,0,code);
2244     if (iss&1) return 0;
2245
2246     switch (iss) {
2247       case SS$_NOPRIV:
2248         set_errno(EPERM);  break;
2249       case SS$_NONEXPR:
2250       case SS$_NOSUCHNODE:
2251       case SS$_UNREACHABLE:
2252         set_errno(ESRCH);  break;
2253       case SS$_INSFMEM:
2254         set_errno(ENOMEM); break;
2255       default:
2256         _ckvmssts(iss);
2257         set_errno(EVMSERR);
2258     }
2259     set_vaxc_errno(iss);
2260
2261     return -1;
2262 }
2263 #endif
2264
2265 /* Routine to convert a VMS status code to a UNIX status code.
2266 ** More tricky than it appears because of conflicting conventions with
2267 ** existing code.
2268 **
2269 ** VMS status codes are a bit mask, with the least significant bit set for
2270 ** success.
2271 **
2272 ** Special UNIX status of EVMSERR indicates that no translation is currently
2273 ** available, and programs should check the VMS status code.
2274 **
2275 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2276 ** decoding.
2277 */
2278
2279 #ifndef C_FACILITY_NO
2280 #define C_FACILITY_NO 0x350000
2281 #endif
2282 #ifndef DCL_IVVERB
2283 #define DCL_IVVERB 0x38090
2284 #endif
2285
2286 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2287 {
2288 int facility;
2289 int fac_sp;
2290 int msg_no;
2291 int msg_status;
2292 int unix_status;
2293
2294   /* Assume the best or the worst */
2295   if (vms_status & STS$M_SUCCESS)
2296     unix_status = 0;
2297   else
2298     unix_status = EVMSERR;
2299
2300   msg_status = vms_status & ~STS$M_CONTROL;
2301
2302   facility = vms_status & STS$M_FAC_NO;
2303   fac_sp = vms_status & STS$M_FAC_SP;
2304   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2305
2306   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2307     switch(msg_no) {
2308     case SS$_NORMAL:
2309         unix_status = 0;
2310         break;
2311     case SS$_ACCVIO:
2312         unix_status = EFAULT;
2313         break;
2314     case SS$_DEVOFFLINE:
2315         unix_status = EBUSY;
2316         break;
2317     case SS$_CLEARED:
2318         unix_status = ENOTCONN;
2319         break;
2320     case SS$_IVCHAN:
2321     case SS$_IVLOGNAM:
2322     case SS$_BADPARAM:
2323     case SS$_IVLOGTAB:
2324     case SS$_NOLOGNAM:
2325     case SS$_NOLOGTAB:
2326     case SS$_INVFILFOROP:
2327     case SS$_INVARG:
2328     case SS$_NOSUCHID:
2329     case SS$_IVIDENT:
2330         unix_status = EINVAL;
2331         break;
2332     case SS$_UNSUPPORTED:
2333         unix_status = ENOTSUP;
2334         break;
2335     case SS$_FILACCERR:
2336     case SS$_NOGRPPRV:
2337     case SS$_NOSYSPRV:
2338         unix_status = EACCES;
2339         break;
2340     case SS$_DEVICEFULL:
2341         unix_status = ENOSPC;
2342         break;
2343     case SS$_NOSUCHDEV:
2344         unix_status = ENODEV;
2345         break;
2346     case SS$_NOSUCHFILE:
2347     case SS$_NOSUCHOBJECT:
2348         unix_status = ENOENT;
2349         break;
2350     case SS$_ABORT:                                 /* Fatal case */
2351     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2352     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2353         unix_status = EINTR;
2354         break;
2355     case SS$_BUFFEROVF:
2356         unix_status = E2BIG;
2357         break;
2358     case SS$_INSFMEM:
2359         unix_status = ENOMEM;
2360         break;
2361     case SS$_NOPRIV:
2362         unix_status = EPERM;
2363         break;
2364     case SS$_NOSUCHNODE:
2365     case SS$_UNREACHABLE:
2366         unix_status = ESRCH;
2367         break;
2368     case SS$_NONEXPR:
2369         unix_status = ECHILD;
2370         break;
2371     default:
2372         if ((facility == 0) && (msg_no < 8)) {
2373           /* These are not real VMS status codes so assume that they are
2374           ** already UNIX status codes
2375           */
2376           unix_status = msg_no;
2377           break;
2378         }
2379     }
2380   }
2381   else {
2382     /* Translate a POSIX exit code to a UNIX exit code */
2383     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2384         unix_status = (msg_no & 0x07F8) >> 3;
2385     }
2386     else {
2387
2388          /* Documented traditional behavior for handling VMS child exits */
2389         /*--------------------------------------------------------------*/
2390         if (child_flag != 0) {
2391
2392              /* Success / Informational return 0 */
2393             /*----------------------------------*/
2394             if (msg_no & STS$K_SUCCESS)
2395                 return 0;
2396
2397              /* Warning returns 1 */
2398             /*-------------------*/
2399             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2400                 return 1;
2401
2402              /* Everything else pass through the severity bits */
2403             /*------------------------------------------------*/
2404             return (msg_no & STS$M_SEVERITY);
2405         }
2406
2407          /* Normal VMS status to ERRNO mapping attempt */
2408         /*--------------------------------------------*/
2409         switch(msg_status) {
2410         /* case RMS$_EOF: */ /* End of File */
2411         case RMS$_FNF:  /* File Not Found */
2412         case RMS$_DNF:  /* Dir Not Found */
2413                 unix_status = ENOENT;
2414                 break;
2415         case RMS$_RNF:  /* Record Not Found */
2416                 unix_status = ESRCH;
2417                 break;
2418         case RMS$_DIR:
2419                 unix_status = ENOTDIR;
2420                 break;
2421         case RMS$_DEV:
2422                 unix_status = ENODEV;
2423                 break;
2424         case RMS$_IFI:
2425         case RMS$_FAC:
2426         case RMS$_ISI:
2427                 unix_status = EBADF;
2428                 break;
2429         case RMS$_FEX:
2430                 unix_status = EEXIST;
2431                 break;
2432         case RMS$_SYN:
2433         case RMS$_FNM:
2434         case LIB$_INVSTRDES:
2435         case LIB$_INVARG:
2436         case LIB$_NOSUCHSYM:
2437         case LIB$_INVSYMNAM:
2438         case DCL_IVVERB:
2439                 unix_status = EINVAL;
2440                 break;
2441         case CLI$_BUFOVF:
2442         case RMS$_RTB:
2443         case CLI$_TKNOVF:
2444         case CLI$_RSLOVF:
2445                 unix_status = E2BIG;
2446                 break;
2447         case RMS$_PRV:  /* No privilege */
2448         case RMS$_ACC:  /* ACP file access failed */
2449         case RMS$_WLK:  /* Device write locked */
2450                 unix_status = EACCES;
2451                 break;
2452         /* case RMS$_NMF: */  /* No more files */
2453         }
2454     }
2455   }
2456
2457   return unix_status;
2458 }
2459
2460 /* Try to guess at what VMS error status should go with a UNIX errno
2461  * value.  This is hard to do as there could be many possible VMS
2462  * error statuses that caused the errno value to be set.
2463  */
2464
2465 int Perl_unix_status_to_vms(int unix_status)
2466 {
2467 int test_unix_status;
2468
2469      /* Trivial cases first */
2470     /*---------------------*/
2471     if (unix_status == EVMSERR)
2472         return vaxc$errno;
2473
2474      /* Is vaxc$errno sane? */
2475     /*---------------------*/
2476     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2477     if (test_unix_status == unix_status)
2478         return vaxc$errno;
2479
2480      /* If way out of range, must be VMS code already */
2481     /*-----------------------------------------------*/
2482     if (unix_status > EVMSERR)
2483         return unix_status;
2484
2485      /* If out of range, punt */
2486     /*-----------------------*/
2487     if (unix_status > __ERRNO_MAX)
2488         return SS$_ABORT;
2489
2490
2491      /* Ok, now we have to do it the hard way. */
2492     /*----------------------------------------*/
2493     switch(unix_status) {
2494     case 0:     return SS$_NORMAL;
2495     case EPERM: return SS$_NOPRIV;
2496     case ENOENT: return SS$_NOSUCHOBJECT;
2497     case ESRCH: return SS$_UNREACHABLE;
2498     case EINTR: return SS$_ABORT;
2499     /* case EIO: */
2500     /* case ENXIO:  */
2501     case E2BIG: return SS$_BUFFEROVF;
2502     /* case ENOEXEC */
2503     case EBADF: return RMS$_IFI;
2504     case ECHILD: return SS$_NONEXPR;
2505     /* case EAGAIN */
2506     case ENOMEM: return SS$_INSFMEM;
2507     case EACCES: return SS$_FILACCERR;
2508     case EFAULT: return SS$_ACCVIO;
2509     /* case ENOTBLK */
2510     case EBUSY: return SS$_DEVOFFLINE;
2511     case EEXIST: return RMS$_FEX;
2512     /* case EXDEV */
2513     case ENODEV: return SS$_NOSUCHDEV;
2514     case ENOTDIR: return RMS$_DIR;
2515     /* case EISDIR */
2516     case EINVAL: return SS$_INVARG;
2517     /* case ENFILE */
2518     /* case EMFILE */
2519     /* case ENOTTY */
2520     /* case ETXTBSY */
2521     /* case EFBIG */
2522     case ENOSPC: return SS$_DEVICEFULL;
2523     case ESPIPE: return LIB$_INVARG;
2524     /* case EROFS: */
2525     /* case EMLINK: */
2526     /* case EPIPE: */
2527     /* case EDOM */
2528     case ERANGE: return LIB$_INVARG;
2529     /* case EWOULDBLOCK */
2530     /* case EINPROGRESS */
2531     /* case EALREADY */
2532     /* case ENOTSOCK */
2533     /* case EDESTADDRREQ */
2534     /* case EMSGSIZE */
2535     /* case EPROTOTYPE */
2536     /* case ENOPROTOOPT */
2537     /* case EPROTONOSUPPORT */
2538     /* case ESOCKTNOSUPPORT */
2539     /* case EOPNOTSUPP */
2540     /* case EPFNOSUPPORT */
2541     /* case EAFNOSUPPORT */
2542     /* case EADDRINUSE */
2543     /* case EADDRNOTAVAIL */
2544     /* case ENETDOWN */
2545     /* case ENETUNREACH */
2546     /* case ENETRESET */
2547     /* case ECONNABORTED */
2548     /* case ECONNRESET */
2549     /* case ENOBUFS */
2550     /* case EISCONN */
2551     case ENOTCONN: return SS$_CLEARED;
2552     /* case ESHUTDOWN */
2553     /* case ETOOMANYREFS */
2554     /* case ETIMEDOUT */
2555     /* case ECONNREFUSED */
2556     /* case ELOOP */
2557     /* case ENAMETOOLONG */
2558     /* case EHOSTDOWN */
2559     /* case EHOSTUNREACH */
2560     /* case ENOTEMPTY */
2561     /* case EPROCLIM */
2562     /* case EUSERS  */
2563     /* case EDQUOT  */
2564     /* case ENOMSG  */
2565     /* case EIDRM */
2566     /* case EALIGN */
2567     /* case ESTALE */
2568     /* case EREMOTE */
2569     /* case ENOLCK */
2570     /* case ENOSYS */
2571     /* case EFTYPE */
2572     /* case ECANCELED */
2573     /* case EFAIL */
2574     /* case EINPROG */
2575     case ENOTSUP:
2576         return SS$_UNSUPPORTED;
2577     /* case EDEADLK */
2578     /* case ENWAIT */
2579     /* case EILSEQ */
2580     /* case EBADCAT */
2581     /* case EBADMSG */
2582     /* case EABANDONED */
2583     default:
2584         return SS$_ABORT; /* punt */
2585     }
2586
2587   return SS$_ABORT; /* Should not get here */
2588 }
2589
2590
2591 /* default piping mailbox size */
2592 #define PERL_BUFSIZ        512
2593
2594
2595 static void
2596 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2597 {
2598   unsigned long int mbxbufsiz;
2599   static unsigned long int syssize = 0;
2600   unsigned long int dviitm = DVI$_DEVNAM;
2601   char csize[LNM$C_NAMLENGTH+1];
2602   int sts;
2603
2604   if (!syssize) {
2605     unsigned long syiitm = SYI$_MAXBUF;
2606     /*
2607      * Get the SYSGEN parameter MAXBUF
2608      *
2609      * If the logical 'PERL_MBX_SIZE' is defined
2610      * use the value of the logical instead of PERL_BUFSIZ, but
2611      * keep the size between 128 and MAXBUF.
2612      *
2613      */
2614     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2615   }
2616
2617   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2618       mbxbufsiz = atoi(csize);
2619   } else {
2620       mbxbufsiz = PERL_BUFSIZ;
2621   }
2622   if (mbxbufsiz < 128) mbxbufsiz = 128;
2623   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2624
2625   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2626
2627   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2628   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2629
2630 }  /* end of create_mbx() */
2631
2632
2633 /*{{{  my_popen and my_pclose*/
2634
2635 typedef struct _iosb           IOSB;
2636 typedef struct _iosb*         pIOSB;
2637 typedef struct _pipe           Pipe;
2638 typedef struct _pipe*         pPipe;
2639 typedef struct pipe_details    Info;
2640 typedef struct pipe_details*  pInfo;
2641 typedef struct _srqp            RQE;
2642 typedef struct _srqp*          pRQE;
2643 typedef struct _tochildbuf      CBuf;
2644 typedef struct _tochildbuf*    pCBuf;
2645
2646 struct _iosb {
2647     unsigned short status;
2648     unsigned short count;
2649     unsigned long  dvispec;
2650 };
2651
2652 #pragma member_alignment save
2653 #pragma nomember_alignment quadword
2654 struct _srqp {          /* VMS self-relative queue entry */
2655     unsigned long qptr[2];
2656 };
2657 #pragma member_alignment restore
2658 static RQE  RQE_ZERO = {0,0};
2659
2660 struct _tochildbuf {
2661     RQE             q;
2662     int             eof;
2663     unsigned short  size;
2664     char            *buf;
2665 };
2666
2667 struct _pipe {
2668     RQE            free;
2669     RQE            wait;
2670     int            fd_out;
2671     unsigned short chan_in;
2672     unsigned short chan_out;
2673     char          *buf;
2674     unsigned int   bufsize;
2675     IOSB           iosb;
2676     IOSB           iosb2;
2677     int           *pipe_done;
2678     int            retry;
2679     int            type;
2680     int            shut_on_empty;
2681     int            need_wake;
2682     pPipe         *home;
2683     pInfo          info;
2684     pCBuf          curr;
2685     pCBuf          curr2;
2686 #if defined(PERL_IMPLICIT_CONTEXT)
2687     void            *thx;           /* Either a thread or an interpreter */
2688                                     /* pointer, depending on how we're built */
2689 #endif
2690 };
2691
2692
2693 struct pipe_details
2694 {
2695     pInfo           next;
2696     PerlIO *fp;  /* file pointer to pipe mailbox */
2697     int useFILE; /* using stdio, not perlio */
2698     int pid;   /* PID of subprocess */
2699     int mode;  /* == 'r' if pipe open for reading */
2700     int done;  /* subprocess has completed */
2701     int waiting; /* waiting for completion/closure */
2702     int             closing;        /* my_pclose is closing this pipe */
2703     unsigned long   completion;     /* termination status of subprocess */
2704     pPipe           in;             /* pipe in to sub */
2705     pPipe           out;            /* pipe out of sub */
2706     pPipe           err;            /* pipe of sub's sys$error */
2707     int             in_done;        /* true when in pipe finished */
2708     int             out_done;
2709     int             err_done;
2710     unsigned short  xchan;          /* channel to debug xterm */
2711     unsigned short  xchan_valid;    /* channel is assigned */
2712 };
2713
2714 struct exit_control_block
2715 {
2716     struct exit_control_block *flink;
2717     unsigned long int   (*exit_routine)();
2718     unsigned long int arg_count;
2719     unsigned long int *status_address;
2720     unsigned long int exit_status;
2721 };
2722
2723 typedef struct _closed_pipes    Xpipe;
2724 typedef struct _closed_pipes*  pXpipe;
2725
2726 struct _closed_pipes {
2727     int             pid;            /* PID of subprocess */
2728     unsigned long   completion;     /* termination status of subprocess */
2729 };
2730 #define NKEEPCLOSED 50
2731 static Xpipe closed_list[NKEEPCLOSED];
2732 static int   closed_index = 0;
2733 static int   closed_num = 0;
2734
2735 #define RETRY_DELAY     "0 ::0.20"
2736 #define MAX_RETRY              50
2737
2738 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2739 static unsigned long mypid;
2740 static unsigned long delaytime[2];
2741
2742 static pInfo open_pipes = NULL;
2743 static $DESCRIPTOR(nl_desc, "NL:");
2744
2745 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2746
2747
2748
2749 static unsigned long int
2750 pipe_exit_routine(pTHX)
2751 {
2752     pInfo info;
2753     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2754     int sts, did_stuff, need_eof, j;
2755
2756    /*
2757     * Flush any pending i/o, but since we are in process run-down, be
2758     * careful about referencing PerlIO structures that may already have
2759     * been deallocated.  We may not even have an interpreter anymore.
2760     */
2761     info = open_pipes;
2762     while (info) {
2763         if (info->fp) {
2764            if (!info->useFILE
2765 #if defined(USE_ITHREADS)
2766              && my_perl
2767 #endif
2768              && PL_perlio_fd_refcnt)
2769                PerlIO_flush(info->fp);
2770            else
2771                fflush((FILE *)info->fp);
2772         }
2773         info = info->next;
2774     }
2775
2776     /*
2777      next we try sending an EOF...ignore if doesn't work, make sure we
2778      don't hang
2779     */
2780     did_stuff = 0;
2781     info = open_pipes;
2782
2783     while (info) {
2784       int need_eof;
2785       _ckvmssts_noperl(sys$setast(0));
2786       if (info->in && !info->in->shut_on_empty) {
2787         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2788                           0, 0, 0, 0, 0, 0));
2789         info->waiting = 1;
2790         did_stuff = 1;
2791       }
2792       _ckvmssts_noperl(sys$setast(1));
2793       info = info->next;
2794     }
2795
2796     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2797
2798     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2799         int nwait = 0;
2800
2801         info = open_pipes;
2802         while (info) {
2803           _ckvmssts_noperl(sys$setast(0));
2804           if (info->waiting && info->done)
2805                 info->waiting = 0;
2806           nwait += info->waiting;
2807           _ckvmssts_noperl(sys$setast(1));
2808           info = info->next;
2809         }
2810         if (!nwait) break;
2811         sleep(1);
2812     }
2813
2814     did_stuff = 0;
2815     info = open_pipes;
2816     while (info) {
2817       _ckvmssts_noperl(sys$setast(0));
2818       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2819         sts = sys$forcex(&info->pid,0,&abort);
2820         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2821         did_stuff = 1;
2822       }
2823       _ckvmssts_noperl(sys$setast(1));
2824       info = info->next;
2825     }
2826
2827     /* again, wait for effect */
2828
2829     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2830         int nwait = 0;
2831
2832         info = open_pipes;
2833         while (info) {
2834           _ckvmssts_noperl(sys$setast(0));
2835           if (info->waiting && info->done)
2836                 info->waiting = 0;
2837           nwait += info->waiting;
2838           _ckvmssts_noperl(sys$setast(1));
2839           info = info->next;
2840         }
2841         if (!nwait) break;
2842         sleep(1);
2843     }
2844
2845     info = open_pipes;
2846     while (info) {
2847       _ckvmssts_noperl(sys$setast(0));
2848       if (!info->done) {  /* We tried to be nice . . . */
2849         sts = sys$delprc(&info->pid,0);
2850         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2851         info->done = 1;  /* sys$delprc is as done as we're going to get. */
2852       }
2853       _ckvmssts_noperl(sys$setast(1));
2854       info = info->next;
2855     }
2856
2857     while(open_pipes) {
2858       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2859       else if (!(sts & 1)) retsts = sts;
2860     }
2861     return retsts;
2862 }
2863
2864 static struct exit_control_block pipe_exitblock =
2865        {(struct exit_control_block *) 0,
2866         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2867
2868 static void pipe_mbxtofd_ast(pPipe p);
2869 static void pipe_tochild1_ast(pPipe p);
2870 static void pipe_tochild2_ast(pPipe p);
2871
2872 static void
2873 popen_completion_ast(pInfo info)
2874 {
2875   pInfo i = open_pipes;
2876   int iss;
2877   int sts;
2878   pXpipe x;
2879
2880   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2881   closed_list[closed_index].pid = info->pid;
2882   closed_list[closed_index].completion = info->completion;
2883   closed_index++;
2884   if (closed_index == NKEEPCLOSED)
2885     closed_index = 0;
2886   closed_num++;
2887
2888   while (i) {
2889     if (i == info) break;
2890     i = i->next;
2891   }
2892   if (!i) return;       /* unlinked, probably freed too */
2893
2894   info->done = TRUE;
2895
2896 /*
2897     Writing to subprocess ...
2898             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2899
2900             chan_out may be waiting for "done" flag, or hung waiting
2901             for i/o completion to child...cancel the i/o.  This will
2902             put it into "snarf mode" (done but no EOF yet) that discards
2903             input.
2904
2905     Output from subprocess (stdout, stderr) needs to be flushed and
2906     shut down.   We try sending an EOF, but if the mbx is full the pipe
2907     routine should still catch the "shut_on_empty" flag, telling it to
2908     use immediate-style reads so that "mbx empty" -> EOF.
2909
2910
2911 */
2912   if (info->in && !info->in_done) {               /* only for mode=w */
2913         if (info->in->shut_on_empty && info->in->need_wake) {
2914             info->in->need_wake = FALSE;
2915             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2916         } else {
2917             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2918         }
2919   }
2920
2921   if (info->out && !info->out_done) {             /* were we also piping output? */
2922       info->out->shut_on_empty = TRUE;
2923       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2924       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2925       _ckvmssts_noperl(iss);
2926   }
2927
2928   if (info->err && !info->err_done) {        /* we were piping stderr */
2929         info->err->shut_on_empty = TRUE;
2930         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2931         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2932         _ckvmssts_noperl(iss);
2933   }
2934   _ckvmssts_noperl(sys$setef(pipe_ef));
2935
2936 }
2937
2938 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2939 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2940
2941 /*
2942     we actually differ from vmstrnenv since we use this to
2943     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2944     are pointing to the same thing
2945 */
2946
2947 static unsigned short
2948 popen_translate(pTHX_ char *logical, char *result)
2949 {
2950     int iss;
2951     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2952     $DESCRIPTOR(d_log,"");
2953     struct _il3 {
2954         unsigned short length;
2955         unsigned short code;
2956         char *         buffer_addr;
2957         unsigned short *retlenaddr;
2958     } itmlst[2];
2959     unsigned short l, ifi;
2960
2961     d_log.dsc$a_pointer = logical;
2962     d_log.dsc$w_length  = strlen(logical);
2963
2964     itmlst[0].code = LNM$_STRING;
2965     itmlst[0].length = 255;
2966     itmlst[0].buffer_addr = result;
2967     itmlst[0].retlenaddr = &l;
2968
2969     itmlst[1].code = 0;
2970     itmlst[1].length = 0;
2971     itmlst[1].buffer_addr = 0;
2972     itmlst[1].retlenaddr = 0;
2973
2974     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2975     if (iss == SS$_NOLOGNAM) {
2976         iss = SS$_NORMAL;
2977         l = 0;
2978     }
2979     if (!(iss&1)) lib$signal(iss);
2980     result[l] = '\0';
2981 /*
2982     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
2983     strip it off and return the ifi, if any
2984 */
2985     ifi  = 0;
2986     if (result[0] == 0x1b && result[1] == 0x00) {
2987         memmove(&ifi,result+2,2);
2988         strcpy(result,result+4);
2989     }
2990     return ifi;     /* this is the RMS internal file id */
2991 }
2992
2993 static void pipe_infromchild_ast(pPipe p);
2994
2995 /*
2996     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2997     inside an AST routine without worrying about reentrancy and which Perl
2998     memory allocator is being used.
2999
3000     We read data and queue up the buffers, then spit them out one at a
3001     time to the output mailbox when the output mailbox is ready for one.
3002
3003 */
3004 #define INITIAL_TOCHILDQUEUE  2
3005
3006 static pPipe
3007 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3008 {
3009     pPipe p;
3010     pCBuf b;
3011     char mbx1[64], mbx2[64];
3012     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3013                                       DSC$K_CLASS_S, mbx1},
3014                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3015                                       DSC$K_CLASS_S, mbx2};
3016     unsigned int dviitm = DVI$_DEVBUFSIZ;
3017     int j, n;
3018
3019     n = sizeof(Pipe);
3020     _ckvmssts(lib$get_vm(&n, &p));
3021
3022     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3023     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3024     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3025
3026     p->buf           = 0;
3027     p->shut_on_empty = FALSE;
3028     p->need_wake     = FALSE;
3029     p->type          = 0;
3030     p->retry         = 0;
3031     p->iosb.status   = SS$_NORMAL;
3032     p->iosb2.status  = SS$_NORMAL;
3033     p->free          = RQE_ZERO;
3034     p->wait          = RQE_ZERO;
3035     p->curr          = 0;
3036     p->curr2         = 0;
3037     p->info          = 0;
3038 #ifdef PERL_IMPLICIT_CONTEXT
3039     p->thx           = aTHX;
3040 #endif
3041
3042     n = sizeof(CBuf) + p->bufsize;
3043
3044     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3045         _ckvmssts(lib$get_vm(&n, &b));
3046         b->buf = (char *) b + sizeof(CBuf);
3047         _ckvmssts(lib$insqhi(b, &p->free));
3048     }
3049
3050     pipe_tochild2_ast(p);
3051     pipe_tochild1_ast(p);
3052     strcpy(wmbx, mbx1);
3053     strcpy(rmbx, mbx2);
3054     return p;
3055 }
3056
3057 /*  reads the MBX Perl is writing, and queues */
3058
3059 static void
3060 pipe_tochild1_ast(pPipe p)
3061 {
3062     pCBuf b = p->curr;
3063     int iss = p->iosb.status;
3064     int eof = (iss == SS$_ENDOFFILE);
3065     int sts;
3066 #ifdef PERL_IMPLICIT_CONTEXT
3067     pTHX = p->thx;
3068 #endif
3069
3070     if (p->retry) {
3071         if (eof) {
3072             p->shut_on_empty = TRUE;
3073             b->eof     = TRUE;
3074             _ckvmssts(sys$dassgn(p->chan_in));
3075         } else  {
3076             _ckvmssts(iss);
3077         }
3078
3079         b->eof  = eof;
3080         b->size = p->iosb.count;
3081         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3082         if (p->need_wake) {
3083             p->need_wake = FALSE;
3084             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3085         }
3086     } else {
3087         p->retry = 1;   /* initial call */
3088     }
3089
3090     if (eof) {                  /* flush the free queue, return when done */
3091         int n = sizeof(CBuf) + p->bufsize;
3092         while (1) {
3093             iss = lib$remqti(&p->free, &b);
3094             if (iss == LIB$_QUEWASEMP) return;
3095             _ckvmssts(iss);
3096             _ckvmssts(lib$free_vm(&n, &b));
3097         }
3098     }
3099
3100     iss = lib$remqti(&p->free, &b);
3101     if (iss == LIB$_QUEWASEMP) {
3102         int n = sizeof(CBuf) + p->bufsize;
3103         _ckvmssts(lib$get_vm(&n, &b));
3104         b->buf = (char *) b + sizeof(CBuf);
3105     } else {
3106        _ckvmssts(iss);
3107     }
3108
3109     p->curr = b;
3110     iss = sys$qio(0,p->chan_in,
3111              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3112              &p->iosb,
3113              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3114     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3115     _ckvmssts(iss);
3116 }
3117
3118
3119 /* writes queued buffers to output, waits for each to complete before
3120    doing the next */
3121
3122 static void
3123 pipe_tochild2_ast(pPipe p)
3124 {
3125     pCBuf b = p->curr2;
3126     int iss = p->iosb2.status;
3127     int n = sizeof(CBuf) + p->bufsize;
3128     int done = (p->info && p->info->done) ||
3129               iss == SS$_CANCEL || iss == SS$_ABORT;
3130 #if defined(PERL_IMPLICIT_CONTEXT)
3131     pTHX = p->thx;
3132 #endif
3133
3134     do {
3135         if (p->type) {         /* type=1 has old buffer, dispose */
3136             if (p->shut_on_empty) {
3137                 _ckvmssts(lib$free_vm(&n, &b));
3138             } else {
3139                 _ckvmssts(lib$insqhi(b, &p->free));
3140             }
3141             p->type = 0;
3142         }
3143
3144         iss = lib$remqti(&p->wait, &b);
3145         if (iss == LIB$_QUEWASEMP) {
3146             if (p->shut_on_empty) {
3147                 if (done) {
3148                     _ckvmssts(sys$dassgn(p->chan_out));
3149                     *p->pipe_done = TRUE;
3150                     _ckvmssts(sys$setef(pipe_ef));
3151                 } else {
3152                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3153                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3154                 }
3155                 return;
3156             }
3157             p->need_wake = TRUE;
3158             return;
3159         }
3160         _ckvmssts(iss);
3161         p->type = 1;
3162     } while (done);
3163
3164
3165     p->curr2 = b;
3166     if (b->eof) {
3167         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3168             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3169     } else {
3170         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3171             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3172     }
3173
3174     return;
3175
3176 }
3177
3178
3179 static pPipe
3180 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3181 {
3182     pPipe p;
3183     char mbx1[64], mbx2[64];
3184     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3185                                       DSC$K_CLASS_S, mbx1},
3186                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3187                                       DSC$K_CLASS_S, mbx2};
3188     unsigned int dviitm = DVI$_DEVBUFSIZ;
3189
3190     int n = sizeof(Pipe);
3191     _ckvmssts(lib$get_vm(&n, &p));
3192     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3193     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3194
3195     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3196     n = p->bufsize * sizeof(char);
3197     _ckvmssts(lib$get_vm(&n, &p->buf));
3198     p->shut_on_empty = FALSE;
3199     p->info   = 0;
3200     p->type   = 0;
3201     p->iosb.status = SS$_NORMAL;
3202 #if defined(PERL_IMPLICIT_CONTEXT)
3203     p->thx = aTHX;
3204 #endif
3205     pipe_infromchild_ast(p);
3206
3207     strcpy(wmbx, mbx1);
3208     strcpy(rmbx, mbx2);
3209     return p;
3210 }
3211
3212 static void
3213 pipe_infromchild_ast(pPipe p)
3214 {
3215     int iss = p->iosb.status;
3216     int eof = (iss == SS$_ENDOFFILE);
3217     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3218     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3219 #if defined(PERL_IMPLICIT_CONTEXT)
3220     pTHX = p->thx;
3221 #endif
3222
3223     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3224         _ckvmssts(sys$dassgn(p->chan_out));
3225         p->chan_out = 0;
3226     }
3227
3228     /* read completed:
3229             input shutdown if EOF from self (done or shut_on_empty)
3230             output shutdown if closing flag set (my_pclose)
3231             send data/eof from child or eof from self
3232             otherwise, re-read (snarf of data from child)
3233     */
3234
3235     if (p->type == 1) {
3236         p->type = 0;
3237         if (myeof && p->chan_in) {                  /* input shutdown */
3238             _ckvmssts(sys$dassgn(p->chan_in));
3239             p->chan_in = 0;
3240         }
3241
3242         if (p->chan_out) {
3243             if (myeof || kideof) {      /* pass EOF to parent */
3244                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3245                               pipe_infromchild_ast, p,
3246                               0, 0, 0, 0, 0, 0));
3247                 return;
3248             } else if (eof) {       /* eat EOF --- fall through to read*/
3249
3250             } else {                /* transmit data */
3251                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3252                               pipe_infromchild_ast,p,
3253                               p->buf, p->iosb.count, 0, 0, 0, 0));
3254                 return;
3255             }
3256         }
3257     }
3258
3259     /*  everything shut? flag as done */
3260
3261     if (!p->chan_in && !p->chan_out) {
3262         *p->pipe_done = TRUE;
3263         _ckvmssts(sys$setef(pipe_ef));
3264         return;
3265     }
3266
3267     /* write completed (or read, if snarfing from child)
3268             if still have input active,
3269                queue read...immediate mode if shut_on_empty so we get EOF if empty
3270             otherwise,
3271                check if Perl reading, generate EOFs as needed
3272     */
3273
3274     if (p->type == 0) {
3275         p->type = 1;
3276         if (p->chan_in) {
3277             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3278                           pipe_infromchild_ast,p,
3279                           p->buf, p->bufsize, 0, 0, 0, 0);
3280             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3281             _ckvmssts(iss);
3282         } else {           /* send EOFs for extra reads */
3283             p->iosb.status = SS$_ENDOFFILE;
3284             p->iosb.dvispec = 0;
3285             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3286                       0, 0, 0,
3287                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3288         }
3289     }
3290 }
3291
3292 static pPipe
3293 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3294 {
3295     pPipe p;
3296     char mbx[64];
3297     unsigned long dviitm = DVI$_DEVBUFSIZ;
3298     struct stat s;
3299     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3300                                       DSC$K_CLASS_S, mbx};
3301     int n = sizeof(Pipe);
3302
3303     /* things like terminals and mbx's don't need this filter */
3304     if (fd && fstat(fd,&s) == 0) {
3305         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3306         char device[65];
3307         unsigned short dev_len;
3308         struct dsc$descriptor_s d_dev;
3309         char * cptr;
3310         struct item_list_3 items[3];
3311         int status;
3312         unsigned short dvi_iosb[4];
3313
3314         cptr = getname(fd, out, 1);
3315         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3316         d_dev.dsc$a_pointer = out;
3317         d_dev.dsc$w_length = strlen(out);
3318         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3319         d_dev.dsc$b_class = DSC$K_CLASS_S;
3320
3321         items[0].len = 4;
3322         items[0].code = DVI$_DEVCHAR;
3323         items[0].bufadr = &devchar;
3324         items[0].retadr = NULL;
3325         items[1].len = 64;
3326         items[1].code = DVI$_FULLDEVNAM;
3327         items[1].bufadr = device;
3328         items[1].retadr = &dev_len;
3329         items[2].len = 0;
3330         items[2].code = 0;
3331
3332         status = sys$getdviw
3333                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3334         _ckvmssts(status);
3335         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3336             device[dev_len] = 0;
3337
3338             if (!(devchar & DEV$M_DIR)) {
3339                 strcpy(out, device);
3340                 return 0;
3341             }
3342         }
3343     }
3344
3345     _ckvmssts(lib$get_vm(&n, &p));
3346     p->fd_out = dup(fd);
3347     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3348     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3349     n = (p->bufsize+1) * sizeof(char);
3350     _ckvmssts(lib$get_vm(&n, &p->buf));
3351     p->shut_on_empty = FALSE;
3352     p->retry = 0;
3353     p->info  = 0;
3354     strcpy(out, mbx);
3355
3356     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3357                   pipe_mbxtofd_ast, p,
3358                   p->buf, p->bufsize, 0, 0, 0, 0));
3359
3360     return p;
3361 }
3362
3363 static void
3364 pipe_mbxtofd_ast(pPipe p)
3365 {
3366     int iss = p->iosb.status;
3367     int done = p->info->done;
3368     int iss2;
3369     int eof = (iss == SS$_ENDOFFILE);
3370     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3371     int err = !(iss&1) && !eof;
3372 #if defined(PERL_IMPLICIT_CONTEXT)
3373     pTHX = p->thx;
3374 #endif
3375
3376     if (done && myeof) {               /* end piping */
3377         close(p->fd_out);
3378         sys$dassgn(p->chan_in);
3379         *p->pipe_done = TRUE;
3380         _ckvmssts(sys$setef(pipe_ef));
3381         return;
3382     }
3383
3384     if (!err && !eof) {             /* good data to send to file */
3385         p->buf[p->iosb.count] = '\n';
3386         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3387         if (iss2 < 0) {
3388             p->retry++;
3389             if (p->retry < MAX_RETRY) {
3390                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3391                 return;
3392             }
3393         }
3394         p->retry = 0;
3395     } else if (err) {
3396         _ckvmssts(iss);
3397     }
3398
3399
3400     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3401           pipe_mbxtofd_ast, p,
3402           p->buf, p->bufsize, 0, 0, 0, 0);
3403     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3404     _ckvmssts(iss);
3405 }
3406
3407
3408 typedef struct _pipeloc     PLOC;
3409 typedef struct _pipeloc*   pPLOC;
3410
3411 struct _pipeloc {
3412     pPLOC   next;
3413     char    dir[NAM$C_MAXRSS+1];
3414 };
3415 static pPLOC  head_PLOC = 0;
3416
3417 void
3418 free_pipelocs(pTHX_ void *head)
3419 {
3420     pPLOC p, pnext;
3421     pPLOC *pHead = (pPLOC *)head;
3422
3423     p = *pHead;
3424     while (p) {
3425         pnext = p->next;
3426         PerlMem_free(p);
3427         p = pnext;
3428     }
3429     *pHead = 0;
3430 }
3431
3432 static void
3433 store_pipelocs(pTHX)
3434 {
3435     int    i;
3436     pPLOC  p;
3437     AV    *av = 0;
3438     SV    *dirsv;
3439     GV    *gv;
3440     char  *dir, *x;
3441     char  *unixdir;
3442     char  temp[NAM$C_MAXRSS+1];
3443     STRLEN n_a;
3444
3445     if (head_PLOC)
3446         free_pipelocs(aTHX_ &head_PLOC);
3447
3448 /*  the . directory from @INC comes last */
3449
3450     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3451     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3452     p->next = head_PLOC;
3453     head_PLOC = p;
3454     strcpy(p->dir,"./");
3455
3456 /*  get the directory from $^X */
3457
3458     unixdir = PerlMem_malloc(VMS_MAXRSS);
3459     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3460
3461 #ifdef PERL_IMPLICIT_CONTEXT
3462     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3463 #else
3464     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3465 #endif
3466         strcpy(temp, PL_origargv[0]);
3467         x = strrchr(temp,']');
3468         if (x == NULL) {
3469         x = strrchr(temp,'>');
3470           if (x == NULL) {
3471             /* It could be a UNIX path */
3472             x = strrchr(temp,'/');
3473           }
3474         }
3475         if (x)
3476           x[1] = '\0';
3477         else {
3478           /* Got a bare name, so use default directory */
3479           temp[0] = '.';
3480           temp[1] = '\0';
3481         }
3482
3483         if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3484             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3485             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3486             p->next = head_PLOC;
3487             head_PLOC = p;
3488             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3489             p->dir[NAM$C_MAXRSS] = '\0';
3490         }
3491     }
3492
3493 /*  reverse order of @INC entries, skip "." since entered above */
3494
3495 #ifdef PERL_IMPLICIT_CONTEXT
3496     if (aTHX)
3497 #endif
3498     if (PL_incgv) av = GvAVn(PL_incgv);
3499
3500     for (i = 0; av && i <= AvFILL(av); i++) {
3501         dirsv = *av_fetch(av,i,TRUE);
3502
3503         if (SvROK(dirsv)) continue;
3504         dir = SvPVx(dirsv,n_a);
3505         if (strcmp(dir,".") == 0) continue;
3506         if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3507             continue;
3508
3509         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3510         p->next = head_PLOC;
3511         head_PLOC = p;
3512         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3513         p->dir[NAM$C_MAXRSS] = '\0';
3514     }
3515
3516 /* most likely spot (ARCHLIB) put first in the list */
3517
3518 #ifdef ARCHLIB_EXP
3519     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3520         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3521         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3522         p->next = head_PLOC;
3523         head_PLOC = p;
3524         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3525         p->dir[NAM$C_MAXRSS] = '\0';
3526     }
3527 #endif
3528     PerlMem_free(unixdir);
3529 }
3530
3531 static I32
3532 Perl_cando_by_name_int
3533    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3534 #if !defined(PERL_IMPLICIT_CONTEXT)
3535 #define cando_by_name_int               Perl_cando_by_name_int
3536 #else
3537 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3538 #endif
3539
3540 static char *
3541 find_vmspipe(pTHX)
3542 {
3543     static int   vmspipe_file_status = 0;
3544     static char  vmspipe_file[NAM$C_MAXRSS+1];
3545
3546     /* already found? Check and use ... need read+execute permission */
3547
3548     if (vmspipe_file_status == 1) {
3549         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3550          && cando_by_name_int
3551            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3552             return vmspipe_file;
3553         }
3554         vmspipe_file_status = 0;
3555     }
3556
3557     /* scan through stored @INC, $^X */
3558
3559     if (vmspipe_file_status == 0) {
3560         char file[NAM$C_MAXRSS+1];
3561         pPLOC  p = head_PLOC;
3562
3563         while (p) {
3564             char * exp_res;
3565             int dirlen;
3566             strcpy(file, p->dir);
3567             dirlen = strlen(file);
3568             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3569             file[NAM$C_MAXRSS] = '\0';
3570             p = p->next;
3571
3572             exp_res = do_rmsexpand
3573                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3574             if (!exp_res) continue;
3575
3576             if (cando_by_name_int
3577                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3578              && cando_by_name_int
3579                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3580                 vmspipe_file_status = 1;
3581                 return vmspipe_file;
3582             }
3583         }
3584         vmspipe_file_status = -1;   /* failed, use tempfiles */
3585     }
3586
3587     return 0;
3588 }
3589
3590 static FILE *
3591 vmspipe_tempfile(pTHX)
3592 {
3593     char file[NAM$C_MAXRSS+1];
3594     FILE *fp;
3595     static int index = 0;
3596     Stat_t s0, s1;
3597     int cmp_result;
3598
3599     /* create a tempfile */
3600
3601     /* we can't go from   W, shr=get to  R, shr=get without
3602        an intermediate vulnerable state, so don't bother trying...
3603
3604        and lib$spawn doesn't shr=put, so have to close the write
3605
3606        So... match up the creation date/time and the FID to
3607        make sure we're dealing with the same file
3608
3609     */
3610
3611     index++;
3612     if (!decc_filename_unix_only) {
3613       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3614       fp = fopen(file,"w");
3615       if (!fp) {
3616         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3617         fp = fopen(file,"w");
3618         if (!fp) {
3619             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3620             fp = fopen(file,"w");
3621         }
3622       }
3623      }
3624      else {
3625       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3626       fp = fopen(file,"w");
3627       if (!fp) {
3628         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3629         fp = fopen(file,"w");
3630         if (!fp) {
3631           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3632           fp = fopen(file,"w");
3633         }
3634       }
3635     }
3636     if (!fp) return 0;  /* we're hosed */
3637
3638     fprintf(fp,"$! 'f$verify(0)'\n");
3639     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3640     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3641     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3642     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3643     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3644     fprintf(fp,"$ perl_del    = \"delete\"\n");
3645     fprintf(fp,"$ pif         = \"if\"\n");
3646     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3647     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3648     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3649     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3650     fprintf(fp,"$!  --- build command line to get max possible length\n");
3651     fprintf(fp,"$c=perl_popen_cmd0\n");
3652     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3653     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3654     fprintf(fp,"$x=perl_popen_cmd3\n");
3655     fprintf(fp,"$c=c+x\n");
3656     fprintf(fp,"$ perl_on\n");
3657     fprintf(fp,"$ 'c'\n");
3658     fprintf(fp,"$ perl_status = $STATUS\n");
3659     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3660     fprintf(fp,"$ perl_exit 'perl_status'\n");
3661     fsync(fileno(fp));
3662
3663     fgetname(fp, file, 1);
3664     fstat(fileno(fp), (struct stat *)&s0);
3665     fclose(fp);
3666
3667     if (decc_filename_unix_only)
3668         do_tounixspec(file, file, 0, NULL);
3669     fp = fopen(file,"r","shr=get");
3670     if (!fp) return 0;
3671     fstat(fileno(fp), (struct stat *)&s1);
3672
3673     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3674     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3675         fclose(fp);
3676         return 0;
3677     }
3678
3679     return fp;
3680 }
3681
3682
3683 static int vms_is_syscommand_xterm(void)
3684 {
3685     const static struct dsc$descriptor_s syscommand_dsc =
3686       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3687
3688     const static struct dsc$descriptor_s decwdisplay_dsc =
3689       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3690
3691     struct item_list_3 items[2];
3692     unsigned short dvi_iosb[4];
3693     unsigned long devchar;
3694     unsigned long devclass;
3695     int status;
3696
3697     /* Very simple check to guess if sys$command is a decterm? */
3698     /* First see if the DECW$DISPLAY: device exists */
3699     items[0].len = 4;
3700     items[0].code = DVI$_DEVCHAR;
3701     items[0].bufadr = &devchar;
3702     items[0].retadr = NULL;
3703     items[1].len = 0;
3704     items[1].code = 0;
3705
3706     status = sys$getdviw
3707         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3708
3709     if ($VMS_STATUS_SUCCESS(status)) {
3710         status = dvi_iosb[0];
3711     }
3712
3713     if (!$VMS_STATUS_SUCCESS(status)) {
3714         SETERRNO(EVMSERR, status);
3715         return -1;
3716     }
3717
3718     /* If it does, then for now assume that we are on a workstation */
3719     /* Now verify that SYS$COMMAND is a terminal */
3720     /* for creating the debugger DECTerm */
3721
3722     items[0].len = 4;
3723     items[0].code = DVI$_DEVCLASS;
3724     items[0].bufadr = &devclass;
3725     items[0].retadr = NULL;
3726     items[1].len = 0;
3727     items[1].code = 0;
3728
3729     status = sys$getdviw
3730         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3731
3732     if ($VMS_STATUS_SUCCESS(status)) {
3733         status = dvi_iosb[0];
3734     }
3735
3736     if (!$VMS_STATUS_SUCCESS(status)) {
3737         SETERRNO(EVMSERR, status);
3738         return -1;
3739     }
3740     else {
3741         if (devclass == DC$_TERM) {
3742             return 0;
3743         }
3744     }
3745     return -1;
3746 }
3747
3748 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3749 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3750 {
3751     int status;
3752     int ret_stat;
3753     char * ret_char;
3754     char device_name[65];
3755     unsigned short device_name_len;
3756     struct dsc$descriptor_s customization_dsc;
3757     struct dsc$descriptor_s device_name_dsc;
3758     const char * cptr;
3759     char * tptr;
3760     char customization[200];
3761     char title[40];
3762     pInfo info = NULL;
3763     char mbx1[64];
3764     unsigned short p_chan;
3765     int n;
3766     unsigned short iosb[4];
3767     struct item_list_3 items[2];
3768     const char * cust_str =
3769         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3770     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3771                                           DSC$K_CLASS_S, mbx1};
3772
3773      /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3774     /*---------------------------------------*/
3775     VAXC$ESTABLISH((__vms_handler)LIB$SIG_TO_RET);
3776
3777
3778     /* Make sure that this is from the Perl debugger */
3779     ret_char = strstr(cmd," xterm ");
3780     if (ret_char == NULL)
3781         return NULL;
3782     cptr = ret_char + 7;
3783     ret_char = strstr(cmd,"tty");
3784     if (ret_char == NULL)
3785         return NULL;
3786     ret_char = strstr(cmd,"sleep");
3787     if (ret_char == NULL)
3788         return NULL;
3789
3790     if (decw_term_port == 0) {
3791         $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3792         $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3793         $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3794
3795         status = LIB$FIND_IMAGE_SYMBOL
3796                                (&filename1_dsc,
3797                                 &decw_term_port_dsc,
3798                                 (void *)&decw_term_port,
3799                                 NULL,
3800                                 0);
3801
3802         /* Try again with the other image name */
3803         if (!$VMS_STATUS_SUCCESS(status)) {
3804
3805             status = LIB$FIND_IMAGE_SYMBOL
3806                                (&filename2_dsc,
3807                                 &decw_term_port_dsc,
3808                                 (void *)&decw_term_port,
3809                                 NULL,
3810                                 0);
3811
3812         }
3813
3814     }
3815
3816
3817     /* No decw$term_port, give it up */
3818     if (!$VMS_STATUS_SUCCESS(status))
3819         return NULL;
3820
3821     /* Are we on a workstation? */
3822     /* to do: capture the rows / columns and pass their properties */
3823     ret_stat = vms_is_syscommand_xterm();
3824     if (ret_stat < 0)
3825         return NULL;
3826
3827     /* Make the title: */
3828     ret_char = strstr(cptr,"-title");
3829     if (ret_char != NULL) {
3830         while ((*cptr != 0) && (*cptr != '\"')) {
3831             cptr++;
3832         }
3833         if (*cptr == '\"')
3834             cptr++;
3835         n = 0;
3836         while ((*cptr != 0) && (*cptr != '\"')) {
3837             title[n] = *cptr;
3838             n++;
3839             if (n == 39) {
3840                 title[39] == 0;
3841                 break;
3842             }
3843             cptr++;
3844         }
3845         title[n] = 0;
3846     }
3847     else {
3848             /* Default title */
3849             strcpy(title,"Perl Debug DECTerm");
3850     }
3851     sprintf(customization, cust_str, title);
3852
3853     customization_dsc.dsc$a_pointer = customization;
3854     customization_dsc.dsc$w_length = strlen(customization);
3855     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3856     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3857
3858     device_name_dsc.dsc$a_pointer = device_name;
3859     device_name_dsc.dsc$w_length = sizeof device_name -1;
3860     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3861     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3862
3863     device_name_len = 0;
3864
3865     /* Try to create the window */
3866      status = (*decw_term_port)
3867        (NULL,
3868         NULL,
3869         &customization_dsc,
3870         &device_name_dsc,
3871         &device_name_len,
3872         NULL,
3873         NULL,
3874         NULL);
3875     if (!$VMS_STATUS_SUCCESS(status)) {
3876         SETERRNO(EVMSERR, status);
3877         return NULL;
3878     }
3879
3880     device_name[device_name_len] = '\0';
3881
3882     /* Need to set this up to look like a pipe for cleanup */
3883     n = sizeof(Info);
3884     status = lib$get_vm(&n, &info);
3885     if (!$VMS_STATUS_SUCCESS(status)) {
3886         SETERRNO(ENOMEM, status);
3887         return NULL;
3888     }
3889
3890     info->mode = *mode;
3891     info->done = FALSE;
3892     info->completion = 0;
3893     info->closing    = FALSE;
3894     info->in         = 0;
3895     info->out        = 0;
3896     info->err        = 0;
3897     info->fp         = Nullfp;
3898     info->useFILE    = 0;
3899     info->waiting    = 0;
3900     info->in_done    = TRUE;
3901     info->out_done   = TRUE;
3902     info->err_done   = TRUE;
3903
3904     /* Assign a channel on this so that it will persist, and not login */
3905     /* We stash this channel in the info structure for reference. */
3906     /* The created xterm self destructs when the last channel is removed */
3907     /* and it appears that perl5db.pl (perl debugger) does this routinely */
3908     /* So leave this assigned. */
3909     device_name_dsc.dsc$w_length = device_name_len;
3910     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
3911     if (!$VMS_STATUS_SUCCESS(status)) {
3912         SETERRNO(EVMSERR, status);
3913         return NULL;
3914     }
3915     info->xchan_valid = 1;
3916
3917     /* Now create a mailbox to be read by the application */
3918
3919     create_mbx(aTHX_ &p_chan, &d_mbx1);
3920
3921     /* write the name of the created terminal to the mailbox */
3922     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
3923             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
3924
3925     if (!$VMS_STATUS_SUCCESS(status)) {
3926         SETERRNO(EVMSERR, status);
3927         return NULL;
3928     }
3929
3930     info->fp  = PerlIO_open(mbx1, mode);
3931
3932     /* Done with this channel */
3933     sys$dassgn(p_chan);
3934
3935     /* If any errors, then clean up */
3936     if (!info->fp) {
3937         n = sizeof(Info);
3938         _ckvmssts(lib$free_vm(&n, &info));
3939         return NULL;
3940         }
3941
3942     /* All done */
3943     return info->fp;
3944 }
3945
3946 static PerlIO *
3947 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3948 {
3949     static int handler_set_up = FALSE;
3950     unsigned long int sts, flags = CLI$M_NOWAIT;
3951     /* The use of a GLOBAL table (as was done previously) rendered
3952      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3953      * environment.  Hence we've switched to LOCAL symbol table.
3954      */
3955     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3956     int j, wait = 0, n;
3957     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3958     char *in, *out, *err, mbx[512];
3959     FILE *tpipe = 0;
3960     char tfilebuf[NAM$C_MAXRSS+1];
3961     pInfo info = NULL;
3962     char cmd_sym_name[20];
3963     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3964                                       DSC$K_CLASS_S, symbol};
3965     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3966                                       DSC$K_CLASS_S, 0};
3967     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3968                                       DSC$K_CLASS_S, cmd_sym_name};
3969     struct dsc$descriptor_s *vmscmd;
3970     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3971     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3972     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3973
3974     /* Check here for Xterm create request.  This means looking for
3975      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
3976      *  is possible to create an xterm.
3977      */
3978     if (*in_mode == 'r') {
3979         PerlIO * xterm_fd;
3980
3981         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
3982         if (xterm_fd != Nullfp)
3983             return xterm_fd;
3984     }
3985
3986     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
3987
3988     /* once-per-program initialization...
3989        note that the SETAST calls and the dual test of pipe_ef
3990        makes sure that only the FIRST thread through here does
3991        the initialization...all other threads wait until it's
3992        done.
3993
3994        Yeah, uglier than a pthread call, it's got all the stuff inline
3995        rather than in a separate routine.
3996     */
3997
3998     if (!pipe_ef) {
3999         _ckvmssts(sys$setast(0));
4000         if (!pipe_ef) {
4001             unsigned long int pidcode = JPI$_PID;
4002             $DESCRIPTOR(d_delay, RETRY_DELAY);
4003             _ckvmssts(lib$get_ef(&pipe_ef));
4004             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4005             _ckvmssts(sys$bintim(&d_delay, delaytime));
4006         }
4007         if (!handler_set_up) {
4008           _ckvmssts(sys$dclexh(&pipe_exitblock));
4009           handler_set_up = TRUE;
4010         }
4011         _ckvmssts(sys$setast(1));
4012     }
4013
4014     /* see if we can find a VMSPIPE.COM */
4015
4016     tfilebuf[0] = '@';
4017     vmspipe = find_vmspipe(aTHX);
4018     if (vmspipe) {
4019         strcpy(tfilebuf+1,vmspipe);
4020     } else {        /* uh, oh...we're in tempfile hell */
4021         tpipe = vmspipe_tempfile(aTHX);
4022         if (!tpipe) {       /* a fish popular in Boston */
4023             if (ckWARN(WARN_PIPE)) {
4024                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4025             }
4026         return Nullfp;
4027         }
4028         fgetname(tpipe,tfilebuf+1,1);
4029     }
4030     vmspipedsc.dsc$a_pointer = tfilebuf;
4031     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4032
4033     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4034     if (!(sts & 1)) {
4035       switch (sts) {
4036         case RMS$_FNF:  case RMS$_DNF:
4037           set_errno(ENOENT); break;
4038         case RMS$_DIR:
4039           set_errno(ENOTDIR); break;
4040         case RMS$_DEV:
4041           set_errno(ENODEV); break;
4042         case RMS$_PRV:
4043           set_errno(EACCES); break;
4044         case RMS$_SYN:
4045           set_errno(EINVAL); break;
4046         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4047           set_errno(E2BIG); break;
4048         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4049           _ckvmssts(sts); /* fall through */
4050         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4051           set_errno(EVMSERR);
4052       }
4053       set_vaxc_errno(sts);
4054       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4055         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4056       }
4057       *psts = sts;
4058       return Nullfp;
4059     }
4060     n = sizeof(Info);
4061     _ckvmssts(lib$get_vm(&n, &info));
4062
4063     strcpy(mode,in_mode);
4064     info->mode = *mode;
4065     info->done = FALSE;
4066     info->completion = 0;
4067     info->closing    = FALSE;
4068     info->in         = 0;
4069     info->out        = 0;
4070     info->err        = 0;
4071     info->fp         = Nullfp;
4072     info->useFILE    = 0;
4073     info->waiting    = 0;
4074     info->in_done    = TRUE;
4075     info->out_done   = TRUE;
4076     info->err_done   = TRUE;
4077     info->xchan      = 0;
4078     info->xchan_valid = 0;
4079
4080     in = PerlMem_malloc(VMS_MAXRSS);
4081     if (in == NULL) _ckvmssts(SS$_INSFMEM);
4082     out = PerlMem_malloc(VMS_MAXRSS);
4083     if (out == NULL) _ckvmssts(SS$_INSFMEM);
4084     err = PerlMem_malloc(VMS_MAXRSS);
4085     if (err == NULL) _ckvmssts(SS$_INSFMEM);
4086
4087     in[0] = out[0] = err[0] = '\0';
4088
4089     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4090         info->useFILE = 1;
4091         strcpy(p,p+1);
4092     }
4093     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4094         wait = 1;
4095         strcpy(p,p+1);
4096     }
4097
4098     if (*mode == 'r') {             /* piping from subroutine */
4099
4100         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4101         if (info->out) {
4102             info->out->pipe_done = &info->out_done;
4103             info->out_done = FALSE;
4104             info->out->info = info;
4105         }
4106         if (!info->useFILE) {
4107             info->fp  = PerlIO_open(mbx, mode);
4108         } else {
4109             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4110             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4111         }
4112
4113         if (!info->fp && info->out) {
4114             sys$cancel(info->out->chan_out);
4115
4116             while (!info->out_done) {
4117                 int done;
4118                 _ckvmssts(sys$setast(0));
4119                 done = info->out_done;
4120                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4121                 _ckvmssts(sys$setast(1));
4122                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4123             }
4124
4125             if (info->out->buf) {
4126                 n = info->out->bufsize * sizeof(char);
4127                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4128             }
4129             n = sizeof(Pipe);
4130             _ckvmssts(lib$free_vm(&n, &info->out));
4131             n = sizeof(Info);
4132             _ckvmssts(lib$free_vm(&n, &info));
4133             *psts = RMS$_FNF;
4134             return Nullfp;
4135         }
4136
4137         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4138         if (info->err) {
4139             info->err->pipe_done = &info->err_done;
4140             info->err_done = FALSE;
4141             info->err->info = info;
4142         }
4143
4144     } else if (*mode == 'w') {      /* piping to subroutine */
4145
4146         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4147         if (info->out) {
4148             info->out->pipe_done = &info->out_done;
4149             info->out_done = FALSE;
4150             info->out->info = info;
4151         }
4152
4153         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4154         if (info->err) {
4155             info->err->pipe_done = &info->err_done;
4156             info->err_done = FALSE;
4157             info->err->info = info;
4158         }
4159
4160         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4161         if (!info->useFILE) {
4162             info->fp  = PerlIO_open(mbx, mode);
4163         } else {
4164             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4165             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4166         }
4167
4168         if (info->in) {
4169             info->in->pipe_done = &info->in_done;
4170             info->in_done = FALSE;
4171             info->in->info = info;
4172         }
4173
4174         /* error cleanup */
4175         if (!info->fp && info->in) {
4176             info->done = TRUE;
4177             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4178                               0, 0, 0, 0, 0, 0, 0, 0));
4179
4180             while (!info->in_done) {
4181                 int done;
4182                 _ckvmssts(sys$setast(0));
4183                 done = info->in_done;
4184                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4185                 _ckvmssts(sys$setast(1));
4186                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4187             }
4188
4189             if (info->in->buf) {
4190                 n = info->in->bufsize * sizeof(char);
4191                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4192             }
4193             n = sizeof(Pipe);
4194             _ckvmssts(lib$free_vm(&n, &info->in));
4195             n = sizeof(Info);
4196             _ckvmssts(lib$free_vm(&n, &info));
4197             *psts = RMS$_FNF;
4198             return Nullfp;
4199         }
4200
4201
4202     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4203         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4204         if (info->out) {
4205             info->out->pipe_done = &info->out_done;
4206             info->out_done = FALSE;
4207             info->out->info = info;
4208         }
4209
4210         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4211         if (info->err) {
4212             info->err->pipe_done = &info->err_done;
4213             info->err_done = FALSE;
4214             info->err->info = info;
4215         }
4216     }
4217
4218     symbol[MAX_DCL_SYMBOL] = '\0';
4219
4220     strncpy(symbol, in, MAX_DCL_SYMBOL);
4221     d_symbol.dsc$w_length = strlen(symbol);
4222     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4223
4224     strncpy(symbol, err, MAX_DCL_SYMBOL);
4225     d_symbol.dsc$w_length = strlen(symbol);
4226     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4227
4228     strncpy(symbol, out, MAX_DCL_SYMBOL);
4229     d_symbol.dsc$w_length = strlen(symbol);
4230     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4231
4232     /* Done with the names for the pipes */
4233     PerlMem_free(err);
4234     PerlMem_free(out);
4235     PerlMem_free(in);
4236
4237     p = vmscmd->dsc$a_pointer;
4238     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4239     if (*p == '$') p++;                         /* remove leading $ */
4240     while (*p == ' ' || *p == '\t') p++;
4241
4242     for (j = 0; j < 4; j++) {
4243         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4244         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4245
4246     strncpy(symbol, p, MAX_DCL_SYMBOL);
4247     d_symbol.dsc$w_length = strlen(symbol);
4248     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4249
4250         if (strlen(p) > MAX_DCL_SYMBOL) {
4251             p += MAX_DCL_SYMBOL;
4252         } else {
4253             p += strlen(p);
4254         }
4255     }
4256     _ckvmssts(sys$setast(0));
4257     info->next=open_pipes;  /* prepend to list */
4258     open_pipes=info;
4259     _ckvmssts(sys$setast(1));
4260     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4261      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4262      * have SYS$COMMAND if we need it.
4263      */
4264     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4265                       0, &info->pid, &info->completion,
4266                       0, popen_completion_ast,info,0,0,0));
4267
4268     /* if we were using a tempfile, close it now */
4269
4270     if (tpipe) fclose(tpipe);
4271
4272     /* once the subprocess is spawned, it has copied the symbols and
4273        we can get rid of ours */
4274
4275     for (j = 0; j < 4; j++) {
4276         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4277         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4278     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4279     }
4280     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4281     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4282     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4283     vms_execfree(vmscmd);
4284
4285 #ifdef PERL_IMPLICIT_CONTEXT
4286     if (aTHX)
4287 #endif
4288     PL_forkprocess = info->pid;
4289
4290     if (wait) {
4291          int done = 0;
4292          while (!done) {
4293              _ckvmssts(sys$setast(0));
4294              done = info->done;
4295              if (!done) _ckvmssts(sys$clref(pipe_ef));
4296              _ckvmssts(sys$setast(1));
4297              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4298          }
4299         *psts = info->completion;
4300 /* Caller thinks it is open and tries to close it. */
4301 /* This causes some problems, as it changes the error status */
4302 /*        my_pclose(info->fp); */
4303     } else {
4304         *psts = SS$_NORMAL;
4305     }
4306     return info->fp;
4307 }  /* end of safe_popen */
4308
4309
4310 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4311 PerlIO *
4312 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4313 {
4314     int sts;
4315     TAINT_ENV();
4316     TAINT_PROPER("popen");
4317     PERL_FLUSHALL_FOR_CHILD;
4318     return safe_popen(aTHX_ cmd,mode,&sts);
4319 }
4320
4321 /*}}}*/
4322
4323 /*{{{  I32 my_pclose(PerlIO *fp)*/
4324 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4325 {
4326     pInfo info, last = NULL;
4327     unsigned long int retsts;
4328     int done, iss, n;
4329     int status;
4330
4331     for (info = open_pipes; info != NULL; last = info, info = info->next)
4332         if (info->fp == fp) break;
4333
4334     if (info == NULL) {  /* no such pipe open */
4335       set_errno(ECHILD); /* quoth POSIX */
4336       set_vaxc_errno(SS$_NONEXPR);
4337       return -1;
4338     }
4339
4340     /* If we were writing to a subprocess, insure that someone reading from
4341      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4342      * produce an EOF record in the mailbox.
4343      *
4344      *  well, at least sometimes it *does*, so we have to watch out for
4345      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4346      */
4347      if (info->fp) {
4348         if (!info->useFILE
4349 #if defined(USE_ITHREADS)
4350           && my_perl
4351 #endif
4352           && PL_perlio_fd_refcnt)
4353             PerlIO_flush(info->fp);
4354         else
4355             fflush((FILE *)info->fp);
4356     }
4357
4358     _ckvmssts(sys$setast(0));
4359      info->closing = TRUE;
4360      done = info->done && info->in_done && info->out_done && info->err_done;
4361      /* hanging on write to Perl's input? cancel it */
4362      if (info->mode == 'r' && info->out && !info->out_done) {
4363         if (info->out->chan_out) {
4364             _ckvmssts(sys$cancel(info->out->chan_out));
4365             if (!info->out->chan_in) {   /* EOF generation, need AST */
4366                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4367             }
4368         }
4369      }
4370      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4371          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4372                            0, 0, 0, 0, 0, 0));
4373     _ckvmssts(sys$setast(1));
4374     if (info->fp) {
4375      if (!info->useFILE
4376 #if defined(USE_ITHREADS)
4377          && my_perl
4378 #endif
4379          && PL_perlio_fd_refcnt)
4380         PerlIO_close(info->fp);
4381      else
4382         fclose((FILE *)info->fp);
4383     }
4384      /*
4385         we have to wait until subprocess completes, but ALSO wait until all
4386         the i/o completes...otherwise we'll be freeing the "info" structure
4387         that the i/o ASTs could still be using...
4388      */
4389
4390      while (!done) {
4391          _ckvmssts(sys$setast(0));
4392          done = info->done && info->in_done && info->out_done && info->err_done;
4393          if (!done) _ckvmssts(sys$clref(pipe_ef));
4394          _ckvmssts(sys$setast(1));
4395          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4396      }
4397      retsts = info->completion;
4398
4399     /* remove from list of open pipes */
4400     _ckvmssts(sys$setast(0));
4401     if (last) last->next = info->next;
4402     else open_pipes = info->next;
4403     _ckvmssts(sys$setast(1));
4404
4405     /* free buffers and structures */
4406
4407     if (info->in) {
4408         if (info->in->buf) {
4409             n = info->in->bufsize * sizeof(char);
4410             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4411         }
4412         n = sizeof(Pipe);
4413         _ckvmssts(lib$free_vm(&n, &info->in));
4414     }
4415     if (info->out) {
4416         if (info->out->buf) {
4417             n = info->out->bufsize * sizeof(char);
4418             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4419         }
4420         n = sizeof(Pipe);
4421         _ckvmssts(lib$free_vm(&n, &info->out));
4422     }
4423     if (info->err) {
4424         if (info->err->buf) {
4425             n = info->err->bufsize * sizeof(char);
4426             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4427         }
4428         n = sizeof(Pipe);
4429         _ckvmssts(lib$free_vm(&n, &info->err));
4430     }
4431     n = sizeof(Info);
4432     _ckvmssts(lib$free_vm(&n, &info));
4433
4434     return retsts;
4435
4436 }  /* end of my_pclose() */
4437
4438 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4439   /* Roll our own prototype because we want this regardless of whether
4440    * _VMS_WAIT is defined.
4441    */
4442   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4443 #endif
4444 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4445    created with popen(); otherwise partially emulate waitpid() unless
4446    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4447    Also check processes not considered by the CRTL waitpid().
4448  */
4449 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4450 Pid_t
4451 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4452 {
4453     pInfo info;
4454     int done;
4455     int sts;
4456     int j;
4457
4458     if (statusp) *statusp = 0;
4459
4460     for (info = open_pipes; info != NULL; info = info->next)
4461         if (info->pid == pid) break;
4462
4463     if (info != NULL) {  /* we know about this child */
4464       while (!info->done) {
4465           _ckvmssts(sys$setast(0));
4466           done = info->done;
4467           if (!done) _ckvmssts(sys$clref(pipe_ef));
4468           _ckvmssts(sys$setast(1));
4469           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4470       }
4471
4472       if (statusp) *statusp = info->completion;
4473       return pid;
4474     }
4475
4476     /* child that already terminated? */
4477
4478     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4479         if (closed_list[j].pid == pid) {
4480             if (statusp) *statusp = closed_list[j].completion;
4481             return pid;
4482         }
4483     }
4484
4485     /* fall through if this child is not one of our own pipe children */
4486
4487 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4488
4489       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4490        * in 7.2 did we get a version that fills in the VMS completion
4491        * status as Perl has always tried to do.
4492        */
4493
4494       sts = __vms_waitpid( pid, statusp, flags );
4495
4496       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4497          return sts;
4498
4499       /* If the real waitpid tells us the child does not exist, we
4500        * fall through here to implement waiting for a child that
4501        * was created by some means other than exec() (say, spawned
4502        * from DCL) or to wait for a process that is not a subprocess
4503        * of the current process.
4504        */
4505
4506 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4507
4508     {
4509       $DESCRIPTOR(intdsc,"0 00:00:01");
4510       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4511       unsigned long int pidcode = JPI$_PID, mypid;
4512       unsigned long int interval[2];
4513       unsigned int jpi_iosb[2];
4514       struct itmlst_3 jpilist[2] = {
4515           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4516           {                      0,         0,                 0, 0}
4517       };
4518
4519       if (pid <= 0) {
4520         /* Sorry folks, we don't presently implement rooting around for
4521            the first child we can find, and we definitely don't want to
4522            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4523          */
4524         set_errno(ENOTSUP);
4525         return -1;
4526       }
4527
4528       /* Get the owner of the child so I can warn if it's not mine. If the
4529        * process doesn't exist or I don't have the privs to look at it,
4530        * I can go home early.
4531        */
4532       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4533       if (sts & 1) sts = jpi_iosb[0];
4534       if (!(sts & 1)) {
4535         switch (sts) {
4536             case SS$_NONEXPR:
4537                 set_errno(ECHILD);
4538                 break;
4539             case SS$_NOPRIV:
4540                 set_errno(EACCES);
4541                 break;
4542             default:
4543                 _ckvmssts(sts);
4544         }
4545         set_vaxc_errno(sts);
4546         return -1;
4547       }
4548
4549       if (ckWARN(WARN_EXEC)) {
4550         /* remind folks they are asking for non-standard waitpid behavior */
4551         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4552         if (ownerpid != mypid)
4553           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4554                       "waitpid: process %x is not a child of process %x",
4555                       pid,mypid);
4556       }
4557
4558       /* simply check on it once a second until it's not there anymore. */
4559
4560       _ckvmssts(sys$bintim(&intdsc,interval));
4561       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4562             _ckvmssts(sys$schdwk(0,0,interval,0));
4563             _ckvmssts(sys$hiber());
4564       }
4565       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4566
4567       _ckvmssts(sts);
4568       return pid;
4569     }
4570 }  /* end of waitpid() */
4571 /*}}}*/
4572 /*}}}*/
4573 /*}}}*/
4574
4575 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4576 char *
4577 my_gconvert(double val, int ndig, int trail, char *buf)
4578 {
4579   static char __gcvtbuf[DBL_DIG+1];
4580   char *loc;
4581
4582   loc = buf ? buf : __gcvtbuf;
4583
4584 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4585   if (val < 1) {
4586     sprintf(loc,"%.*g",ndig,val);
4587     return loc;
4588   }
4589 #endif
4590
4591   if (val) {
4592     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4593     return gcvt(val,ndig,loc);
4594   }
4595   else {
4596     loc[0] = '0'; loc[1] = '\0';
4597     return loc;
4598   }
4599
4600 }
4601 /*}}}*/
4602
4603 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4604 static int rms_free_search_context(struct FAB * fab)
4605 {
4606 struct NAM * nam;
4607
4608     nam = fab->fab$l_nam;
4609     nam->nam$b_nop |= NAM$M_SYNCHK;
4610     nam->nam$l_rlf = NULL;
4611     fab->fab$b_dns = 0;
4612     return sys$parse(fab, NULL, NULL);
4613 }
4614
4615 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4616 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4617 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4618 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4619 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4620 #define rms_nam_esll(nam) nam.nam$b_esl
4621 #define rms_nam_esl(nam) nam.nam$b_esl
4622 #define rms_nam_name(nam) nam.nam$l_name
4623 #define rms_nam_namel(nam) nam.nam$l_name
4624 #define rms_nam_type(nam) nam.nam$l_type
4625 #define rms_nam_typel(nam) nam.nam$l_type
4626 #define rms_nam_ver(nam) nam.nam$l_ver
4627 #define rms_nam_verl(nam) nam.nam$l_ver
4628 #define rms_nam_rsll(nam) nam.nam$b_rsl
4629 #define rms_nam_rsl(nam) nam.nam$b_rsl
4630 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4631 #define rms_set_fna(fab, nam, name, size) \
4632         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4633 #define rms_get_fna(fab, nam) fab.fab$l_fna
4634 #define rms_set_dna(fab, nam, name, size) \
4635         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4636 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4637 #define rms_set_esa(fab, nam, name, size) \
4638         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4639 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4640         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4641 #define rms_set_rsa(nam, name, size) \
4642         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4643 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4644         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4645 #define rms_nam_name_type_l_size(nam) \
4646         (nam.nam$b_name + nam.nam$b_type)
4647 #else
4648 static int rms_free_search_context(struct FAB * fab)
4649 {
4650 struct NAML * nam;
4651
4652     nam = fab->fab$l_naml;
4653     nam->naml$b_nop |= NAM$M_SYNCHK;
4654     nam->naml$l_rlf = NULL;
4655     nam->naml$l_long_defname_size = 0;
4656
4657     fab->fab$b_dns = 0;
4658     return sys$parse(fab, NULL, NULL);
4659 }
4660
4661 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4662 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4663 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4664 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4665 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4666 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4667 #define rms_nam_esl(nam) nam.naml$b_esl
4668 #define rms_nam_name(nam) nam.naml$l_name
4669 #define rms_nam_namel(nam) nam.naml$l_long_name
4670 #define rms_nam_type(nam) nam.naml$l_type
4671 #define rms_nam_typel(nam) nam.naml$l_long_type
4672 #define rms_nam_ver(nam) nam.naml$l_ver
4673 #define rms_nam_verl(nam) nam.naml$l_long_ver
4674 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4675 #define rms_nam_rsl(nam) nam.naml$b_rsl
4676 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4677 #define rms_set_fna(fab, nam, name, size) \
4678         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4679         nam.naml$l_long_filename_size = size; \
4680         nam.naml$l_long_filename = name;}
4681 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4682 #define rms_set_dna(fab, nam, name, size) \
4683         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4684         nam.naml$l_long_defname_size = size; \
4685         nam.naml$l_long_defname = name; }
4686 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4687 #define rms_set_esa(fab, nam, name, size) \
4688         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4689         nam.naml$l_long_expand_alloc = size; \
4690         nam.naml$l_long_expand = name; }
4691 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4692         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4693         nam.naml$l_long_expand = l_name; \
4694         nam.naml$l_long_expand_alloc = l_size; }
4695 #define rms_set_rsa(nam, name, size) \
4696         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4697         nam.naml$l_long_result = name; \
4698         nam.naml$l_long_result_alloc = size; }
4699 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4700         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4701         nam.naml$l_long_result = l_name; \
4702         nam.naml$l_long_result_alloc = l_size; }
4703 #define rms_nam_name_type_l_size(nam) \
4704         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4705 #endif
4706
4707 /* rms_erase
4708  * The CRTL for 8.3 and later can create symbolic links in any mode,
4709  * however the unlink/remove/delete routines will only properly handle
4710  * them if one of the PCP modes is active.
4711  *
4712  * Future: rename() routine will also need this when the unlink_all_versions
4713  * option is set.
4714  */
4715 static int rms_erase(const char * vmsname)
4716 {
4717   int status;
4718   struct FAB myfab = cc$rms_fab;
4719   rms_setup_nam(mynam);
4720
4721   rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4722   rms_bind_fab_nam(myfab, mynam);
4723 \
4724   /* Are we removing all versions? */
4725   if (vms_unlink_all_versions == 1) {
4726     const char * defspec = ";*";
4727     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4728   }
4729
4730 #ifdef NAML$M_OPEN_SPECIAL
4731   rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4732 #endif
4733
4734   status = SYS$ERASE(&myfab, 0, 0);
4735
4736   return status;
4737 }
4738
4739
4740 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4741 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4742  * to expand file specification.  Allows for a single default file
4743  * specification and a simple mask of options.  If outbuf is non-NULL,
4744  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4745  * the resultant file specification is placed.  If outbuf is NULL, the
4746  * resultant file specification is placed into a static buffer.
4747  * The third argument, if non-NULL, is taken to be a default file
4748  * specification string.  The fourth argument is unused at present.
4749  * rmesexpand() returns the address of the resultant string if
4750  * successful, and NULL on error.
4751  *
4752  * New functionality for previously unused opts value:
4753  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4754  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
4755  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4756  *  PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
4757  */
4758 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4759
4760 static char *
4761 mp_do_rmsexpand
4762    (pTHX_ const char *filespec,
4763     char *outbuf,
4764     int ts,
4765     const char *defspec,
4766     unsigned opts,
4767     int * fs_utf8,
4768     int * dfs_utf8)
4769 {
4770   static char __rmsexpand_retbuf[VMS_MAXRSS];
4771   char * vmsfspec, *tmpfspec;
4772   char * esa, *cp, *out = NULL;
4773   char * tbuf;
4774   char * esal = NULL;
4775   char * outbufl;
4776   struct FAB myfab = cc$rms_fab;
4777   rms_setup_nam(mynam);
4778   STRLEN speclen;
4779   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4780   int sts;
4781
4782   /* temp hack until UTF8 is actually implemented */
4783   if (fs_utf8 != NULL)
4784     *fs_utf8 = 0;
4785
4786   if (!filespec || !*filespec) {
4787     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4788     return NULL;
4789   }
4790   if (!outbuf) {
4791     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4792     else    outbuf = __rmsexpand_retbuf;
4793   }
4794
4795   vmsfspec = NULL;
4796   tmpfspec = NULL;
4797   outbufl = NULL;
4798
4799   isunix = 0;
4800   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4801     isunix = is_unix_filespec(filespec);
4802     if (isunix) {
4803       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4804       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4805       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4806         PerlMem_free(vmsfspec);
4807         if (out)
4808            Safefree(out);
4809         return NULL;
4810       }
4811       filespec = vmsfspec;
4812
4813       /* Unless we are forcing to VMS format, a UNIX input means
4814        * UNIX output, and that requires long names to be used
4815        */
4816       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4817         opts |= PERL_RMSEXPAND_M_LONG;
4818       else {
4819         isunix = 0;
4820       }
4821     }
4822   }
4823
4824   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4825   rms_bind_fab_nam(myfab, mynam);
4826
4827   if (defspec && *defspec) {
4828     int t_isunix;
4829     t_isunix = is_unix_filespec(defspec);
4830     if (t_isunix) {
4831       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4832       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4833       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4834         PerlMem_free(tmpfspec);
4835         if (vmsfspec != NULL)
4836             PerlMem_free(vmsfspec);
4837         if (out)
4838            Safefree(out);
4839         return NULL;
4840       }
4841       defspec = tmpfspec;
4842     }
4843     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4844   }
4845
4846   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4847   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4848 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4849   esal = PerlMem_malloc(VMS_MAXRSS);
4850   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4851 #endif
4852   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4853
4854   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4855     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4856   }
4857   else {
4858 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4859     outbufl = PerlMem_malloc(VMS_MAXRSS);
4860     if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4861     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4862 #else
4863     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4864 #endif
4865   }
4866
4867 #ifdef NAM$M_NO_SHORT_UPCASE
4868   if (decc_efs_case_preserve)
4869     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4870 #endif
4871
4872    /* We may not want to follow symbolic links */
4873 #ifdef NAML$M_OPEN_SPECIAL
4874   if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
4875     rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4876 #endif
4877
4878   /* First attempt to parse as an existing file */
4879   retsts = sys$parse(&myfab,0,0);
4880   if (!(retsts & STS$K_SUCCESS)) {
4881
4882     /* Could not find the file, try as syntax only if error is not fatal */
4883     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4884     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4885       retsts = sys$parse(&myfab,0,0);
4886       if (retsts & STS$K_SUCCESS) goto expanded;
4887     }
4888
4889      /* Still could not parse the file specification */
4890     /*----------------------------------------------*/
4891     sts = rms_free_search_context(&myfab); /* Free search context */
4892     if (out) Safefree(out);
4893     if (tmpfspec != NULL)
4894         PerlMem_free(tmpfspec);
4895     if (vmsfspec != NULL)
4896         PerlMem_free(vmsfspec);
4897     if (outbufl != NULL)
4898         PerlMem_free(outbufl);
4899     PerlMem_free(esa);
4900     if (esal != NULL)
4901         PerlMem_free(esal);
4902     set_vaxc_errno(retsts);
4903     if      (retsts == RMS$_PRV) set_errno(EACCES);
4904     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4905     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4906     else                         set_errno(EVMSERR);
4907     return NULL;
4908   }
4909   retsts = sys$search(&myfab,0,0);
4910   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4911     sts = rms_free_search_context(&myfab); /* Free search context */
4912     if (out) Safefree(out);
4913     if (tmpfspec != NULL)
4914         PerlMem_free(tmpfspec);
4915     if (vmsfspec != NULL)
4916         PerlMem_free(vmsfspec);
4917     if (outbufl != NULL)
4918         PerlMem_free(outbufl);
4919     PerlMem_free(esa);
4920     if (esal != NULL)
4921         PerlMem_free(esal);
4922     set_vaxc_errno(retsts);
4923     if      (retsts == RMS$_PRV) set_errno(EACCES);
4924     else                         set_errno(EVMSERR);
4925     return NULL;
4926   }
4927
4928   /* If the input filespec contained any lowercase characters,
4929    * downcase the result for compatibility with Unix-minded code. */
4930   expanded:
4931   if (!decc_efs_case_preserve) {
4932     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4933       if (islower(*tbuf)) { haslower = 1; break; }
4934   }
4935
4936    /* Is a long or a short name expected */
4937   /*------------------------------------*/
4938   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4939     if (rms_nam_rsll(mynam)) {
4940         tbuf = outbuf;
4941         speclen = rms_nam_rsll(mynam);
4942     }
4943     else {
4944         tbuf = esal; /* Not esa */
4945         speclen = rms_nam_esll(mynam);
4946     }
4947   }
4948   else {
4949     if (rms_nam_rsl(mynam)) {
4950         tbuf = outbuf;
4951         speclen = rms_nam_rsl(mynam);
4952     }
4953     else {
4954         tbuf = esa; /* Not esal */
4955         speclen = rms_nam_esl(mynam);
4956     }
4957   }
4958   tbuf[speclen] = '\0';
4959
4960   /* Trim off null fields added by $PARSE
4961    * If type > 1 char, must have been specified in original or default spec
4962    * (not true for version; $SEARCH may have added version of existing file).
4963    */
4964   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4965   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4966     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4967              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4968   }
4969   else {
4970     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4971              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4972   }
4973   if (trimver || trimtype) {
4974     if (defspec && *defspec) {
4975       char *defesal = NULL;
4976       defesal = PerlMem_malloc(VMS_MAXRSS + 1);
4977       if (defesal != NULL) {
4978         struct FAB deffab = cc$rms_fab;
4979         rms_setup_nam(defnam);
4980
4981         rms_bind_fab_nam(deffab, defnam);
4982
4983         /* Cast ok */
4984         rms_set_fna
4985             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4986
4987         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4988
4989         rms_clear_nam_nop(defnam);
4990         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4991 #ifdef NAM$M_NO_SHORT_UPCASE
4992         if (decc_efs_case_preserve)
4993           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4994 #endif
4995 #ifdef NAML$M_OPEN_SPECIAL
4996         if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
4997           rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4998 #endif
4999         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5000           if (trimver) {
5001              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5002           }
5003           if (trimtype) {
5004             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5005           }
5006         }
5007         PerlMem_free(defesal);
5008       }
5009     }
5010     if (trimver) {
5011       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5012         if (*(rms_nam_verl(mynam)) != '\"')
5013           speclen = rms_nam_verl(mynam) - tbuf;
5014       }
5015       else {
5016         if (*(rms_nam_ver(mynam)) != '\"')
5017           speclen = rms_nam_ver(mynam) - tbuf;
5018       }
5019     }
5020     if (trimtype) {
5021       /* If we didn't already trim version, copy down */
5022       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5023         if (speclen > rms_nam_verl(mynam) - tbuf)
5024           memmove
5025            (rms_nam_typel(mynam),
5026             rms_nam_verl(mynam),
5027             speclen - (rms_nam_verl(mynam) - tbuf));
5028           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5029       }
5030       else {
5031         if (speclen > rms_nam_ver(mynam) - tbuf)
5032           memmove
5033            (rms_nam_type(mynam),
5034             rms_nam_ver(mynam),
5035             speclen - (rms_nam_ver(mynam) - tbuf));
5036           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5037       }
5038     }
5039   }
5040
5041    /* Done with these copies of the input files */
5042   /*-------------------------------------------*/
5043   if (vmsfspec != NULL)
5044         PerlMem_free(vmsfspec);
5045   if (tmpfspec != NULL)
5046         PerlMem_free(tmpfspec);
5047
5048   /* If we just had a directory spec on input, $PARSE "helpfully"
5049    * adds an empty name and type for us */
5050   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5051     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5052         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5053         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5054       speclen = rms_nam_namel(mynam) - tbuf;
5055   }
5056   else {
5057     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5058         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5059         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5060       speclen = rms_nam_name(mynam) - tbuf;
5061   }
5062
5063   /* Posix format specifications must have matching quotes */
5064   if (speclen < (VMS_MAXRSS - 1)) {
5065     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5066       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5067         tbuf[speclen] = '\"';
5068         speclen++;
5069       }
5070     }
5071   }
5072   tbuf[speclen] = '\0';
5073   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5074
5075   /* Have we been working with an expanded, but not resultant, spec? */
5076   /* Also, convert back to Unix syntax if necessary. */
5077
5078   if (!rms_nam_rsll(mynam)) {
5079     if (isunix) {
5080       if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
5081         if (out) Safefree(out);
5082         if (esal != NULL)
5083             PerlMem_free(esal);
5084         PerlMem_free(esa);
5085         if (outbufl != NULL)
5086             PerlMem_free(outbufl);
5087         return NULL;
5088       }
5089     }
5090     else strcpy(outbuf,esa);
5091   }
5092   else if (isunix) {
5093     tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5094     if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5095     if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
5096         if (out) Safefree(out);
5097         PerlMem_free(esa);
5098         if (esal != NULL)
5099             PerlMem_free(esal);
5100         PerlMem_free(tmpfspec);
5101         if (outbufl != NULL)
5102             PerlMem_free(outbufl);
5103         return NULL;
5104     }
5105     strcpy(outbuf,tmpfspec);
5106     PerlMem_free(tmpfspec);
5107   }
5108
5109   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5110   sts = rms_free_search_context(&myfab); /* Free search context */
5111   PerlMem_free(esa);
5112   if (esal != NULL)
5113      PerlMem_free(esal);
5114   if (outbufl != NULL)
5115      PerlMem_free(outbufl);
5116   return outbuf;
5117 }
5118 /*}}}*/
5119 /* External entry points */
5120 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5121 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5122 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5123 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5124 char *Perl_rmsexpand_utf8
5125   (pTHX_ const char *spec, char *buf, const char *def,
5126    unsigned opt, int * fs_utf8, int * dfs_utf8)
5127 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5128 char *Perl_rmsexpand_utf8_ts
5129   (pTHX_ const char *spec, char *buf, const char *def,
5130    unsigned opt, int * fs_utf8, int * dfs_utf8)
5131 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5132
5133
5134 /*
5135 ** The following routines are provided to make life easier when
5136 ** converting among VMS-style and Unix-style directory specifications.
5137 ** All will take input specifications in either VMS or Unix syntax. On
5138 ** failure, all return NULL.  If successful, the routines listed below
5139 ** return a pointer to a buffer containing the appropriately
5140 ** reformatted spec (and, therefore, subsequent calls to that routine
5141 ** will clobber the result), while the routines of the same names with
5142 ** a _ts suffix appended will return a pointer to a mallocd string
5143 ** containing the appropriately reformatted spec.
5144 ** In all cases, only explicit syntax is altered; no check is made that
5145 ** the resulting string is valid or that the directory in question
5146 ** actually exists.
5147 **
5148 **   fileify_dirspec() - convert a directory spec into the name of the
5149 **     directory file (i.e. what you can stat() to see if it's a dir).
5150 **     The style (VMS or Unix) of the result is the same as the style
5151 **     of the parameter passed in.
5152 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5153 **     what you prepend to a filename to indicate what directory it's in).
5154 **     The style (VMS or Unix) of the result is the same as the style
5155 **     of the parameter passed in.
5156 **   tounixpath() - convert a directory spec into a Unix-style path.
5157 **   tovmspath() - convert a directory spec into a VMS-style path.
5158 **   tounixspec() - convert any file spec into a Unix-style file spec.
5159 **   tovmsspec() - convert any file spec into a VMS-style spec.
5160 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5161 **
5162 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5163 ** Permission is given to distribute this code as part of the Perl
5164 ** standard distribution under the terms of the GNU General Public
5165 ** License or the Perl Artistic License.  Copies of each may be
5166 ** found in the Perl standard distribution.
5167  */
5168
5169 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5170 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5171 {
5172     static char __fileify_retbuf[VMS_MAXRSS];
5173     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5174     char *retspec, *cp1, *cp2, *lastdir;
5175     char *trndir, *vmsdir;
5176     unsigned short int trnlnm_iter_count;
5177     int sts;
5178     if (utf8_fl != NULL)
5179         *utf8_fl = 0;
5180
5181     if (!dir || !*dir) {
5182       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5183     }
5184     dirlen = strlen(dir);
5185     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5186     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5187       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5188         dir = "/sys$disk";
5189         dirlen = 9;
5190       }
5191       else
5192         dirlen = 1;
5193     }
5194     if (dirlen > (VMS_MAXRSS - 1)) {
5195       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5196       return NULL;
5197     }
5198     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5199     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5200     if (!strpbrk(dir+1,"/]>:")  &&
5201         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5202       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5203       trnlnm_iter_count = 0;
5204       while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5205         trnlnm_iter_count++;
5206         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5207       }
5208       dirlen = strlen(trndir);
5209     }
5210     else {
5211       strncpy(trndir,dir,dirlen);
5212       trndir[dirlen] = '\0';
5213     }
5214
5215     /* At this point we are done with *dir and use *trndir which is a
5216      * copy that can be modified.  *dir must not be modified.
5217      */
5218
5219     /* If we were handed a rooted logical name or spec, treat it like a
5220      * simple directory, so that
5221      *    $ Define myroot dev:[dir.]
5222      *    ... do_fileify_dirspec("myroot",buf,1) ...
5223      * does something useful.
5224      */
5225     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5226       trndir[--dirlen] = '\0';
5227       trndir[dirlen-1] = ']';
5228     }
5229     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5230       trndir[--dirlen] = '\0';
5231       trndir[dirlen-1] = '>';
5232     }
5233
5234     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5235       /* If we've got an explicit filename, we can just shuffle the string. */
5236       if (*(cp1+1)) hasfilename = 1;
5237       /* Similarly, we can just back up a level if we've got multiple levels
5238          of explicit directories in a VMS spec which ends with directories. */
5239       else {
5240         for (cp2 = cp1; cp2 > trndir; cp2--) {
5241           if (*cp2 == '.') {
5242             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5243 /* fix-me, can not scan EFS file specs backward like this */
5244               *cp2 = *cp1; *cp1 = '\0';
5245               hasfilename = 1;
5246               break;
5247             }
5248           }
5249           if (*cp2 == '[' || *cp2 == '<') break;
5250         }
5251       }
5252     }
5253
5254     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5255     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5256     cp1 = strpbrk(trndir,"]:>");
5257     if (hasfilename || !cp1) { /* Unix-style path or filename */
5258       if (trndir[0] == '.') {
5259         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5260           PerlMem_free(trndir);
5261           PerlMem_free(vmsdir);
5262           return do_fileify_dirspec("[]",buf,ts,NULL);
5263         }
5264         else if (trndir[1] == '.' &&
5265                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5266           PerlMem_free(trndir);
5267           PerlMem_free(vmsdir);
5268           return do_fileify_dirspec("[-]",buf,ts,NULL);
5269         }
5270       }
5271       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5272         dirlen -= 1;                 /* to last element */
5273         lastdir = strrchr(trndir,'/');
5274       }
5275       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5276         /* If we have "/." or "/..", VMSify it and let the VMS code
5277          * below expand it, rather than repeating the code to handle
5278          * relative components of a filespec here */
5279         do {
5280           if (*(cp1+2) == '.') cp1++;
5281           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5282             char * ret_chr;
5283             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5284                 PerlMem_free(trndir);
5285                 PerlMem_free(vmsdir);
5286                 return NULL;
5287             }
5288             if (strchr(vmsdir,'/') != NULL) {
5289               /* If do_tovmsspec() returned it, it must have VMS syntax
5290                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5291                * the time to check this here only so we avoid a recursion
5292                * loop; otherwise, gigo.
5293                */
5294               PerlMem_free(trndir);
5295               PerlMem_free(vmsdir);
5296               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5297               return NULL;
5298             }
5299             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5300                 PerlMem_free(trndir);
5301                 PerlMem_free(vmsdir);
5302                 return NULL;
5303             }
5304             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5305             PerlMem_free(trndir);
5306             PerlMem_free(vmsdir);
5307             return ret_chr;
5308           }
5309           cp1++;
5310         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5311         lastdir = strrchr(trndir,'/');
5312       }
5313       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5314         char * ret_chr;
5315         /* Ditto for specs that end in an MFD -- let the VMS code
5316          * figure out whether it's a real device or a rooted logical. */
5317
5318         /* This should not happen any more.  Allowing the fake /000000
5319          * in a UNIX pathname causes all sorts of problems when trying
5320          * to run in UNIX emulation.  So the VMS to UNIX conversions
5321          * now remove the fake /000000 directories.
5322          */
5323
5324         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5325         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5326             PerlMem_free(trndir);
5327             PerlMem_free(vmsdir);
5328             return NULL;
5329         }
5330         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5331             PerlMem_free(trndir);
5332             PerlMem_free(vmsdir);
5333             return NULL;
5334         }
5335         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5336         PerlMem_free(trndir);
5337         PerlMem_free(vmsdir);
5338         return ret_chr;
5339       }
5340       else {
5341
5342         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5343              !(lastdir = cp1 = strrchr(trndir,']')) &&
5344              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5345         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5346           int ver; char *cp3;
5347
5348           /* For EFS or ODS-5 look for the last dot */
5349           if (decc_efs_charset) {
5350               cp2 = strrchr(cp1,'.');
5351           }
5352           if (vms_process_case_tolerant) {
5353               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5354                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5355                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5356                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5357                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5358                             (ver || *cp3)))))) {
5359                   PerlMem_free(trndir);
5360                   PerlMem_free(vmsdir);
5361                   set_errno(ENOTDIR);
5362                   set_vaxc_errno(RMS$_DIR);
5363                   return NULL;
5364               }
5365           }
5366           else {
5367               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5368                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5369                   !*(cp2+3) || *(cp2+3) != 'R' ||
5370                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5371                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5372                             (ver || *cp3)))))) {
5373                  PerlMem_free(trndir);
5374                  PerlMem_free(vmsdir);
5375                  set_errno(ENOTDIR);
5376                  set_vaxc_errno(RMS$_DIR);
5377                  return NULL;
5378               }
5379           }
5380           dirlen = cp2 - trndir;
5381         }
5382       }
5383
5384       retlen = dirlen + 6;
5385       if (buf) retspec = buf;
5386       else if (ts) Newx(retspec,retlen+1,char);
5387       else retspec = __fileify_retbuf;
5388       memcpy(retspec,trndir,dirlen);
5389       retspec[dirlen] = '\0';
5390
5391       /* We've picked up everything up to the directory file name.
5392          Now just add the type and version, and we're set. */
5393       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5394         strcat(retspec,".dir;1");
5395       else
5396         strcat(retspec,".DIR;1");
5397       PerlMem_free(trndir);
5398       PerlMem_free(vmsdir);
5399       return retspec;
5400     }
5401     else {  /* VMS-style directory spec */
5402
5403       char *esa, term, *cp;
5404       unsigned long int sts, cmplen, haslower = 0;
5405       unsigned int nam_fnb;
5406       char * nam_type;
5407       struct FAB dirfab = cc$rms_fab;
5408       rms_setup_nam(savnam);
5409       rms_setup_nam(dirnam);
5410
5411       esa = PerlMem_malloc(VMS_MAXRSS + 1);
5412       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5413       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5414       rms_bind_fab_nam(dirfab, dirnam);
5415       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5416       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5417 #ifdef NAM$M_NO_SHORT_UPCASE
5418       if (decc_efs_case_preserve)
5419         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5420 #endif
5421
5422       for (cp = trndir; *cp; cp++)
5423         if (islower(*cp)) { haslower = 1; break; }
5424       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5425         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5426           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5427           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5428         }
5429         if (!sts) {
5430           PerlMem_free(esa);
5431           PerlMem_free(trndir);
5432           PerlMem_free(vmsdir);
5433           set_errno(EVMSERR);
5434           set_vaxc_errno(dirfab.fab$l_sts);
5435           return NULL;
5436         }
5437       }
5438       else {
5439         savnam = dirnam;
5440         /* Does the file really exist? */
5441         if (sys$search(&dirfab)& STS$K_SUCCESS) {
5442           /* Yes; fake the fnb bits so we'll check type below */
5443         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5444         }
5445         else { /* No; just work with potential name */
5446           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5447           else {
5448             int fab_sts;
5449             fab_sts = dirfab.fab$l_sts;
5450             sts = rms_free_search_context(&dirfab);
5451             PerlMem_free(esa);
5452             PerlMem_free(trndir);
5453             PerlMem_free(vmsdir);
5454             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
5455             return NULL;
5456           }
5457         }
5458       }
5459       esa[rms_nam_esll(dirnam)] = '\0';
5460       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5461         cp1 = strchr(esa,']');
5462         if (!cp1) cp1 = strchr(esa,'>');
5463         if (cp1) {  /* Should always be true */
5464           rms_nam_esll(dirnam) -= cp1 - esa - 1;
5465           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5466         }
5467       }
5468       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5469         /* Yep; check version while we're at it, if it's there. */
5470         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5471         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5472           /* Something other than .DIR[;1].  Bzzt. */
5473           sts = rms_free_search_context(&dirfab);
5474           PerlMem_free(esa);
5475           PerlMem_free(trndir);
5476           PerlMem_free(vmsdir);
5477           set_errno(ENOTDIR);
5478           set_vaxc_errno(RMS$_DIR);
5479           return NULL;
5480         }
5481       }
5482
5483       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5484         /* They provided at least the name; we added the type, if necessary, */
5485         if (buf) retspec = buf;                            /* in sys$parse() */
5486         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5487         else retspec = __fileify_retbuf;
5488         strcpy(retspec,esa);
5489         sts = rms_free_search_context(&dirfab);
5490         PerlMem_free(trndir);
5491         PerlMem_free(esa);
5492         PerlMem_free(vmsdir);
5493         return retspec;
5494       }
5495       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5496         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5497         *cp1 = '\0';
5498         rms_nam_esll(dirnam) -= 9;
5499       }
5500       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5501       if (cp1 == NULL) { /* should never happen */
5502         sts = rms_free_search_context(&dirfab);
5503         PerlMem_free(trndir);
5504         PerlMem_free(esa);
5505         PerlMem_free(vmsdir);
5506         return NULL;
5507       }
5508       term = *cp1;
5509       *cp1 = '\0';
5510       retlen = strlen(esa);
5511       cp1 = strrchr(esa,'.');
5512       /* ODS-5 directory specifications can have extra "." in them. */
5513       /* Fix-me, can not scan EFS file specifications backwards */
5514       while (cp1 != NULL) {
5515         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5516           break;
5517         else {
5518            cp1--;
5519            while ((cp1 > esa) && (*cp1 != '.'))
5520              cp1--;
5521         }
5522         if (cp1 == esa)
5523           cp1 = NULL;
5524       }
5525
5526       if ((cp1) != NULL) {
5527         /* There's more than one directory in the path.  Just roll back. */
5528         *cp1 = term;
5529         if (buf) retspec = buf;
5530         else if (ts) Newx(retspec,retlen+7,char);
5531         else retspec = __fileify_retbuf;
5532         strcpy(retspec,esa);
5533       }
5534       else {
5535         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5536           /* Go back and expand rooted logical name */
5537           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5538 #ifdef NAM$M_NO_SHORT_UPCASE
5539           if (decc_efs_case_preserve)
5540             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5541 #endif
5542           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5543             sts = rms_free_search_context(&dirfab);
5544             PerlMem_free(esa);
5545             PerlMem_free(trndir);
5546             PerlMem_free(vmsdir);
5547             set_errno(EVMSERR);
5548             set_vaxc_errno(dirfab.fab$l_sts);
5549             return NULL;
5550           }
5551           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5552           if (buf) retspec = buf;
5553           else if (ts) Newx(retspec,retlen+16,char);
5554           else retspec = __fileify_retbuf;
5555           cp1 = strstr(esa,"][");
5556           if (!cp1) cp1 = strstr(esa,"]<");
5557           dirlen = cp1 - esa;
5558           memcpy(retspec,esa,dirlen);
5559           if (!strncmp(cp1+2,"000000]",7)) {
5560             retspec[dirlen-1] = '\0';
5561             /* fix-me Not full ODS-5, just extra dots in directories for now */
5562             cp1 = retspec + dirlen - 1;
5563             while (cp1 > retspec)
5564             {
5565               if (*cp1 == '[')
5566                 break;
5567               if (*cp1 == '.') {
5568                 if (*(cp1-1) != '^')
5569                   break;
5570               }
5571               cp1--;
5572             }
5573             if (*cp1 == '.') *cp1 = ']';
5574             else {
5575               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5576               memmove(cp1+1,"000000]",7);
5577             }
5578           }
5579           else {
5580             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5581             retspec[retlen] = '\0';
5582             /* Convert last '.' to ']' */
5583             cp1 = retspec+retlen-1;
5584             while (*cp != '[') {
5585               cp1--;
5586               if (*cp1 == '.') {
5587                 /* Do not trip on extra dots in ODS-5 directories */
5588                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5589                 break;
5590               }
5591             }
5592             if (*cp1 == '.') *cp1 = ']';
5593             else {
5594               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5595               memmove(cp1+1,"000000]",7);
5596             }
5597           }
5598         }
5599         else {  /* This is a top-level dir.  Add the MFD to the path. */
5600           if (buf) retspec = buf;
5601           else if (ts) Newx(retspec,retlen+16,char);
5602           else retspec = __fileify_retbuf;
5603           cp1 = esa;
5604           cp2 = retspec;
5605           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5606           strcpy(cp2,":[000000]");
5607           cp1 += 2;
5608           strcpy(cp2+9,cp1);
5609         }
5610       }
5611       sts = rms_free_search_context(&dirfab);
5612       /* We've set up the string up through the filename.  Add the
5613          type and version, and we're done. */
5614       strcat(retspec,".DIR;1");
5615
5616       /* $PARSE may have upcased filespec, so convert output to lower
5617        * case if input contained any lowercase characters. */
5618       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5619       PerlMem_free(trndir);
5620       PerlMem_free(esa);
5621       PerlMem_free(vmsdir);
5622       return retspec;
5623     }
5624 }  /* end of do_fileify_dirspec() */
5625 /*}}}*/
5626 /* External entry points */
5627 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5628 { return do_fileify_dirspec(dir,buf,0,NULL); }
5629 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5630 { return do_fileify_dirspec(dir,buf,1,NULL); }
5631 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5632 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5633 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5634 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5635
5636 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5637 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5638 {
5639     static char __pathify_retbuf[VMS_MAXRSS];
5640     unsigned long int retlen;
5641     char *retpath, *cp1, *cp2, *trndir;
5642     unsigned short int trnlnm_iter_count;
5643     STRLEN trnlen;
5644     int sts;
5645     if (utf8_fl != NULL)
5646         *utf8_fl = 0;
5647
5648     if (!dir || !*dir) {
5649       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5650     }
5651
5652     trndir = PerlMem_malloc(VMS_MAXRSS);
5653     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5654     if (*dir) strcpy(trndir,dir);
5655     else getcwd(trndir,VMS_MAXRSS - 1);
5656
5657     trnlnm_iter_count = 0;
5658     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5659            && my_trnlnm(trndir,trndir,0)) {
5660       trnlnm_iter_count++;
5661       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5662       trnlen = strlen(trndir);
5663
5664       /* Trap simple rooted lnms, and return lnm:[000000] */
5665       if (!strcmp(trndir+trnlen-2,".]")) {
5666         if (buf) retpath = buf;
5667         else if (ts) Newx(retpath,strlen(dir)+10,char);
5668         else retpath = __pathify_retbuf;
5669         strcpy(retpath,dir);
5670         strcat(retpath,":[000000]");
5671         PerlMem_free(trndir);
5672         return retpath;
5673       }
5674     }
5675
5676     /* At this point we do not work with *dir, but the copy in
5677      * *trndir that is modifiable.
5678      */
5679
5680     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5681       if (*trndir == '.' && (*(trndir+1) == '\0' ||
5682                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5683         retlen = 2 + (*(trndir+1) != '\0');
5684       else {
5685         if ( !(cp1 = strrchr(trndir,'/')) &&
5686              !(cp1 = strrchr(trndir,']')) &&
5687              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5688         if ((cp2 = strchr(cp1,'.')) != NULL &&
5689             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
5690              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
5691               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5692               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5693           int ver; char *cp3;
5694
5695           /* For EFS or ODS-5 look for the last dot */
5696           if (decc_efs_charset) {
5697             cp2 = strrchr(cp1,'.');
5698           }
5699           if (vms_process_case_tolerant) {
5700               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5701                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5702                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5703                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5704                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5705                             (ver || *cp3)))))) {
5706                 PerlMem_free(trndir);
5707                 set_errno(ENOTDIR);
5708                 set_vaxc_errno(RMS$_DIR);
5709                 return NULL;
5710               }
5711           }
5712           else {
5713               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5714                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5715                   !*(cp2+3) || *(cp2+3) != 'R' ||
5716                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5717                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5718                             (ver || *cp3)))))) {
5719                 PerlMem_free(trndir);
5720                 set_errno(ENOTDIR);
5721                 set_vaxc_errno(RMS$_DIR);
5722                 return NULL;
5723               }
5724           }
5725           retlen = cp2 - trndir + 1;
5726         }
5727         else {  /* No file type present.  Treat the filename as a directory. */
5728           retlen = strlen(trndir) + 1;
5729         }
5730       }
5731       if (buf) retpath = buf;
5732       else if (ts) Newx(retpath,retlen+1,char);
5733       else retpath = __pathify_retbuf;
5734       strncpy(retpath, trndir, retlen-1);
5735       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5736         retpath[retlen-1] = '/';      /* with '/', add it. */
5737         retpath[retlen] = '\0';
5738       }
5739       else retpath[retlen-1] = '\0';
5740     }
5741     else {  /* VMS-style directory spec */
5742       char *esa, *cp;
5743       unsigned long int sts, cmplen, haslower;
5744       struct FAB dirfab = cc$rms_fab;
5745       int dirlen;
5746       rms_setup_nam(savnam);
5747       rms_setup_nam(dirnam);
5748
5749       /* If we've got an explicit filename, we can just shuffle the string. */
5750       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5751              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
5752         if ((cp2 = strchr(cp1,'.')) != NULL) {
5753           int ver; char *cp3;
5754           if (vms_process_case_tolerant) {
5755               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5756                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5757                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5758                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5759                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5760                             (ver || *cp3)))))) {
5761                PerlMem_free(trndir);
5762                set_errno(ENOTDIR);
5763                set_vaxc_errno(RMS$_DIR);
5764                return NULL;
5765              }
5766           }
5767           else {
5768               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5769                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5770                   !*(cp2+3) || *(cp2+3) != 'R' ||
5771                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5772                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5773                             (ver || *cp3)))))) {
5774                PerlMem_free(trndir);
5775                set_errno(ENOTDIR);
5776                set_vaxc_errno(RMS$_DIR);
5777                return NULL;
5778              }
5779           }
5780         }
5781         else {  /* No file type, so just draw name into directory part */
5782           for (cp2 = cp1; *cp2; cp2++) ;
5783         }
5784         *cp2 = *cp1;
5785         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5786         *cp1 = '.';
5787         /* We've now got a VMS 'path'; fall through */
5788       }
5789
5790       dirlen = strlen(trndir);
5791       if (trndir[dirlen-1] == ']' ||
5792           trndir[dirlen-1] == '>' ||
5793           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5794         if (buf) retpath = buf;
5795         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5796         else retpath = __pathify_retbuf;
5797         strcpy(retpath,trndir);
5798         PerlMem_free(trndir);
5799         return retpath;
5800       }
5801       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5802       esa = PerlMem_malloc(VMS_MAXRSS);
5803       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5804       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5805       rms_bind_fab_nam(dirfab, dirnam);
5806       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5807 #ifdef NAM$M_NO_SHORT_UPCASE
5808       if (decc_efs_case_preserve)
5809           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5810 #endif
5811
5812       for (cp = trndir; *cp; cp++)
5813         if (islower(*cp)) { haslower = 1; break; }
5814
5815       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5816         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5817           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5818           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5819         }
5820         if (!sts) {
5821           PerlMem_free(trndir);
5822           PerlMem_free(esa);
5823           set_errno(EVMSERR);
5824           set_vaxc_errno(dirfab.fab$l_sts);
5825           return NULL;
5826         }
5827       }
5828       else {
5829         savnam = dirnam;
5830         /* Does the file really exist? */
5831         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5832           if (dirfab.fab$l_sts != RMS$_FNF) {
5833             int sts1;
5834             sts1 = rms_free_search_context(&dirfab);
5835             PerlMem_free(trndir);
5836             PerlMem_free(esa);
5837             set_errno(EVMSERR);
5838             set_vaxc_errno(dirfab.fab$l_sts);
5839             return NULL;
5840           }
5841           dirnam = savnam; /* No; just work with potential name */
5842         }
5843       }
5844       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5845         /* Yep; check version while we're at it, if it's there. */
5846         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5847         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5848           int sts2;
5849           /* Something other than .DIR[;1].  Bzzt. */
5850           sts2 = rms_free_search_context(&dirfab);
5851           PerlMem_free(trndir);
5852           PerlMem_free(esa);
5853           set_errno(ENOTDIR);
5854           set_vaxc_errno(RMS$_DIR);
5855           return NULL;
5856         }
5857       }
5858       /* OK, the type was fine.  Now pull any file name into the
5859          directory path. */
5860       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5861       else {
5862         cp1 = strrchr(esa,'>');
5863         *(rms_nam_typel(dirnam)) = '>';
5864       }
5865       *cp1 = '.';
5866       *(rms_nam_typel(dirnam) + 1) = '\0';
5867       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5868       if (buf) retpath = buf;
5869       else if (ts) Newx(retpath,retlen,char);
5870       else retpath = __pathify_retbuf;
5871       strcpy(retpath,esa);
5872       PerlMem_free(esa);
5873       sts = rms_free_search_context(&dirfab);
5874       /* $PARSE may have upcased filespec, so convert output to lower
5875        * case if input contained any lowercase characters. */
5876       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5877     }
5878
5879     PerlMem_free(trndir);
5880     return retpath;
5881 }  /* end of do_pathify_dirspec() */
5882 /*}}}*/
5883 /* External entry points */
5884 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5885 { return do_pathify_dirspec(dir,buf,0,NULL); }
5886 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5887 { return do_pathify_dirspec(dir,buf,1,NULL); }
5888 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5889 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5890 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5891 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5892
5893 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5894 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5895 {
5896   static char __tounixspec_retbuf[VMS_MAXRSS];
5897   char *dirend, *rslt, *cp1, *cp3, *tmp;
5898   const char *cp2;
5899   int devlen, dirlen, retlen = VMS_MAXRSS;
5900   int expand = 1; /* guarantee room for leading and trailing slashes */
5901   unsigned short int trnlnm_iter_count;
5902   int cmp_rslt;
5903   if (utf8_fl != NULL)
5904     *utf8_fl = 0;
5905
5906   if (spec == NULL) return NULL;
5907   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5908   if (buf) rslt = buf;
5909   else if (ts) {
5910     Newx(rslt, VMS_MAXRSS, char);
5911   }
5912   else rslt = __tounixspec_retbuf;
5913
5914   /* New VMS specific format needs translation
5915    * glob passes filenames with trailing '\n' and expects this preserved.
5916    */
5917   if (decc_posix_compliant_pathnames) {
5918     if (strncmp(spec, "\"^UP^", 5) == 0) {
5919       char * uspec;
5920       char *tunix;
5921       int tunix_len;
5922       int nl_flag;
5923
5924       tunix = PerlMem_malloc(VMS_MAXRSS);
5925       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5926       strcpy(tunix, spec);
5927       tunix_len = strlen(tunix);
5928       nl_flag = 0;
5929       if (tunix[tunix_len - 1] == '\n') {
5930         tunix[tunix_len - 1] = '\"';
5931         tunix[tunix_len] = '\0';
5932         tunix_len--;
5933         nl_flag = 1;
5934       }
5935       uspec = decc$translate_vms(tunix);
5936       PerlMem_free(tunix);
5937       if ((int)uspec > 0) {
5938         strcpy(rslt,uspec);
5939         if (nl_flag) {
5940           strcat(rslt,"\n");
5941         }
5942         else {
5943           /* If we can not translate it, makemaker wants as-is */
5944           strcpy(rslt, spec);
5945         }
5946         return rslt;
5947       }
5948     }
5949   }
5950
5951   cmp_rslt = 0; /* Presume VMS */
5952   cp1 = strchr(spec, '/');
5953   if (cp1 == NULL)
5954     cmp_rslt = 0;
5955
5956     /* Look for EFS ^/ */
5957     if (decc_efs_charset) {
5958       while (cp1 != NULL) {
5959         cp2 = cp1 - 1;
5960         if (*cp2 != '^') {
5961           /* Found illegal VMS, assume UNIX */
5962           cmp_rslt = 1;
5963           break;
5964         }
5965       cp1++;
5966       cp1 = strchr(cp1, '/');
5967     }
5968   }
5969
5970   /* Look for "." and ".." */
5971   if (decc_filename_unix_report) {
5972     if (spec[0] == '.') {
5973       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5974         cmp_rslt = 1;
5975       }
5976       else {
5977         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5978           cmp_rslt = 1;
5979         }
5980       }
5981     }
5982   }
5983   /* This is already UNIX or at least nothing VMS understands */
5984   if (cmp_rslt) {
5985     strcpy(rslt,spec);
5986     return rslt;
5987   }
5988
5989   cp1 = rslt;
5990   cp2 = spec;
5991   dirend = strrchr(spec,']');
5992   if (dirend == NULL) dirend = strrchr(spec,'>');
5993   if (dirend == NULL) dirend = strchr(spec,':');
5994   if (dirend == NULL) {
5995     strcpy(rslt,spec);
5996     return rslt;
5997   }
5998
5999   /* Special case 1 - sys$posix_root = / */
6000 #if __CRTL_VER >= 70000000
6001   if (!decc_disable_posix_root) {
6002     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6003       *cp1 = '/';
6004       cp1++;
6005       cp2 = cp2 + 15;
6006       }
6007   }
6008 #endif
6009
6010   /* Special case 2 - Convert NLA0: to /dev/null */
6011 #if __CRTL_VER < 70000000
6012   cmp_rslt = strncmp(spec,"NLA0:", 5);
6013   if (cmp_rslt != 0)
6014      cmp_rslt = strncmp(spec,"nla0:", 5);
6015 #else
6016   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6017 #endif
6018   if (cmp_rslt == 0) {
6019     strcpy(rslt, "/dev/null");
6020     cp1 = cp1 + 9;
6021     cp2 = cp2 + 5;
6022     if (spec[6] != '\0') {
6023       cp1[9] == '/';
6024       cp1++;
6025       cp2++;
6026     }
6027   }
6028
6029    /* Also handle special case "SYS$SCRATCH:" */
6030 #if __CRTL_VER < 70000000
6031   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6032   if (cmp_rslt != 0)
6033      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6034 #else
6035   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6036 #endif
6037   tmp = PerlMem_malloc(VMS_MAXRSS);
6038   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6039   if (cmp_rslt == 0) {
6040   int islnm;
6041
6042     islnm = my_trnlnm(tmp, "TMP", 0);
6043     if (!islnm) {
6044       strcpy(rslt, "/tmp");
6045       cp1 = cp1 + 4;
6046       cp2 = cp2 + 12;
6047       if (spec[12] != '\0') {
6048         cp1[4] == '/';
6049         cp1++;
6050         cp2++;
6051       }
6052     }
6053   }
6054
6055   if (*cp2 != '[' && *cp2 != '<') {
6056     *(cp1++) = '/';
6057   }
6058   else {  /* the VMS spec begins with directories */
6059     cp2++;
6060     if (*cp2 == ']' || *cp2 == '>') {
6061       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6062       PerlMem_free(tmp);
6063       return rslt;
6064     }
6065     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6066       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6067         if (ts) Safefree(rslt);
6068         PerlMem_free(tmp);
6069         return NULL;
6070       }
6071       trnlnm_iter_count = 0;
6072       do {
6073         cp3 = tmp;
6074         while (*cp3 != ':' && *cp3) cp3++;
6075         *(cp3++) = '\0';
6076         if (strchr(cp3,']') != NULL) break;
6077         trnlnm_iter_count++;
6078         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6079       } while (vmstrnenv(tmp,tmp,0,fildev,0));
6080       if (ts && !buf &&
6081           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6082         retlen = devlen + dirlen;
6083         Renew(rslt,retlen+1+2*expand,char);
6084         cp1 = rslt;
6085       }
6086       cp3 = tmp;
6087       *(cp1++) = '/';
6088       while (*cp3) {
6089         *(cp1++) = *(cp3++);
6090         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6091             PerlMem_free(tmp);
6092             return NULL; /* No room */
6093         }
6094       }
6095       *(cp1++) = '/';
6096     }
6097     if ((*cp2 == '^')) {
6098         /* EFS file escape, pass the next character as is */
6099         /* Fix me: HEX encoding for Unicode not implemented */
6100         cp2++;
6101     }
6102     else if ( *cp2 == '.') {
6103       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6104         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6105         cp2 += 3;
6106       }
6107       else cp2++;
6108     }
6109   }
6110   PerlMem_free(tmp);
6111   for (; cp2 <= dirend; cp2++) {
6112     if ((*cp2 == '^')) {
6113         /* EFS file escape, pass the next character as is */
6114         /* Fix me: HEX encoding for Unicode not implemented */
6115         *(cp1++) = *(++cp2);
6116         /* An escaped dot stays as is -- don't convert to slash */
6117         if (*cp2 == '.') cp2++;
6118     }
6119     if (*cp2 == ':') {
6120       *(cp1++) = '/';
6121       if (*(cp2+1) == '[') cp2++;
6122     }
6123     else if (*cp2 == ']' || *cp2 == '>') {
6124       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6125     }
6126     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6127       *(cp1++) = '/';
6128       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6129         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6130                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6131         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6132             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6133       }
6134       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6135         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6136         cp2 += 2;
6137       }
6138     }
6139     else if (*cp2 == '-') {
6140       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6141         while (*cp2 == '-') {
6142           cp2++;
6143           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6144         }
6145         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6146           if (ts) Safefree(rslt);                        /* filespecs like */
6147           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
6148           return NULL;
6149         }
6150       }
6151       else *(cp1++) = *cp2;
6152     }
6153     else *(cp1++) = *cp2;
6154   }
6155   while (*cp2) {
6156     if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++;  /* '^.' --> '.' */
6157     *(cp1++) = *(cp2++);
6158   }
6159   *cp1 = '\0';
6160
6161   /* This still leaves /000000/ when working with a
6162    * VMS device root or concealed root.
6163    */
6164   {
6165   int ulen;
6166   char * zeros;
6167
6168       ulen = strlen(rslt);
6169
6170       /* Get rid of "000000/ in rooted filespecs */
6171       if (ulen > 7) {
6172         zeros = strstr(rslt, "/000000/");
6173         if (zeros != NULL) {
6174           int mlen;
6175           mlen = ulen - (zeros - rslt) - 7;
6176           memmove(zeros, &zeros[7], mlen);
6177           ulen = ulen - 7;
6178           rslt[ulen] = '\0';
6179         }
6180       }
6181   }
6182
6183   return rslt;
6184
6185 }  /* end of do_tounixspec() */
6186 /*}}}*/
6187 /* External entry points */
6188 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6189   { return do_tounixspec(spec,buf,0, NULL); }
6190 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6191   { return do_tounixspec(spec,buf,1, NULL); }
6192 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6193   { return do_tounixspec(spec,buf,0, utf8_fl); }
6194 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6195   { return do_tounixspec(spec,buf,1, utf8_fl); }
6196
6197 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6198
6199 /*
6200  This procedure is used to identify if a path is based in either
6201  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6202  it returns the OpenVMS format directory for it.
6203
6204  It is expecting specifications of only '/' or '/xxxx/'
6205
6206  If a posix root does not exist, or 'xxxx' is not a directory
6207  in the posix root, it returns a failure.
6208
6209  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6210
6211  It is used only internally by posix_to_vmsspec_hardway().
6212  */
6213
6214 static int posix_root_to_vms
6215   (char *vmspath, int vmspath_len,
6216    const char *unixpath,
6217    const int * utf8_fl) {
6218 int sts;
6219 struct FAB myfab = cc$rms_fab;
6220 struct NAML mynam = cc$rms_naml;
6221 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6222  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6223 char *esa;
6224 char *vms_delim;
6225 int dir_flag;
6226 int unixlen;
6227
6228     dir_flag = 0;
6229     unixlen = strlen(unixpath);
6230     if (unixlen == 0) {
6231       vmspath[0] = '\0';
6232       return RMS$_FNF;
6233     }
6234
6235 #if __CRTL_VER >= 80200000
6236   /* If not a posix spec already, convert it */
6237   if (decc_posix_compliant_pathnames) {
6238     if (strncmp(unixpath,"\"^UP^",5) != 0) {
6239       sprintf(vmspath,"\"^UP^%s\"",unixpath);
6240     }
6241     else {
6242       /* This is already a VMS specification, no conversion */
6243       unixlen--;
6244       strncpy(vmspath,unixpath, vmspath_len);
6245     }
6246   }
6247   else
6248 #endif
6249   {
6250   int path_len;
6251   int i,j;
6252
6253      /* Check to see if this is under the POSIX root */
6254      if (decc_disable_posix_root) {
6255         return RMS$_FNF;
6256      }
6257
6258      /* Skip leading / */
6259      if (unixpath[0] == '/') {
6260         unixpath++;
6261         unixlen--;
6262      }
6263
6264
6265      strcpy(vmspath,"SYS$POSIX_ROOT:");
6266
6267      /* If this is only the / , or blank, then... */
6268      if (unixpath[0] == '\0') {
6269         /* by definition, this is the answer */
6270         return SS$_NORMAL;
6271      }
6272
6273      /* Need to look up a directory */
6274      vmspath[15] = '[';
6275      vmspath[16] = '\0';
6276
6277      /* Copy and add '^' escape characters as needed */
6278      j = 16;
6279      i = 0;
6280      while (unixpath[i] != 0) {
6281      int k;
6282
6283         j += copy_expand_unix_filename_escape
6284             (&vmspath[j], &unixpath[i], &k, utf8_fl);
6285         i += k;
6286      }
6287
6288      path_len = strlen(vmspath);
6289      if (vmspath[path_len - 1] == '/')
6290         path_len--;
6291      vmspath[path_len] = ']';
6292      path_len++;
6293      vmspath[path_len] = '\0';
6294
6295   }
6296   vmspath[vmspath_len] = 0;
6297   if (unixpath[unixlen - 1] == '/')
6298   dir_flag = 1;
6299   esa = PerlMem_malloc(VMS_MAXRSS);
6300   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6301   myfab.fab$l_fna = vmspath;
6302   myfab.fab$b_fns = strlen(vmspath);
6303   myfab.fab$l_naml = &mynam;
6304   mynam.naml$l_esa = NULL;
6305   mynam.naml$b_ess = 0;
6306   mynam.naml$l_long_expand = esa;
6307   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6308   mynam.naml$l_rsa = NULL;
6309   mynam.naml$b_rss = 0;
6310   if (decc_efs_case_preserve)
6311     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6312 #ifdef NAML$M_OPEN_SPECIAL
6313   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6314 #endif
6315
6316   /* Set up the remaining naml fields */
6317   sts = sys$parse(&myfab);
6318
6319   /* It failed! Try again as a UNIX filespec */
6320   if (!(sts & 1)) {
6321     PerlMem_free(esa);
6322     return sts;
6323   }
6324
6325    /* get the Device ID and the FID */
6326    sts = sys$search(&myfab);
6327    /* on any failure, returned the POSIX ^UP^ filespec */
6328    if (!(sts & 1)) {
6329       PerlMem_free(esa);
6330       return sts;
6331    }
6332    specdsc.dsc$a_pointer = vmspath;
6333    specdsc.dsc$w_length = vmspath_len;
6334
6335    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6336    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6337    sts = lib$fid_to_name
6338       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6339
6340   /* on any failure, returned the POSIX ^UP^ filespec */
6341   if (!(sts & 1)) {
6342      /* This can happen if user does not have permission to read directories */
6343      if (strncmp(unixpath,"\"^UP^",5) != 0)
6344        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6345      else
6346        strcpy(vmspath, unixpath);
6347   }
6348   else {
6349     vmspath[specdsc.dsc$w_length] = 0;
6350
6351     /* Are we expecting a directory? */
6352     if (dir_flag != 0) {
6353     int i;
6354     char *eptr;
6355
6356       eptr = NULL;
6357
6358       i = specdsc.dsc$w_length - 1;
6359       while (i > 0) {
6360       int zercnt;
6361         zercnt = 0;
6362         /* Version must be '1' */
6363         if (vmspath[i--] != '1')
6364           break;
6365         /* Version delimiter is one of ".;" */
6366         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6367           break;
6368         i--;
6369         if (vmspath[i--] != 'R')
6370           break;
6371         if (vmspath[i--] != 'I')
6372           break;
6373         if (vmspath[i--] != 'D')
6374           break;
6375         if (vmspath[i--] != '.')
6376           break;
6377         eptr = &vmspath[i+1];
6378         while (i > 0) {
6379           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6380             if (vmspath[i-1] != '^') {
6381               if (zercnt != 6) {
6382                 *eptr = vmspath[i];
6383                 eptr[1] = '\0';
6384                 vmspath[i] = '.';
6385                 break;
6386               }
6387               else {
6388                 /* Get rid of 6 imaginary zero directory filename */
6389                 vmspath[i+1] = '\0';
6390               }
6391             }
6392           }
6393           if (vmspath[i] == '0')
6394             zercnt++;
6395           else
6396             zercnt = 10;
6397           i--;
6398         }
6399         break;
6400       }
6401     }
6402   }
6403   PerlMem_free(esa);
6404   return sts;
6405 }
6406
6407 /* /dev/mumble needs to be handled special.
6408    /dev/null becomes NLA0:, And there is the potential for other stuff
6409    like /dev/tty which may need to be mapped to something.
6410 */
6411
6412 static int
6413 slash_dev_special_to_vms
6414    (const char * unixptr,
6415     char * vmspath,
6416     int vmspath_len)
6417 {
6418 char * nextslash;
6419 int len;
6420 int cmp;
6421 int islnm;
6422
6423     unixptr += 4;
6424     nextslash = strchr(unixptr, '/');
6425     len = strlen(unixptr);
6426     if (nextslash != NULL)
6427         len = nextslash - unixptr;
6428     cmp = strncmp("null", unixptr, 5);
6429     if (cmp == 0) {
6430         if (vmspath_len >= 6) {
6431             strcpy(vmspath, "_NLA0:");
6432             return SS$_NORMAL;
6433         }
6434     }
6435 }
6436
6437
6438 /* The built in routines do not understand perl's special needs, so
6439     doing a manual conversion from UNIX to VMS
6440
6441     If the utf8_fl is not null and points to a non-zero value, then
6442     treat 8 bit characters as UTF-8.
6443
6444     The sequence starting with '$(' and ending with ')' will be passed
6445     through with out interpretation instead of being escaped.
6446
6447   */
6448 static int posix_to_vmsspec_hardway
6449   (char *vmspath, int vmspath_len,
6450    const char *unixpath,
6451    int dir_flag,
6452    int * utf8_fl) {
6453
6454 char *esa;
6455 const char *unixptr;
6456 const char *unixend;
6457 char *vmsptr;
6458 const char *lastslash;
6459 const char *lastdot;
6460 int unixlen;
6461 int vmslen;
6462 int dir_start;
6463 int dir_dot;
6464 int quoted;
6465 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6466 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6467
6468   if (utf8_fl != NULL)
6469     *utf8_fl = 0;
6470
6471   unixptr = unixpath;
6472   dir_dot = 0;
6473
6474   /* Ignore leading "/" characters */
6475   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6476     unixptr++;
6477   }
6478   unixlen = strlen(unixptr);
6479
6480   /* Do nothing with blank paths */
6481   if (unixlen == 0) {
6482     vmspath[0] = '\0';
6483     return SS$_NORMAL;
6484   }
6485
6486   quoted = 0;
6487   /* This could have a "^UP^ on the front */
6488   if (strncmp(unixptr,"\"^UP^",5) == 0) {
6489     quoted = 1;
6490     unixptr+= 5;
6491     unixlen-= 5;
6492   }
6493
6494   lastslash = strrchr(unixptr,'/');
6495   lastdot = strrchr(unixptr,'.');
6496   unixend = strrchr(unixptr,'\"');
6497   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6498     unixend = unixptr + unixlen;
6499   }
6500
6501   /* last dot is last dot or past end of string */
6502   if (lastdot == NULL)
6503     lastdot = unixptr + unixlen;
6504
6505   /* if no directories, set last slash to beginning of string */
6506   if (lastslash == NULL) {
6507     lastslash = unixptr;
6508   }
6509   else {
6510     /* Watch out for trailing "." after last slash, still a directory */
6511     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6512       lastslash = unixptr + unixlen;
6513     }
6514
6515     /* Watch out for traiing ".." after last slash, still a directory */
6516     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6517       lastslash = unixptr + unixlen;
6518     }
6519
6520     /* dots in directories are aways escaped */
6521     if (lastdot < lastslash)
6522       lastdot = unixptr + unixlen;
6523   }
6524
6525   /* if (unixptr < lastslash) then we are in a directory */
6526
6527   dir_start = 0;
6528
6529   vmsptr = vmspath;
6530   vmslen = 0;
6531
6532   /* Start with the UNIX path */
6533   if (*unixptr != '/') {
6534     /* relative paths */
6535
6536     /* If allowing logical names on relative pathnames, then handle here */
6537     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6538         !decc_posix_compliant_pathnames) {
6539     char * nextslash;
6540     int seg_len;
6541     char * trn;
6542     int islnm;
6543
6544         /* Find the next slash */
6545         nextslash = strchr(unixptr,'/');
6546
6547         esa = PerlMem_malloc(vmspath_len);
6548         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6549
6550         trn = PerlMem_malloc(VMS_MAXRSS);
6551         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6552
6553         if (nextslash != NULL) {
6554
6555             seg_len = nextslash - unixptr;
6556             strncpy(esa, unixptr, seg_len);
6557             esa[seg_len] = 0;
6558         }
6559         else {
6560             strcpy(esa, unixptr);
6561             seg_len = strlen(unixptr);
6562         }
6563         /* trnlnm(section) */
6564         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6565
6566         if (islnm) {
6567             /* Now fix up the directory */
6568
6569             /* Split up the path to find the components */
6570             sts = vms_split_path
6571                   (trn,
6572                    &v_spec,
6573                    &v_len,
6574                    &r_spec,
6575                    &r_len,
6576                    &d_spec,
6577                    &d_len,
6578                    &n_spec,
6579                    &n_len,
6580                    &e_spec,
6581                    &e_len,
6582                    &vs_spec,
6583                    &vs_len);
6584
6585             while (sts == 0) {
6586             char * strt;
6587             int cmp;
6588
6589                 /* A logical name must be a directory  or the full
6590                    specification.  It is only a full specification if
6591                    it is the only component */
6592                 if ((unixptr[seg_len] == '\0') ||
6593                     (unixptr[seg_len+1] == '\0')) {
6594
6595                     /* Is a directory being required? */
6596                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6597                         /* Not a logical name */
6598                         break;
6599                     }
6600
6601
6602                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6603                         /* This must be a directory */
6604                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6605                             strcpy(vmsptr, esa);
6606                             vmslen=strlen(vmsptr);
6607                             vmsptr[vmslen] = ':';
6608                             vmslen++;
6609                             vmsptr[vmslen] = '\0';
6610                             return SS$_NORMAL;
6611                         }
6612                     }
6613
6614                 }
6615
6616
6617                 /* must be dev/directory - ignore version */
6618                 if ((n_len + e_len) != 0)
6619                     break;
6620
6621                 /* transfer the volume */
6622                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6623                     strncpy(vmsptr, v_spec, v_len);
6624                     vmsptr += v_len;
6625                     vmsptr[0] = '\0';
6626                     vmslen += v_len;
6627                 }
6628
6629                 /* unroot the rooted directory */
6630                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6631                     r_spec[0] = '[';
6632                     r_spec[r_len - 1] = ']';
6633
6634                     /* This should not be there, but nothing is perfect */
6635                     if (r_len > 9) {
6636                         cmp = strcmp(&r_spec[1], "000000.");
6637                         if (cmp == 0) {
6638                             r_spec += 7;
6639                             r_spec[7] = '[';
6640                             r_len -= 7;
6641                             if (r_len == 2)
6642                                 r_len = 0;
6643                         }
6644                     }
6645                     if (r_len > 0) {
6646                         strncpy(vmsptr, r_spec, r_len);
6647                         vmsptr += r_len;
6648                         vmslen += r_len;
6649                         vmsptr[0] = '\0';
6650                     }
6651                 }
6652                 /* Bring over the directory. */
6653                 if ((d_len > 0) &&
6654                     ((d_len + vmslen) < vmspath_len)) {
6655                     d_spec[0] = '[';
6656                     d_spec[d_len - 1] = ']';
6657                     if (d_len > 9) {
6658                         cmp = strcmp(&d_spec[1], "000000.");
6659                         if (cmp == 0) {
6660                             d_spec += 7;
6661                             d_spec[7] = '[';
6662                             d_len -= 7;
6663                             if (d_len == 2)
6664                                 d_len = 0;
6665                         }
6666                     }
6667
6668                     if (r_len > 0) {
6669                         /* Remove the redundant root */
6670                         if (r_len > 0) {
6671                             /* remove the ][ */
6672                             vmsptr--;
6673                             vmslen--;
6674                             d_spec++;
6675                             d_len--;
6676                         }
6677                         strncpy(vmsptr, d_spec, d_len);
6678                             vmsptr += d_len;
6679                             vmslen += d_len;
6680                             vmsptr[0] = '\0';
6681                     }
6682                 }
6683                 break;
6684             }
6685         }
6686
6687         PerlMem_free(esa);
6688         PerlMem_free(trn);
6689     }
6690
6691     if (lastslash > unixptr) {
6692     int dotdir_seen;
6693
6694       /* skip leading ./ */
6695       dotdir_seen = 0;
6696       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6697         dotdir_seen = 1;
6698         unixptr++;
6699         unixptr++;
6700       }
6701
6702       /* Are we still in a directory? */
6703       if (unixptr <= lastslash) {
6704         *vmsptr++ = '[';
6705         vmslen = 1;
6706         dir_start = 1;
6707
6708         /* if not backing up, then it is relative forward. */
6709         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6710               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6711           *vmsptr++ = '.';
6712           vmslen++;
6713           dir_dot = 1;
6714           }
6715        }
6716        else {
6717          if (dotdir_seen) {
6718            /* Perl wants an empty directory here to tell the difference
6719             * between a DCL commmand and a filename
6720             */
6721           *vmsptr++ = '[';
6722           *vmsptr++ = ']';
6723           vmslen = 2;
6724         }
6725       }
6726     }
6727     else {
6728       /* Handle two special files . and .. */
6729       if (unixptr[0] == '.') {
6730         if (&unixptr[1] == unixend) {
6731           *vmsptr++ = '[';
6732           *vmsptr++ = ']';
6733           vmslen += 2;
6734           *vmsptr++ = '\0';
6735           return SS$_NORMAL;
6736         }
6737         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6738           *vmsptr++ = '[';
6739           *vmsptr++ = '-';
6740           *vmsptr++ = ']';
6741           vmslen += 3;
6742           *vmsptr++ = '\0';
6743           return SS$_NORMAL;
6744         }
6745       }
6746     }
6747   }
6748   else {        /* Absolute PATH handling */
6749   int sts;
6750   char * nextslash;
6751   int seg_len;
6752     /* Need to find out where root is */
6753
6754     /* In theory, this procedure should never get an absolute POSIX pathname
6755      * that can not be found on the POSIX root.
6756      * In practice, that can not be relied on, and things will show up
6757      * here that are a VMS device name or concealed logical name instead.
6758      * So to make things work, this procedure must be tolerant.
6759      */
6760     esa = PerlMem_malloc(vmspath_len);
6761     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6762
6763     sts = SS$_NORMAL;
6764     nextslash = strchr(&unixptr[1],'/');
6765     seg_len = 0;
6766     if (nextslash != NULL) {
6767     int cmp;
6768       seg_len = nextslash - &unixptr[1];
6769       strncpy(vmspath, unixptr, seg_len + 1);
6770       vmspath[seg_len+1] = 0;
6771       cmp = 1;
6772       if (seg_len == 3) {
6773         cmp = strncmp(vmspath, "dev", 4);
6774         if (cmp == 0) {
6775             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6776             if (sts = SS$_NORMAL)
6777                 return SS$_NORMAL;
6778         }
6779       }
6780       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6781     }
6782
6783     if ($VMS_STATUS_SUCCESS(sts)) {
6784       /* This is verified to be a real path */
6785
6786       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6787       if ($VMS_STATUS_SUCCESS(sts)) {
6788         strcpy(vmspath, esa);
6789         vmslen = strlen(vmspath);
6790         vmsptr = vmspath + vmslen;
6791         unixptr++;
6792         if (unixptr < lastslash) {
6793         char * rptr;
6794           vmsptr--;
6795           *vmsptr++ = '.';
6796           dir_start = 1;
6797           dir_dot = 1;
6798           if (vmslen > 7) {
6799           int cmp;
6800             rptr = vmsptr - 7;
6801             cmp = strcmp(rptr,"000000.");
6802             if (cmp == 0) {
6803               vmslen -= 7;
6804               vmsptr -= 7;
6805               vmsptr[1] = '\0';
6806             } /* removing 6 zeros */
6807           } /* vmslen < 7, no 6 zeros possible */
6808         } /* Not in a directory */
6809       } /* Posix root found */
6810       else {
6811         /* No posix root, fall back to default directory */
6812         strcpy(vmspath, "SYS$DISK:[");
6813         vmsptr = &vmspath[10];
6814         vmslen = 10;
6815         if (unixptr > lastslash) {
6816            *vmsptr = ']';
6817            vmsptr++;
6818            vmslen++;
6819         }
6820         else {
6821            dir_start = 1;
6822         }
6823       }
6824     } /* end of verified real path handling */
6825     else {
6826     int add_6zero;
6827     int islnm;
6828
6829       /* Ok, we have a device or a concealed root that is not in POSIX
6830        * or we have garbage.  Make the best of it.
6831        */
6832
6833       /* Posix to VMS destroyed this, so copy it again */
6834       strncpy(vmspath, &unixptr[1], seg_len);
6835       vmspath[seg_len] = 0;
6836       vmslen = seg_len;
6837       vmsptr = &vmsptr[vmslen];
6838       islnm = 0;
6839
6840       /* Now do we need to add the fake 6 zero directory to it? */
6841       add_6zero = 1;
6842       if ((*lastslash == '/') && (nextslash < lastslash)) {
6843         /* No there is another directory */
6844         add_6zero = 0;
6845       }
6846       else {
6847       int trnend;
6848       int cmp;
6849
6850         /* now we have foo:bar or foo:[000000]bar to decide from */
6851         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6852
6853         if (!islnm && !decc_posix_compliant_pathnames) {
6854
6855             cmp = strncmp("bin", vmspath, 4);
6856             if (cmp == 0) {
6857                 /* bin => SYS$SYSTEM: */
6858                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6859             }
6860             else {
6861                 /* tmp => SYS$SCRATCH: */
6862                 cmp = strncmp("tmp", vmspath, 4);
6863                 if (cmp == 0) {
6864                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6865                 }
6866             }
6867         }
6868
6869         trnend = islnm ? islnm - 1 : 0;
6870
6871         /* if this was a logical name, ']' or '>' must be present */
6872         /* if not a logical name, then assume a device and hope. */
6873         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6874
6875         /* if log name and trailing '.' then rooted - treat as device */
6876         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6877
6878         /* Fix me, if not a logical name, a device lookup should be
6879          * done to see if the device is file structured.  If the device
6880          * is not file structured, the 6 zeros should not be put on.
6881          *
6882          * As it is, perl is occasionally looking for dev:[000000]tty.
6883          * which looks a little strange.
6884          *
6885          * Not that easy to detect as "/dev" may be file structured with
6886          * special device files.
6887          */
6888
6889         if ((add_6zero == 0) && (*nextslash == '/') &&
6890             (&nextslash[1] == unixend)) {
6891           /* No real directory present */
6892           add_6zero = 1;
6893         }
6894       }
6895
6896       /* Put the device delimiter on */
6897       *vmsptr++ = ':';
6898       vmslen++;
6899       unixptr = nextslash;
6900       unixptr++;
6901
6902       /* Start directory if needed */
6903       if (!islnm || add_6zero) {
6904         *vmsptr++ = '[';
6905         vmslen++;
6906         dir_start = 1;
6907       }
6908
6909       /* add fake 000000] if needed */
6910       if (add_6zero) {
6911         *vmsptr++ = '0';
6912         *vmsptr++ = '0';
6913         *vmsptr++ = '0';
6914         *vmsptr++ = '0';
6915         *vmsptr++ = '0';
6916         *vmsptr++ = '0';
6917         *vmsptr++ = ']';
6918         vmslen += 7;
6919         dir_start = 0;
6920       }
6921
6922     } /* non-POSIX translation */
6923     PerlMem_free(esa);
6924   } /* End of relative/absolute path handling */
6925
6926   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6927   int dash_flag;
6928   int in_cnt;
6929   int out_cnt;
6930
6931     dash_flag = 0;
6932
6933     if (dir_start != 0) {
6934
6935       /* First characters in a directory are handled special */
6936       while ((*unixptr == '/') ||
6937              ((*unixptr == '.') &&
6938               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6939                 (&unixptr[1]==unixend)))) {
6940       int loop_flag;
6941
6942         loop_flag = 0;
6943
6944         /* Skip redundant / in specification */
6945         while ((*unixptr == '/') && (dir_start != 0)) {
6946           loop_flag = 1;
6947           unixptr++;
6948           if (unixptr == lastslash)
6949             break;
6950         }
6951         if (unixptr == lastslash)
6952           break;
6953
6954         /* Skip redundant ./ characters */
6955         while ((*unixptr == '.') &&
6956                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6957           loop_flag = 1;
6958           unixptr++;
6959           if (unixptr == lastslash)
6960             break;
6961           if (*unixptr == '/')
6962             unixptr++;
6963         }
6964         if (unixptr == lastslash)
6965           break;
6966
6967         /* Skip redundant ../ characters */
6968         while ((*unixptr == '.') && (unixptr[1] == '.') &&
6969              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6970           /* Set the backing up flag */
6971           loop_flag = 1;
6972           dir_dot = 0;
6973           dash_flag = 1;
6974           *vmsptr++ = '-';
6975           vmslen++;
6976           unixptr++; /* first . */
6977           unixptr++; /* second . */
6978           if (unixptr == lastslash)
6979             break;
6980           if (*unixptr == '/') /* The slash */
6981             unixptr++;
6982         }
6983         if (unixptr == lastslash)
6984           break;
6985
6986         /* To do: Perl expects /.../ to be translated to [...] on VMS */
6987         /* Not needed when VMS is pretending to be UNIX. */
6988
6989         /* Is this loop stuck because of too many dots? */
6990         if (loop_flag == 0) {
6991           /* Exit the loop and pass the rest through */
6992           break;
6993         }
6994       }
6995
6996       /* Are we done with directories yet? */
6997       if (unixptr >= lastslash) {
6998
6999         /* Watch out for trailing dots */
7000         if (dir_dot != 0) {
7001             vmslen --;
7002             vmsptr--;
7003         }
7004         *vmsptr++ = ']';
7005         vmslen++;
7006         dash_flag = 0;
7007         dir_start = 0;
7008         if (*unixptr == '/')
7009           unixptr++;
7010       }
7011       else {
7012         /* Have we stopped backing up? */
7013         if (dash_flag) {
7014           *vmsptr++ = '.';
7015           vmslen++;
7016           dash_flag = 0;
7017           /* dir_start continues to be = 1 */
7018         }
7019         if (*unixptr == '-') {
7020           *vmsptr++ = '^';
7021           *vmsptr++ = *unixptr++;
7022           vmslen += 2;
7023           dir_start = 0;
7024
7025           /* Now are we done with directories yet? */
7026           if (unixptr >= lastslash) {
7027
7028             /* Watch out for trailing dots */
7029             if (dir_dot != 0) {
7030               vmslen --;
7031               vmsptr--;
7032             }
7033
7034             *vmsptr++ = ']';
7035             vmslen++;
7036             dash_flag = 0;
7037             dir_start = 0;
7038           }
7039         }
7040       }
7041     }
7042
7043     /* All done? */
7044     if (unixptr >= unixend)
7045       break;
7046
7047     /* Normal characters - More EFS work probably needed */
7048     dir_start = 0;
7049     dir_dot = 0;
7050
7051     switch(*unixptr) {
7052     case '/':
7053         /* remove multiple / */
7054         while (unixptr[1] == '/') {
7055            unixptr++;
7056         }
7057         if (unixptr == lastslash) {
7058           /* Watch out for trailing dots */
7059           if (dir_dot != 0) {
7060             vmslen --;
7061             vmsptr--;
7062           }
7063           *vmsptr++ = ']';
7064         }
7065         else {
7066           dir_start = 1;
7067           *vmsptr++ = '.';
7068           dir_dot = 1;
7069
7070           /* To do: Perl expects /.../ to be translated to [...] on VMS */
7071           /* Not needed when VMS is pretending to be UNIX. */
7072
7073         }
7074         dash_flag = 0;
7075         if (unixptr != unixend)
7076           unixptr++;
7077         vmslen++;
7078         break;
7079     case '.':
7080         if ((unixptr < lastdot) || (unixptr < lastslash) ||
7081             (&unixptr[1] == unixend)) {
7082           *vmsptr++ = '^';
7083           *vmsptr++ = '.';
7084           vmslen += 2;
7085           unixptr++;
7086
7087           /* trailing dot ==> '^..' on VMS */
7088           if (unixptr == unixend) {
7089             *vmsptr++ = '.';
7090             vmslen++;
7091             unixptr++;
7092           }
7093           break;
7094         }
7095
7096         *vmsptr++ = *unixptr++;
7097         vmslen ++;
7098         break;
7099     case '"':
7100         if (quoted && (&unixptr[1] == unixend)) {
7101             unixptr++;
7102             break;
7103         }
7104         in_cnt = copy_expand_unix_filename_escape
7105                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7106         vmsptr += out_cnt;
7107         unixptr += in_cnt;
7108         break;
7109     case '~':
7110     case ';':
7111     case '\\':
7112     case '?':
7113     case ' ':
7114     default:
7115         in_cnt = copy_expand_unix_filename_escape
7116                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7117         vmsptr += out_cnt;
7118         unixptr += in_cnt;
7119         break;
7120     }
7121   }
7122
7123   /* Make sure directory is closed */
7124   if (unixptr == lastslash) {
7125     char *vmsptr2;
7126     vmsptr2 = vmsptr - 1;
7127
7128     if (*vmsptr2 != ']') {
7129       *vmsptr2--;
7130
7131       /* directories do not end in a dot bracket */
7132       if (*vmsptr2 == '.') {
7133         vmsptr2--;
7134
7135         /* ^. is allowed */
7136         if (*vmsptr2 != '^') {
7137           vmsptr--; /* back up over the dot */
7138         }
7139       }
7140       *vmsptr++ = ']';
7141     }
7142   }
7143   else {
7144     char *vmsptr2;
7145     /* Add a trailing dot if a file with no extension */
7146     vmsptr2 = vmsptr - 1;
7147     if ((vmslen > 1) &&
7148         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7149         (*vmsptr2 != ')') && (*lastdot != '.')) {
7150         *vmsptr++ = '.';
7151         vmslen++;
7152     }
7153   }
7154
7155   *vmsptr = '\0';
7156   return SS$_NORMAL;
7157 }
7158 #endif
7159
7160  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7161 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7162 {
7163 char * result;
7164 int utf8_flag;
7165
7166    /* If a UTF8 flag is being passed, honor it */
7167    utf8_flag = 0;
7168    if (utf8_fl != NULL) {
7169      utf8_flag = *utf8_fl;
7170     *utf8_fl = 0;
7171    }
7172
7173    if (utf8_flag) {
7174      /* If there is a possibility of UTF8, then if any UTF8 characters
7175         are present, then they must be converted to VTF-7
7176       */
7177      result = strcpy(rslt, path); /* FIX-ME */
7178    }
7179    else
7180      result = strcpy(rslt, path);
7181
7182    return result;
7183 }
7184
7185
7186 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7187 static char *mp_do_tovmsspec
7188    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7189   static char __tovmsspec_retbuf[VMS_MAXRSS];
7190   char *rslt, *dirend;
7191   char *lastdot;
7192   char *vms_delim;
7193   register char *cp1;
7194   const char *cp2;
7195   unsigned long int infront = 0, hasdir = 1;
7196   int rslt_len;
7197   int no_type_seen;
7198   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7199   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7200
7201   if (path == NULL) return NULL;
7202   rslt_len = VMS_MAXRSS-1;
7203   if (buf) rslt = buf;
7204   else if (ts) Newx(rslt, VMS_MAXRSS, char);
7205   else rslt = __tovmsspec_retbuf;
7206
7207   /* '.' and '..' are "[]" and "[-]" for a quick check */
7208   if (path[0] == '.') {
7209     if (path[1] == '\0') {
7210       strcpy(rslt,"[]");
7211       if (utf8_flag != NULL)
7212         *utf8_flag = 0;
7213       return rslt;
7214     }
7215     else {
7216       if (path[1] == '.' && path[2] == '\0') {
7217         strcpy(rslt,"[-]");
7218         if (utf8_flag != NULL)
7219            *utf8_flag = 0;
7220         return rslt;
7221       }
7222     }
7223   }
7224
7225    /* Posix specifications are now a native VMS format */
7226   /*--------------------------------------------------*/
7227 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7228   if (decc_posix_compliant_pathnames) {
7229     if (strncmp(path,"\"^UP^",5) == 0) {
7230       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7231       return rslt;
7232     }
7233   }
7234 #endif
7235
7236   /* This is really the only way to see if this is already in VMS format */
7237   sts = vms_split_path
7238        (path,
7239         &v_spec,
7240         &v_len,
7241         &r_spec,
7242         &r_len,
7243         &d_spec,
7244         &d_len,
7245         &n_spec,
7246         &n_len,
7247         &e_spec,
7248         &e_len,
7249         &vs_spec,
7250         &vs_len);
7251   if (sts == 0) {
7252     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7253        replacement, because the above parse just took care of most of
7254        what is needed to do vmspath when the specification is already
7255        in VMS format.
7256
7257        And if it is not already, it is easier to do the conversion as
7258        part of this routine than to call this routine and then work on
7259        the result.
7260      */
7261
7262     /* If VMS punctuation was found, it is already VMS format */
7263     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7264       if (utf8_flag != NULL)
7265         *utf8_flag = 0;
7266       strcpy(rslt, path);
7267       return rslt;
7268     }
7269     /* Now, what to do with trailing "." cases where there is no
7270        extension?  If this is a UNIX specification, and EFS characters
7271        are enabled, then the trailing "." should be converted to a "^.".
7272        But if this was already a VMS specification, then it should be
7273        left alone.
7274
7275        So in the case of ambiguity, leave the specification alone.
7276      */
7277
7278
7279     /* If there is a possibility of UTF8, then if any UTF8 characters
7280         are present, then they must be converted to VTF-7
7281      */
7282     if (utf8_flag != NULL)
7283       *utf8_flag = 0;
7284     strcpy(rslt, path);
7285     return rslt;
7286   }
7287
7288   dirend = strrchr(path,'/');
7289
7290   if (dirend == NULL) {
7291      /* If we get here with no UNIX directory delimiters, then this is
7292         not a complete file specification, either garbage a UNIX glob
7293         specification that can not be converted to a VMS wildcard, or
7294         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7295         so apparently other programs expect this also.
7296
7297         utf8 flag setting needs to be preserved.
7298       */
7299       strcpy(rslt, path);
7300       return rslt;
7301   }
7302
7303 /* If POSIX mode active, handle the conversion */
7304 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7305   if (decc_efs_charset) {
7306     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7307     return rslt;
7308   }
7309 #endif
7310
7311   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7312     if (!*(dirend+2)) dirend +=2;
7313     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7314     if (decc_efs_charset == 0) {
7315       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7316     }
7317   }
7318
7319   cp1 = rslt;
7320   cp2 = path;
7321   lastdot = strrchr(cp2,'.');
7322   if (*cp2 == '/') {
7323     char *trndev;
7324     int islnm, rooted;
7325     STRLEN trnend;
7326
7327     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7328     if (!*(cp2+1)) {
7329       if (decc_disable_posix_root) {
7330         strcpy(rslt,"sys$disk:[000000]");
7331       }
7332       else {
7333         strcpy(rslt,"sys$posix_root:[000000]");
7334       }
7335       if (utf8_flag != NULL)
7336         *utf8_flag = 0;
7337       return rslt;
7338     }
7339     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7340     *cp1 = '\0';
7341     trndev = PerlMem_malloc(VMS_MAXRSS);
7342     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7343     islnm =  my_trnlnm(rslt,trndev,0);
7344
7345      /* DECC special handling */
7346     if (!islnm) {
7347       if (strcmp(rslt,"bin") == 0) {
7348         strcpy(rslt,"sys$system");
7349         cp1 = rslt + 10;
7350         *cp1 = 0;
7351         islnm =  my_trnlnm(rslt,trndev,0);
7352       }
7353       else if (strcmp(rslt,"tmp") == 0) {
7354         strcpy(rslt,"sys$scratch");
7355         cp1 = rslt + 11;
7356         *cp1 = 0;
7357         islnm =  my_trnlnm(rslt,trndev,0);
7358       }
7359       else if (!decc_disable_posix_root) {
7360         strcpy(rslt, "sys$posix_root");
7361         cp1 = rslt + 13;
7362         *cp1 = 0;
7363         cp2 = path;
7364         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7365         islnm =  my_trnlnm(rslt,trndev,0);
7366       }
7367       else if (strcmp(rslt,"dev") == 0) {
7368         if (strncmp(cp2,"/null", 5) == 0) {
7369           if ((cp2[5] == 0) || (cp2[5] == '/')) {
7370             strcpy(rslt,"NLA0");
7371             cp1 = rslt + 4;
7372             *cp1 = 0;
7373             cp2 = cp2 + 5;
7374             islnm =  my_trnlnm(rslt,trndev,0);
7375           }
7376         }
7377       }
7378     }
7379
7380     trnend = islnm ? strlen(trndev) - 1 : 0;
7381     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7382     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7383     /* If the first element of the path is a logical name, determine
7384      * whether it has to be translated so we can add more directories. */
7385     if (!islnm || rooted) {
7386       *(cp1++) = ':';
7387       *(cp1++) = '[';
7388       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7389       else cp2++;
7390     }
7391     else {
7392       if (cp2 != dirend) {
7393         strcpy(rslt,trndev);
7394         cp1 = rslt + trnend;
7395         if (*cp2 != 0) {
7396           *(cp1++) = '.';
7397           cp2++;
7398         }
7399       }
7400       else {
7401         if (decc_disable_posix_root) {
7402           *(cp1++) = ':';
7403           hasdir = 0;
7404         }
7405       }
7406     }
7407     PerlMem_free(trndev);
7408   }
7409   else {
7410     *(cp1++) = '[';
7411     if (*cp2 == '.') {
7412       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7413         cp2 += 2;         /* skip over "./" - it's redundant */
7414         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
7415       }
7416       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7417         *(cp1++) = '-';                                 /* "../" --> "-" */
7418         cp2 += 3;
7419       }
7420       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7421                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7422         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7423         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7424         cp2 += 4;
7425       }
7426       else if ((cp2 != lastdot) || (lastdot < dirend)) {
7427         /* Escape the extra dots in EFS file specifications */
7428         *(cp1++) = '^';
7429       }
7430       if (cp2 > dirend) cp2 = dirend;
7431     }
7432     else *(cp1++) = '.';
7433   }
7434   for (; cp2 < dirend; cp2++) {
7435     if (*cp2 == '/') {
7436       if (*(cp2-1) == '/') continue;
7437       if (*(cp1-1) != '.') *(cp1++) = '.';
7438       infront = 0;
7439     }
7440     else if (!infront && *cp2 == '.') {
7441       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7442       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
7443       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7444         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7445         else if (*(cp1-2) == '[') *(cp1-1) = '-';
7446         else {  /* back up over previous directory name */
7447           cp1--;
7448           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7449           if (*(cp1-1) == '[') {
7450             memcpy(cp1,"000000.",7);
7451             cp1 += 7;
7452           }
7453         }
7454         cp2 += 2;
7455         if (cp2 == dirend) break;
7456       }
7457       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7458                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7459         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7460         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7461         if (!*(cp2+3)) {
7462           *(cp1++) = '.';  /* Simulate trailing '/' */
7463           cp2 += 2;  /* for loop will incr this to == dirend */
7464         }
7465         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
7466       }
7467       else {
7468         if (decc_efs_charset == 0)
7469           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
7470         else {
7471           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
7472           *(cp1++) = '.';
7473         }
7474       }
7475     }
7476     else {
7477       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
7478       if (*cp2 == '.') {
7479         if (decc_efs_charset == 0)
7480           *(cp1++) = '_';
7481         else {
7482           *(cp1++) = '^';
7483           *(cp1++) = '.';
7484         }
7485       }
7486       else                  *(cp1++) =  *cp2;
7487       infront = 1;
7488     }
7489   }
7490   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7491   if (hasdir) *(cp1++) = ']';
7492   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
7493   /* fixme for ODS5 */
7494   no_type_seen = 0;
7495   if (cp2 > lastdot)
7496     no_type_seen = 1;
7497   while (*cp2) {
7498     switch(*cp2) {
7499     case '?':
7500         if (decc_efs_charset == 0)
7501           *(cp1++) = '%';
7502         else
7503           *(cp1++) = '?';
7504         cp2++;
7505     case ' ':
7506         *(cp1)++ = '^';
7507         *(cp1)++ = '_';
7508         cp2++;
7509         break;
7510     case '.':
7511         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7512             decc_readdir_dropdotnotype) {
7513           *(cp1)++ = '^';
7514           *(cp1)++ = '.';
7515           cp2++;
7516
7517           /* trailing dot ==> '^..' on VMS */
7518           if (*cp2 == '\0') {
7519             *(cp1++) = '.';
7520             no_type_seen = 0;
7521           }
7522         }
7523         else {
7524           *(cp1++) = *(cp2++);
7525           no_type_seen = 0;
7526         }
7527         break;
7528     case '$':
7529          /* This could be a macro to be passed through */
7530         *(cp1++) = *(cp2++);
7531         if (*cp2 == '(') {
7532         const char * save_cp2;
7533         char * save_cp1;
7534         int is_macro;
7535
7536             /* paranoid check */
7537             save_cp2 = cp2;
7538             save_cp1 = cp1;
7539             is_macro = 0;
7540
7541             /* Test through */
7542             *(cp1++) = *(cp2++);
7543             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7544                 *(cp1++) = *(cp2++);
7545                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7546                     *(cp1++) = *(cp2++);
7547                 }
7548                 if (*cp2 == ')') {
7549                     *(cp1++) = *(cp2++);
7550                     is_macro = 1;
7551                 }
7552             }
7553             if (is_macro == 0) {
7554                 /* Not really a macro - never mind */
7555                 cp2 = save_cp2;
7556                 cp1 = save_cp1;
7557             }
7558         }
7559         break;
7560     case '\"':
7561     case '~':
7562     case '`':
7563     case '!':
7564     case '#':
7565     case '%':
7566     case '^':
7567         /* Don't escape again if following character is
7568          * already something we escape.
7569          */
7570         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
7571             *(cp1++) = *(cp2++);
7572             break;
7573         }
7574         /* But otherwise fall through and escape it. */
7575     case '&':
7576     case '(':
7577     case ')':
7578     case '=':
7579     case '+':
7580     case '\'':
7581     case '@':
7582     case '[':
7583     case ']':
7584     case '{':
7585     case '}':
7586     case ':':
7587     case '\\':
7588     case '|':
7589     case '<':
7590     case '>':
7591         *(cp1++) = '^';
7592         *(cp1++) = *(cp2++);
7593         break;
7594     case ';':
7595         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7596          * which is wrong.  UNIX notation should be ".dir." unless
7597          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7598          * changing this behavior could break more things at this time.
7599          * efs character set effectively does not allow "." to be a version
7600          * delimiter as a further complication about changing this.
7601          */
7602         if (decc_filename_unix_report != 0) {
7603           *(cp1++) = '^';
7604         }
7605         *(cp1++) = *(cp2++);
7606         break;
7607     default:
7608         *(cp1++) = *(cp2++);
7609     }
7610   }
7611   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7612   char *lcp1;
7613     lcp1 = cp1;
7614     lcp1--;
7615      /* Fix me for "^]", but that requires making sure that you do
7616       * not back up past the start of the filename
7617       */
7618     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7619       *cp1++ = '.';
7620   }
7621   *cp1 = '\0';
7622
7623   if (utf8_flag != NULL)
7624     *utf8_flag = 0;
7625   return rslt;
7626
7627 }  /* end of do_tovmsspec() */
7628 /*}}}*/
7629 /* External entry points */
7630 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7631   { return do_tovmsspec(path,buf,0,NULL); }
7632 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7633   { return do_tovmsspec(path,buf,1,NULL); }
7634 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7635   { return do_tovmsspec(path,buf,0,utf8_fl); }
7636 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7637   { return do_tovmsspec(path,buf,1,utf8_fl); }
7638
7639 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7640 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7641   static char __tovmspath_retbuf[VMS_MAXRSS];
7642   int vmslen;
7643   char *pathified, *vmsified, *cp;
7644
7645   if (path == NULL) return NULL;
7646   pathified = PerlMem_malloc(VMS_MAXRSS);
7647   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7648   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7649     PerlMem_free(pathified);
7650     return NULL;
7651   }
7652
7653   vmsified = NULL;
7654   if (buf == NULL)
7655      Newx(vmsified, VMS_MAXRSS, char);
7656   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7657     PerlMem_free(pathified);
7658     if (vmsified) Safefree(vmsified);
7659     return NULL;
7660   }
7661   PerlMem_free(pathified);
7662   if (buf) {
7663     return buf;
7664   }
7665   else if (ts) {
7666     vmslen = strlen(vmsified);
7667     Newx(cp,vmslen+1,char);
7668     memcpy(cp,vmsified,vmslen);
7669     cp[vmslen] = '\0';
7670     Safefree(vmsified);
7671     return cp;
7672   }
7673   else {
7674     strcpy(__tovmspath_retbuf,vmsified);
7675     Safefree(vmsified);
7676     return __tovmspath_retbuf;
7677   }
7678
7679 }  /* end of do_tovmspath() */
7680 /*}}}*/
7681 /* External entry points */
7682 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7683   { return do_tovmspath(path,buf,0, NULL); }
7684 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7685   { return do_tovmspath(path,buf,1, NULL); }
7686 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7687   { return do_tovmspath(path,buf,0,utf8_fl); }
7688 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7689   { return do_tovmspath(path,buf,1,utf8_fl); }
7690
7691
7692 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7693 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7694   static char __tounixpath_retbuf[VMS_MAXRSS];
7695   int unixlen;
7696   char *pathified, *unixified, *cp;
7697
7698   if (path == NULL) return NULL;
7699   pathified = PerlMem_malloc(VMS_MAXRSS);
7700   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7701   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7702     PerlMem_free(pathified);
7703     return NULL;
7704   }
7705
7706   unixified = NULL;
7707   if (buf == NULL) {
7708       Newx(unixified, VMS_MAXRSS, char);
7709   }
7710   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7711     PerlMem_free(pathified);
7712     if (unixified) Safefree(unixified);
7713     return NULL;
7714   }
7715   PerlMem_free(pathified);
7716   if (buf) {
7717     return buf;
7718   }
7719   else if (ts) {
7720     unixlen = strlen(unixified);
7721     Newx(cp,unixlen+1,char);
7722     memcpy(cp,unixified,unixlen);
7723     cp[unixlen] = '\0';
7724     Safefree(unixified);
7725     return cp;
7726   }
7727   else {
7728     strcpy(__tounixpath_retbuf,unixified);
7729     Safefree(unixified);
7730     return __tounixpath_retbuf;
7731   }
7732
7733 }  /* end of do_tounixpath() */
7734 /*}}}*/
7735 /* External entry points */
7736 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7737   { return do_tounixpath(path,buf,0,NULL); }
7738 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7739   { return do_tounixpath(path,buf,1,NULL); }
7740 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7741   { return do_tounixpath(path,buf,0,utf8_fl); }
7742 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7743   { return do_tounixpath(path,buf,1,utf8_fl); }
7744
7745 /*
7746  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
7747  *
7748  *****************************************************************************
7749  *                                                                           *
7750  *  Copyright (C) 1989-1994, 2007 by                                         *
7751  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
7752  *                                                                           *
7753  *  Permission is hereby granted for the reproduction of this software       *
7754  *  on condition that this copyright notice is included in source            *
7755  *  distributions of the software.  The code may be modified and             *
7756  *  distributed under the same terms as Perl itself.                         *
7757  *                                                                           *
7758  *  27-Aug-1994 Modified for inclusion in perl5                              *
7759  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
7760  *****************************************************************************
7761  */
7762
7763 /*
7764  * getredirection() is intended to aid in porting C programs
7765  * to VMS (Vax-11 C).  The native VMS environment does not support
7766  * '>' and '<' I/O redirection, or command line wild card expansion,
7767  * or a command line pipe mechanism using the '|' AND background
7768  * command execution '&'.  All of these capabilities are provided to any
7769  * C program which calls this procedure as the first thing in the
7770  * main program.
7771  * The piping mechanism will probably work with almost any 'filter' type
7772  * of program.  With suitable modification, it may useful for other
7773  * portability problems as well.
7774  *
7775  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
7776  */
7777 struct list_item
7778     {
7779     struct list_item *next;
7780     char *value;
7781     };
7782
7783 static void add_item(struct list_item **head,
7784                      struct list_item **tail,
7785                      char *value,
7786                      int *count);
7787
7788 static void mp_expand_wild_cards(pTHX_ char *item,
7789                                 struct list_item **head,
7790                                 struct list_item **tail,
7791                                 int *count);
7792
7793 static int background_process(pTHX_ int argc, char **argv);
7794
7795 static void pipe_and_fork(pTHX_ char **cmargv);
7796
7797 /*{{{ void getredirection(int *ac, char ***av)*/
7798 static void
7799 mp_getredirection(pTHX_ int *ac, char ***av)
7800 /*
7801  * Process vms redirection arg's.  Exit if any error is seen.
7802  * If getredirection() processes an argument, it is erased
7803  * from the vector.  getredirection() returns a new argc and argv value.
7804  * In the event that a background command is requested (by a trailing "&"),
7805  * this routine creates a background subprocess, and simply exits the program.
7806  *
7807  * Warning: do not try to simplify the code for vms.  The code
7808  * presupposes that getredirection() is called before any data is
7809  * read from stdin or written to stdout.
7810  *
7811  * Normal usage is as follows:
7812  *
7813  *      main(argc, argv)
7814  *      int             argc;
7815  *      char            *argv[];
7816  *      {
7817  *              getredirection(&argc, &argv);
7818  *      }
7819  */
7820 {
7821     int                 argc = *ac;     /* Argument Count         */
7822     char                **argv = *av;   /* Argument Vector        */
7823     char                *ap;            /* Argument pointer       */
7824     int                 j;              /* argv[] index           */
7825     int                 item_count = 0; /* Count of Items in List */
7826     struct list_item    *list_head = 0; /* First Item in List       */
7827     struct list_item    *list_tail;     /* Last Item in List        */
7828     char                *in = NULL;     /* Input File Name          */
7829     char                *out = NULL;    /* Output File Name         */
7830     char                *outmode = "w"; /* Mode to Open Output File */
7831     char                *err = NULL;    /* Error File Name          */
7832     char                *errmode = "w"; /* Mode to Open Error File  */
7833     int                 cmargc = 0;     /* Piped Command Arg Count  */
7834     char                **cmargv = NULL;/* Piped Command Arg Vector */
7835
7836     /*
7837      * First handle the case where the last thing on the line ends with
7838      * a '&'.  This indicates the desire for the command to be run in a
7839      * subprocess, so we satisfy that desire.
7840      */
7841     ap = argv[argc-1];
7842     if (0 == strcmp("&", ap))
7843        exit(background_process(aTHX_ --argc, argv));
7844     if (*ap && '&' == ap[strlen(ap)-1])
7845         {
7846         ap[strlen(ap)-1] = '\0';
7847        exit(background_process(aTHX_ argc, argv));
7848         }
7849     /*
7850      * Now we handle the general redirection cases that involve '>', '>>',
7851      * '<', and pipes '|'.
7852      */
7853     for (j = 0; j < argc; ++j)
7854         {
7855         if (0 == strcmp("<", argv[j]))
7856             {
7857             if (j+1 >= argc)
7858                 {
7859                 fprintf(stderr,"No input file after < on command line");
7860                 exit(LIB$_WRONUMARG);
7861                 }
7862             in = argv[++j];
7863             continue;
7864             }
7865         if ('<' == *(ap = argv[j]))
7866             {
7867             in = 1 + ap;
7868             continue;
7869             }
7870         if (0 == strcmp(">", ap))
7871             {
7872             if (j+1 >= argc)
7873                 {
7874                 fprintf(stderr,"No output file after > on command line");
7875                 exit(LIB$_WRONUMARG);
7876                 }
7877             out = argv[++j];
7878             continue;
7879             }
7880         if ('>' == *ap)
7881             {
7882             if ('>' == ap[1])
7883                 {
7884                 outmode = "a";
7885                 if ('\0' == ap[2])
7886                     out = argv[++j];
7887                 else
7888                     out = 2 + ap;
7889                 }
7890             else
7891                 out = 1 + ap;
7892             if (j >= argc)
7893                 {
7894                 fprintf(stderr,"No output file after > or >> on command line");
7895                 exit(LIB$_WRONUMARG);
7896                 }
7897             continue;
7898             }
7899         if (('2' == *ap) && ('>' == ap[1]))
7900             {
7901             if ('>' == ap[2])
7902                 {
7903                 errmode = "a";
7904                 if ('\0' == ap[3])
7905                     err = argv[++j];
7906                 else
7907                     err = 3 + ap;
7908                 }
7909             else
7910                 if ('\0' == ap[2])
7911                     err = argv[++j];
7912                 else
7913                     err = 2 + ap;
7914             if (j >= argc)
7915                 {
7916                 fprintf(stderr,"No output file after 2> or 2>> on command line");
7917                 exit(LIB$_WRONUMARG);
7918                 }
7919             continue;
7920             }
7921         if (0 == strcmp("|", argv[j]))
7922             {
7923             if (j+1 >= argc)
7924                 {
7925                 fprintf(stderr,"No command into which to pipe on command line");
7926                 exit(LIB$_WRONUMARG);
7927                 }
7928             cmargc = argc-(j+1);
7929             cmargv = &argv[j+1];
7930             argc = j;
7931             continue;
7932             }
7933         if ('|' == *(ap = argv[j]))
7934             {
7935             ++argv[j];
7936             cmargc = argc-j;
7937             cmargv = &argv[j];
7938             argc = j;
7939             continue;
7940             }
7941         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7942         }
7943     /*
7944      * Allocate and fill in the new argument vector, Some Unix's terminate
7945      * the list with an extra null pointer.
7946      */
7947     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7948     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7949     *av = argv;
7950     for (j = 0; j < item_count; ++j, list_head = list_head->next)
7951         argv[j] = list_head->value;
7952     *ac = item_count;
7953     if (cmargv != NULL)
7954         {
7955         if (out != NULL)
7956             {
7957             fprintf(stderr,"'|' and '>' may not both be specified on command line");
7958             exit(LIB$_INVARGORD);
7959             }
7960         pipe_and_fork(aTHX_ cmargv);
7961         }
7962
7963     /* Check for input from a pipe (mailbox) */
7964
7965     if (in == NULL && 1 == isapipe(0))
7966         {
7967         char mbxname[L_tmpnam];
7968         long int bufsize;
7969         long int dvi_item = DVI$_DEVBUFSIZ;
7970         $DESCRIPTOR(mbxnam, "");
7971         $DESCRIPTOR(mbxdevnam, "");
7972
7973         /* Input from a pipe, reopen it in binary mode to disable       */
7974         /* carriage control processing.                                 */
7975
7976         fgetname(stdin, mbxname);
7977         mbxnam.dsc$a_pointer = mbxname;
7978         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7979         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7980         mbxdevnam.dsc$a_pointer = mbxname;
7981         mbxdevnam.dsc$w_length = sizeof(mbxname);
7982         dvi_item = DVI$_DEVNAM;
7983         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7984         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7985         set_errno(0);
7986         set_vaxc_errno(1);
7987         freopen(mbxname, "rb", stdin);
7988         if (errno != 0)
7989             {
7990             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7991             exit(vaxc$errno);
7992             }
7993         }
7994     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7995         {
7996         fprintf(stderr,"Can't open input file %s as stdin",in);
7997         exit(vaxc$errno);
7998         }
7999     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8000         {
8001         fprintf(stderr,"Can't open output file %s as stdout",out);
8002         exit(vaxc$errno);
8003         }
8004         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8005
8006     if (err != NULL) {
8007         if (strcmp(err,"&1") == 0) {
8008             dup2(fileno(stdout), fileno(stderr));
8009             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8010         } else {
8011         FILE *tmperr;
8012         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8013             {
8014             fprintf(stderr,"Can't open error file %s as stderr",err);
8015             exit(vaxc$errno);
8016             }
8017             fclose(tmperr);
8018            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8019                 {
8020                 exit(vaxc$errno);
8021                 }
8022             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8023         }
8024         }
8025 #ifdef ARGPROC_DEBUG
8026     PerlIO_printf(Perl_debug_log, "Arglist:\n");
8027     for (j = 0; j < *ac;  ++j)
8028         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8029 #endif
8030    /* Clear errors we may have hit expanding wildcards, so they don't
8031       show up in Perl's $! later */
8032    set_errno(0); set_vaxc_errno(1);
8033 }  /* end of getredirection() */
8034 /*}}}*/
8035
8036 static void add_item(struct list_item **head,
8037                      struct list_item **tail,
8038                      char *value,
8039                      int *count)
8040 {
8041     if (*head == 0)
8042         {
8043         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8044         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8045         *tail = *head;
8046         }
8047     else {
8048         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8049         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8050         *tail = (*tail)->next;
8051         }
8052     (*tail)->value = value;
8053     ++(*count);
8054 }
8055
8056 static void mp_expand_wild_cards(pTHX_ char *item,
8057                               struct list_item **head,
8058                               struct list_item **tail,
8059                               int *count)
8060 {
8061 int expcount = 0;
8062 unsigned long int context = 0;
8063 int isunix = 0;
8064 int item_len = 0;
8065 char *had_version;
8066 char *had_device;
8067 int had_directory;
8068 char *devdir,*cp;
8069 char *vmsspec;
8070 $DESCRIPTOR(filespec, "");
8071 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8072 $DESCRIPTOR(resultspec, "");
8073 unsigned long int lff_flags = 0;
8074 int sts;
8075 int rms_sts;
8076
8077 #ifdef VMS_LONGNAME_SUPPORT
8078     lff_flags = LIB$M_FIL_LONG_NAMES;
8079 #endif
8080
8081     for (cp = item; *cp; cp++) {
8082         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8083         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8084     }
8085     if (!*cp || isspace(*cp))
8086         {
8087         add_item(head, tail, item, count);
8088         return;
8089         }
8090     else
8091         {
8092      /* "double quoted" wild card expressions pass as is */
8093      /* From DCL that means using e.g.:                  */
8094      /* perl program """perl.*"""                        */
8095      item_len = strlen(item);
8096      if ( '"' == *item && '"' == item[item_len-1] )
8097        {
8098        item++;
8099        item[item_len-2] = '\0';
8100        add_item(head, tail, item, count);
8101        return;
8102        }
8103      }
8104     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8105     resultspec.dsc$b_class = DSC$K_CLASS_D;
8106     resultspec.dsc$a_pointer = NULL;
8107     vmsspec = PerlMem_malloc(VMS_MAXRSS);
8108     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8109     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8110       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8111     if (!isunix || !filespec.dsc$a_pointer)
8112       filespec.dsc$a_pointer = item;
8113     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8114     /*
8115      * Only return version specs, if the caller specified a version
8116      */
8117     had_version = strchr(item, ';');
8118     /*
8119      * Only return device and directory specs, if the caller specifed either.
8120      */
8121     had_device = strchr(item, ':');
8122     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8123
8124     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8125                                  (&filespec, &resultspec, &context,
8126                                   &defaultspec, 0, &rms_sts, &lff_flags)))
8127         {
8128         char *string;
8129         char *c;
8130
8131         string = PerlMem_malloc(resultspec.dsc$w_length+1);
8132         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8133         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8134         string[resultspec.dsc$w_length] = '\0';
8135         if (NULL == had_version)
8136             *(strrchr(string, ';')) = '\0';
8137         if ((!had_directory) && (had_device == NULL))
8138             {
8139             if (NULL == (devdir = strrchr(string, ']')))
8140                 devdir = strrchr(string, '>');
8141             strcpy(string, devdir + 1);
8142             }
8143         /*
8144          * Be consistent with what the C RTL has already done to the rest of
8145          * the argv items and lowercase all of these names.
8146          */
8147         if (!decc_efs_case_preserve) {
8148             for (c = string; *c; ++c)
8149             if (isupper(*c))
8150                 *c = tolower(*c);
8151         }
8152         if (isunix) trim_unixpath(string,item,1);
8153         add_item(head, tail, string, count);
8154         ++expcount;
8155     }
8156     PerlMem_free(vmsspec);
8157     if (sts != RMS$_NMF)
8158         {
8159         set_vaxc_errno(sts);
8160         switch (sts)
8161             {
8162             case RMS$_FNF: case RMS$_DNF:
8163                 set_errno(ENOENT); break;
8164             case RMS$_DIR:
8165                 set_errno(ENOTDIR); break;
8166             case RMS$_DEV:
8167                 set_errno(ENODEV); break;
8168             case RMS$_FNM: case RMS$_SYN:
8169                 set_errno(EINVAL); break;
8170             case RMS$_PRV:
8171                 set_errno(EACCES); break;
8172             default:
8173                 _ckvmssts_noperl(sts);
8174             }
8175         }
8176     if (expcount == 0)
8177         add_item(head, tail, item, count);
8178     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8179     _ckvmssts_noperl(lib$find_file_end(&context));
8180 }
8181
8182 static int child_st[2];/* Event Flag set when child process completes   */
8183
8184 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
8185
8186 static unsigned long int exit_handler(int *status)
8187 {
8188 short iosb[4];
8189
8190     if (0 == child_st[0])
8191         {
8192 #ifdef ARGPROC_DEBUG
8193         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8194 #endif
8195         fflush(stdout);     /* Have to flush pipe for binary data to    */
8196                             /* terminate properly -- <tp@mccall.com>    */
8197         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8198         sys$dassgn(child_chan);
8199         fclose(stdout);
8200         sys$synch(0, child_st);
8201         }
8202     return(1);
8203 }
8204
8205 static void sig_child(int chan)
8206 {
8207 #ifdef ARGPROC_DEBUG
8208     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8209 #endif
8210     if (child_st[0] == 0)
8211         child_st[0] = 1;
8212 }
8213
8214 static struct exit_control_block exit_block =
8215     {
8216     0,
8217     exit_handler,
8218     1,
8219     &exit_block.exit_status,
8220     0
8221     };
8222
8223 static void
8224 pipe_and_fork(pTHX_ char **cmargv)
8225 {
8226     PerlIO *fp;
8227     struct dsc$descriptor_s *vmscmd;
8228     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8229     int sts, j, l, ismcr, quote, tquote = 0;
8230
8231     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8232     vms_execfree(vmscmd);
8233
8234     j = l = 0;
8235     p = subcmd;
8236     q = cmargv[0];
8237     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
8238               && toupper(*(q+2)) == 'R' && !*(q+3);
8239
8240     while (q && l < MAX_DCL_LINE_LENGTH) {
8241         if (!*q) {
8242             if (j > 0 && quote) {
8243                 *p++ = '"';
8244                 l++;
8245             }
8246             q = cmargv[++j];
8247             if (q) {
8248                 if (ismcr && j > 1) quote = 1;
8249                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
8250                 *p++ = ' ';
8251                 l++;
8252                 if (quote || tquote) {
8253                     *p++ = '"';
8254                     l++;
8255                 }
8256             }
8257         } else {
8258             if ((quote||tquote) && *q == '"') {
8259                 *p++ = '"';
8260                 l++;
8261             }
8262             *p++ = *q++;
8263             l++;
8264         }
8265     }
8266     *p = '\0';
8267
8268     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8269     if (fp == Nullfp) {
8270         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8271     }
8272 }
8273
8274 static int background_process(pTHX_ int argc, char **argv)
8275 {
8276 char command[MAX_DCL_SYMBOL + 1] = "$";
8277 $DESCRIPTOR(value, "");
8278 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8279 static $DESCRIPTOR(null, "NLA0:");
8280 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8281 char pidstring[80];
8282 $DESCRIPTOR(pidstr, "");
8283 int pid;
8284 unsigned long int flags = 17, one = 1, retsts;
8285 int len;
8286
8287     strcat(command, argv[0]);
8288     len = strlen(command);
8289     while (--argc && (len < MAX_DCL_SYMBOL))
8290         {
8291         strcat(command, " \"");
8292         strcat(command, *(++argv));
8293         strcat(command, "\"");
8294         len = strlen(command);
8295         }
8296     value.dsc$a_pointer = command;
8297     value.dsc$w_length = strlen(value.dsc$a_pointer);
8298     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8299     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8300     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8301         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8302     }
8303     else {
8304         _ckvmssts_noperl(retsts);
8305     }
8306 #ifdef ARGPROC_DEBUG
8307     PerlIO_printf(Perl_debug_log, "%s\n", command);
8308 #endif
8309     sprintf(pidstring, "%08X", pid);
8310     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8311     pidstr.dsc$a_pointer = pidstring;
8312     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8313     lib$set_symbol(&pidsymbol, &pidstr);
8314     return(SS$_NORMAL);
8315 }
8316 /*}}}*/
8317 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8318
8319
8320 /* OS-specific initialization at image activation (not thread startup) */
8321 /* Older VAXC header files lack these constants */
8322 #ifndef JPI$_RIGHTS_SIZE
8323 #  define JPI$_RIGHTS_SIZE 817
8324 #endif
8325 #ifndef KGB$M_SUBSYSTEM
8326 #  define KGB$M_SUBSYSTEM 0x8
8327 #endif
8328
8329 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8330
8331 /*{{{void vms_image_init(int *, char ***)*/
8332 void
8333 vms_image_init(int *argcp, char ***argvp)
8334 {
8335   char eqv[LNM$C_NAMLENGTH+1] = "";
8336   unsigned int len, tabct = 8, tabidx = 0;
8337   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8338   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8339   unsigned short int dummy, rlen;
8340   struct dsc$descriptor_s **tabvec;
8341 #if defined(PERL_IMPLICIT_CONTEXT)
8342   pTHX = NULL;
8343 #endif
8344   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8345                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8346                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8347                                  {          0,                0,    0,      0} };
8348
8349 #ifdef KILL_BY_SIGPRC
8350     Perl_csighandler_init();
8351 #endif
8352
8353   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8354   _ckvmssts_noperl(iosb[0]);
8355   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8356     if (iprv[i]) {           /* Running image installed with privs? */
8357       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8358       will_taint = TRUE;
8359       break;
8360     }
8361   }
8362   /* Rights identifiers might trigger tainting as well. */
8363   if (!will_taint && (rlen || rsz)) {
8364     while (rlen < rsz) {
8365       /* We didn't get all the identifiers on the first pass.  Allocate a
8366        * buffer much larger than $GETJPI wants (rsz is size in bytes that
8367        * were needed to hold all identifiers at time of last call; we'll
8368        * allocate that many unsigned long ints), and go back and get 'em.
8369        * If it gave us less than it wanted to despite ample buffer space,
8370        * something's broken.  Is your system missing a system identifier?
8371        */
8372       if (rsz <= jpilist[1].buflen) {
8373          /* Perl_croak accvios when used this early in startup. */
8374          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8375                          rsz, (unsigned long) jpilist[1].buflen,
8376                          "Check your rights database for corruption.\n");
8377          exit(SS$_ABORT);
8378       }
8379       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8380       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8381       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8382       jpilist[1].buflen = rsz * sizeof(unsigned long int);
8383       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8384       _ckvmssts_noperl(iosb[0]);
8385     }
8386     mask = jpilist[1].bufadr;
8387     /* Check attribute flags for each identifier (2nd longword); protected
8388      * subsystem identifiers trigger tainting.
8389      */
8390     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8391       if (mask[i] & KGB$M_SUBSYSTEM) {
8392         will_taint = TRUE;
8393         break;
8394       }
8395     }
8396     if (mask != rlst) PerlMem_free(mask);
8397   }
8398
8399   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8400    * logical, some versions of the CRTL will add a phanthom /000000/
8401    * directory.  This needs to be removed.
8402    */
8403   if (decc_filename_unix_report) {
8404   char * zeros;
8405   int ulen;
8406     ulen = strlen(argvp[0][0]);
8407     if (ulen > 7) {
8408       zeros = strstr(argvp[0][0], "/000000/");
8409       if (zeros != NULL) {
8410         int mlen;
8411         mlen = ulen - (zeros - argvp[0][0]) - 7;
8412         memmove(zeros, &zeros[7], mlen);
8413         ulen = ulen - 7;
8414         argvp[0][0][ulen] = '\0';
8415       }
8416     }
8417     /* It also may have a trailing dot that needs to be removed otherwise
8418      * it will be converted to VMS mode incorrectly.
8419      */
8420     ulen--;
8421     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8422       argvp[0][0][ulen] = '\0';
8423   }
8424
8425   /* We need to use this hack to tell Perl it should run with tainting,
8426    * since its tainting flag may be part of the PL_curinterp struct, which
8427    * hasn't been allocated when vms_image_init() is called.
8428    */
8429   if (will_taint) {
8430     char **newargv, **oldargv;
8431     oldargv = *argvp;
8432     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8433     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8434     newargv[0] = oldargv[0];
8435     newargv[1] = PerlMem_malloc(3 * sizeof(char));
8436     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8437     strcpy(newargv[1], "-T");
8438     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8439     (*argcp)++;
8440     newargv[*argcp] = NULL;
8441     /* We orphan the old argv, since we don't know where it's come from,
8442      * so we don't know how to free it.
8443      */
8444     *argvp = newargv;
8445   }
8446   else {  /* Did user explicitly request tainting? */
8447     int i;
8448     char *cp, **av = *argvp;
8449     for (i = 1; i < *argcp; i++) {
8450       if (*av[i] != '-') break;
8451       for (cp = av[i]+1; *cp; cp++) {
8452         if (*cp == 'T') { will_taint = 1; break; }
8453         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8454                   strchr("DFIiMmx",*cp)) break;
8455       }
8456       if (will_taint) break;
8457     }
8458   }
8459
8460   for (tabidx = 0;
8461        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8462        tabidx++) {
8463     if (!tabidx) {
8464       tabvec = (struct dsc$descriptor_s **)
8465             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8466       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8467     }
8468     else if (tabidx >= tabct) {
8469       tabct += 8;
8470       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8471       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8472     }
8473     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8474     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8475     tabvec[tabidx]->dsc$w_length  = 0;
8476     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
8477     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
8478     tabvec[tabidx]->dsc$a_pointer = NULL;
8479     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8480   }
8481   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8482
8483   getredirection(argcp,argvp);
8484 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8485   {
8486 # include <reentrancy.h>
8487   decc$set_reentrancy(C$C_MULTITHREAD);
8488   }
8489 #endif
8490   return;
8491 }
8492 /*}}}*/
8493
8494
8495 /* trim_unixpath()
8496  * Trim Unix-style prefix off filespec, so it looks like what a shell
8497  * glob expansion would return (i.e. from specified prefix on, not
8498  * full path).  Note that returned filespec is Unix-style, regardless
8499  * of whether input filespec was VMS-style or Unix-style.
8500  *
8501  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8502  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
8503  * vector of options; at present, only bit 0 is used, and if set tells
8504  * trim unixpath to try the current default directory as a prefix when
8505  * presented with a possibly ambiguous ... wildcard.
8506  *
8507  * Returns !=0 on success, with trimmed filespec replacing contents of
8508  * fspec, and 0 on failure, with contents of fpsec unchanged.
8509  */
8510 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8511 int
8512 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8513 {
8514   char *unixified, *unixwild,
8515        *template, *base, *end, *cp1, *cp2;
8516   register int tmplen, reslen = 0, dirs = 0;
8517
8518   unixwild = PerlMem_malloc(VMS_MAXRSS);
8519   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8520   if (!wildspec || !fspec) return 0;
8521   template = unixwild;
8522   if (strpbrk(wildspec,"]>:") != NULL) {
8523     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8524         PerlMem_free(unixwild);
8525         return 0;
8526     }
8527   }
8528   else {
8529     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8530     unixwild[VMS_MAXRSS-1] = 0;
8531   }
8532   unixified = PerlMem_malloc(VMS_MAXRSS);
8533   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8534   if (strpbrk(fspec,"]>:") != NULL) {
8535     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8536         PerlMem_free(unixwild);
8537         PerlMem_free(unixified);
8538         return 0;
8539     }
8540     else base = unixified;
8541     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8542      * check to see that final result fits into (isn't longer than) fspec */
8543     reslen = strlen(fspec);
8544   }
8545   else base = fspec;
8546
8547   /* No prefix or absolute path on wildcard, so nothing to remove */
8548   if (!*template || *template == '/') {
8549     PerlMem_free(unixwild);
8550     if (base == fspec) {
8551         PerlMem_free(unixified);
8552         return 1;
8553     }
8554     tmplen = strlen(unixified);
8555     if (tmplen > reslen) {
8556         PerlMem_free(unixified);
8557         return 0;  /* not enough space */
8558     }
8559     /* Copy unixified resultant, including trailing NUL */
8560     memmove(fspec,unixified,tmplen+1);
8561     PerlMem_free(unixified);
8562     return 1;
8563   }
8564
8565   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
8566   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8567     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8568     for (cp1 = end ;cp1 >= base; cp1--)
8569       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8570         { cp1++; break; }
8571     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8572     PerlMem_free(unixified);
8573     PerlMem_free(unixwild);
8574     return 1;
8575   }
8576   else {
8577     char *tpl, *lcres;
8578     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8579     int ells = 1, totells, segdirs, match;
8580     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8581                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8582
8583     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8584     totells = ells;
8585     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8586     tpl = PerlMem_malloc(VMS_MAXRSS);
8587     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8588     if (ellipsis == template && opts & 1) {
8589       /* Template begins with an ellipsis.  Since we can't tell how many
8590        * directory names at the front of the resultant to keep for an
8591        * arbitrary starting point, we arbitrarily choose the current
8592        * default directory as a starting point.  If it's there as a prefix,
8593        * clip it off.  If not, fall through and act as if the leading
8594        * ellipsis weren't there (i.e. return shortest possible path that
8595        * could match template).
8596        */
8597       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8598           PerlMem_free(tpl);
8599           PerlMem_free(unixified);
8600           PerlMem_free(unixwild);
8601           return 0;
8602       }
8603       if (!decc_efs_case_preserve) {
8604         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8605           if (_tolower(*cp1) != _tolower(*cp2)) break;
8606       }
8607       segdirs = dirs - totells;  /* Min # of dirs we must have left */
8608       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8609       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8610         memmove(fspec,cp2+1,end - cp2);
8611         PerlMem_free(tpl);
8612         PerlMem_free(unixified);
8613         PerlMem_free(unixwild);
8614         return 1;
8615       }
8616     }
8617     /* First off, back up over constant elements at end of path */
8618     if (dirs) {
8619       for (front = end ; front >= base; front--)
8620          if (*front == '/' && !dirs--) { front++; break; }
8621     }
8622     lcres = PerlMem_malloc(VMS_MAXRSS);
8623     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8624     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8625          cp1++,cp2++) {
8626             if (!decc_efs_case_preserve) {
8627                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
8628             }
8629             else {
8630                 *cp2 = *cp1;
8631             }
8632     }
8633     if (cp1 != '\0') {
8634         PerlMem_free(tpl);
8635         PerlMem_free(unixified);
8636         PerlMem_free(unixwild);
8637         PerlMem_free(lcres);
8638         return 0;  /* Path too long. */
8639     }
8640     lcend = cp2;
8641     *cp2 = '\0';  /* Pick up with memcpy later */
8642     lcfront = lcres + (front - base);
8643     /* Now skip over each ellipsis and try to match the path in front of it. */
8644     while (ells--) {
8645       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8646         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
8647             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
8648       if (cp1 < template) break; /* template started with an ellipsis */
8649       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8650         ellipsis = cp1; continue;
8651       }
8652       wilddsc.dsc$a_pointer = tpl;
8653       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8654       nextell = cp1;
8655       for (segdirs = 0, cp2 = tpl;
8656            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8657            cp1++, cp2++) {
8658          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8659          else {
8660             if (!decc_efs_case_preserve) {
8661               *cp2 = _tolower(*cp1);  /* else lowercase for match */
8662             }
8663             else {
8664               *cp2 = *cp1;  /* else preserve case for match */
8665             }
8666          }
8667          if (*cp2 == '/') segdirs++;
8668       }
8669       if (cp1 != ellipsis - 1) {
8670           PerlMem_free(tpl);
8671           PerlMem_free(unixified);
8672           PerlMem_free(unixwild);
8673           PerlMem_free(lcres);
8674           return 0; /* Path too long */
8675       }
8676       /* Back up at least as many dirs as in template before matching */
8677       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8678         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8679       for (match = 0; cp1 > lcres;) {
8680         resdsc.dsc$a_pointer = cp1;
8681         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8682           match++;
8683           if (match == 1) lcfront = cp1;
8684         }
8685         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8686       }
8687       if (!match) {
8688         PerlMem_free(tpl);
8689         PerlMem_free(unixified);
8690         PerlMem_free(unixwild);
8691         PerlMem_free(lcres);
8692         return 0;  /* Can't find prefix ??? */
8693       }
8694       if (match > 1 && opts & 1) {
8695         /* This ... wildcard could cover more than one set of dirs (i.e.
8696          * a set of similar dir names is repeated).  If the template
8697          * contains more than 1 ..., upstream elements could resolve the
8698          * ambiguity, but it's not worth a full backtracking setup here.
8699          * As a quick heuristic, clip off the current default directory
8700          * if it's present to find the trimmed spec, else use the
8701          * shortest string that this ... could cover.
8702          */
8703         char def[NAM$C_MAXRSS+1], *st;
8704
8705         if (getcwd(def, sizeof def,0) == NULL) {
8706             Safefree(unixified);
8707             Safefree(unixwild);
8708             Safefree(lcres);
8709             Safefree(tpl);
8710             return 0;
8711         }
8712         if (!decc_efs_case_preserve) {
8713           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8714             if (_tolower(*cp1) != _tolower(*cp2)) break;
8715         }
8716         segdirs = dirs - totells;  /* Min # of dirs we must have left */
8717         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8718         if (*cp1 == '\0' && *cp2 == '/') {
8719           memmove(fspec,cp2+1,end - cp2);
8720           PerlMem_free(tpl);
8721           PerlMem_free(unixified);
8722           PerlMem_free(unixwild);
8723           PerlMem_free(lcres);
8724           return 1;
8725         }
8726         /* Nope -- stick with lcfront from above and keep going. */
8727       }
8728     }
8729     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8730     PerlMem_free(tpl);
8731     PerlMem_free(unixified);
8732     PerlMem_free(unixwild);
8733     PerlMem_free(lcres);
8734     return 1;
8735     ellipsis = nextell;
8736   }
8737
8738 }  /* end of trim_unixpath() */
8739 /*}}}*/
8740
8741
8742 /*
8743  *  VMS readdir() routines.
8744  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8745  *
8746  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
8747  *  Minor modifications to original routines.
8748  */
8749
8750 /* readdir may have been redefined by reentr.h, so make sure we get
8751  * the local version for what we do here.
8752  */
8753 #ifdef readdir
8754 # undef readdir
8755 #endif
8756 #if !defined(PERL_IMPLICIT_CONTEXT)
8757 # define readdir Perl_readdir
8758 #else
8759 # define readdir(a) Perl_readdir(aTHX_ a)
8760 #endif
8761
8762     /* Number of elements in vms_versions array */
8763 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
8764
8765 /*
8766  *  Open a directory, return a handle for later use.
8767  */
8768 /*{{{ DIR *opendir(char*name) */
8769 DIR *
8770 Perl_opendir(pTHX_ const char *name)
8771 {
8772     DIR *dd;
8773     char *dir;
8774     Stat_t sb;
8775
8776     Newx(dir, VMS_MAXRSS, char);
8777     if (do_tovmspath(name,dir,0,NULL) == NULL) {
8778       Safefree(dir);
8779       return NULL;
8780     }
8781     /* Check access before stat; otherwise stat does not
8782      * accurately report whether it's a directory.
8783      */
8784     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8785       /* cando_by_name has already set errno */
8786       Safefree(dir);
8787       return NULL;
8788     }
8789     if (flex_stat(dir,&sb) == -1) return NULL;
8790     if (!S_ISDIR(sb.st_mode)) {
8791       Safefree(dir);
8792       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
8793       return NULL;
8794     }
8795     /* Get memory for the handle, and the pattern. */
8796     Newx(dd,1,DIR);
8797     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8798
8799     /* Fill in the fields; mainly playing with the descriptor. */
8800     sprintf(dd->pattern, "%s*.*",dir);
8801     Safefree(dir);
8802     dd->context = 0;
8803     dd->count = 0;
8804     dd->flags = 0;
8805     /* By saying we always want the result of readdir() in unix format, we
8806      * are really saying we want all the escapes removed.  Otherwise the caller,
8807      * having no way to know whether it's already in VMS format, might send it
8808      * through tovmsspec again, thus double escaping.
8809      */
8810     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8811     dd->pat.dsc$a_pointer = dd->pattern;
8812     dd->pat.dsc$w_length = strlen(dd->pattern);
8813     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8814     dd->pat.dsc$b_class = DSC$K_CLASS_S;
8815 #if defined(USE_ITHREADS)
8816     Newx(dd->mutex,1,perl_mutex);
8817     MUTEX_INIT( (perl_mutex *) dd->mutex );
8818 #else
8819     dd->mutex = NULL;
8820 #endif
8821
8822     return dd;
8823 }  /* end of opendir() */
8824 /*}}}*/
8825
8826 /*
8827  *  Set the flag to indicate we want versions or not.
8828  */
8829 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8830 void
8831 vmsreaddirversions(DIR *dd, int flag)
8832 {
8833     if (flag)
8834         dd->flags |= PERL_VMSDIR_M_VERSIONS;
8835     else
8836         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8837 }
8838 /*}}}*/
8839
8840 /*
8841  *  Free up an opened directory.
8842  */
8843 /*{{{ void closedir(DIR *dd)*/
8844 void
8845 Perl_closedir(DIR *dd)
8846 {
8847     int sts;
8848
8849     sts = lib$find_file_end(&dd->context);
8850     Safefree(dd->pattern);
8851 #if defined(USE_ITHREADS)
8852     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8853     Safefree(dd->mutex);
8854 #endif
8855     Safefree(dd);
8856 }
8857 /*}}}*/
8858
8859 /*
8860  *  Collect all the version numbers for the current file.
8861  */
8862 static void
8863 collectversions(pTHX_ DIR *dd)
8864 {
8865     struct dsc$descriptor_s     pat;
8866     struct dsc$descriptor_s     res;
8867     struct dirent *e;
8868     char *p, *text, *buff;
8869     int i;
8870     unsigned long context, tmpsts;
8871
8872     /* Convenient shorthand. */
8873     e = &dd->entry;
8874
8875     /* Add the version wildcard, ignoring the "*.*" put on before */
8876     i = strlen(dd->pattern);
8877     Newx(text,i + e->d_namlen + 3,char);
8878     strcpy(text, dd->pattern);
8879     sprintf(&text[i - 3], "%s;*", e->d_name);
8880
8881     /* Set up the pattern descriptor. */
8882     pat.dsc$a_pointer = text;
8883     pat.dsc$w_length = i + e->d_namlen - 1;
8884     pat.dsc$b_dtype = DSC$K_DTYPE_T;
8885     pat.dsc$b_class = DSC$K_CLASS_S;
8886
8887     /* Set up result descriptor. */
8888     Newx(buff, VMS_MAXRSS, char);
8889     res.dsc$a_pointer = buff;
8890     res.dsc$w_length = VMS_MAXRSS - 1;
8891     res.dsc$b_dtype = DSC$K_DTYPE_T;
8892     res.dsc$b_class = DSC$K_CLASS_S;
8893
8894     /* Read files, collecting versions. */
8895     for (context = 0, e->vms_verscount = 0;
8896          e->vms_verscount < VERSIZE(e);
8897          e->vms_verscount++) {
8898         unsigned long rsts;
8899         unsigned long flags = 0;
8900
8901 #ifdef VMS_LONGNAME_SUPPORT
8902         flags = LIB$M_FIL_LONG_NAMES;
8903 #endif
8904         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8905         if (tmpsts == RMS$_NMF || context == 0) break;
8906         _ckvmssts(tmpsts);
8907         buff[VMS_MAXRSS - 1] = '\0';
8908         if ((p = strchr(buff, ';')))
8909             e->vms_versions[e->vms_verscount] = atoi(p + 1);
8910         else
8911             e->vms_versions[e->vms_verscount] = -1;
8912     }
8913
8914     _ckvmssts(lib$find_file_end(&context));
8915     Safefree(text);
8916     Safefree(buff);
8917
8918 }  /* end of collectversions() */
8919
8920 /*
8921  *  Read the next entry from the directory.
8922  */
8923 /*{{{ struct dirent *readdir(DIR *dd)*/
8924 struct dirent *
8925 Perl_readdir(pTHX_ DIR *dd)
8926 {
8927     struct dsc$descriptor_s     res;
8928     char *p, *buff;
8929     unsigned long int tmpsts;
8930     unsigned long rsts;
8931     unsigned long flags = 0;
8932     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8933     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8934
8935     /* Set up result descriptor, and get next file. */
8936     Newx(buff, VMS_MAXRSS, char);
8937     res.dsc$a_pointer = buff;
8938     res.dsc$w_length = VMS_MAXRSS - 1;
8939     res.dsc$b_dtype = DSC$K_DTYPE_T;
8940     res.dsc$b_class = DSC$K_CLASS_S;
8941
8942 #ifdef VMS_LONGNAME_SUPPORT
8943     flags = LIB$M_FIL_LONG_NAMES;
8944 #endif
8945
8946     tmpsts = lib$find_file
8947         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8948     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
8949     if (!(tmpsts & 1)) {
8950       set_vaxc_errno(tmpsts);
8951       switch (tmpsts) {
8952         case RMS$_PRV:
8953           set_errno(EACCES); break;
8954         case RMS$_DEV:
8955           set_errno(ENODEV); break;
8956         case RMS$_DIR:
8957           set_errno(ENOTDIR); break;
8958         case RMS$_FNF: case RMS$_DNF:
8959           set_errno(ENOENT); break;
8960         default:
8961           set_errno(EVMSERR);
8962       }
8963       Safefree(buff);
8964       return NULL;
8965     }
8966     dd->count++;
8967     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8968     if (!decc_efs_case_preserve) {
8969       buff[VMS_MAXRSS - 1] = '\0';
8970       for (p = buff; *p; p++) *p = _tolower(*p);
8971     }
8972     else {
8973       /* we don't want to force to lowercase, just null terminate */
8974       buff[res.dsc$w_length] = '\0';
8975     }
8976     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
8977     *p = '\0';
8978
8979     /* Skip any directory component and just copy the name. */
8980     sts = vms_split_path
8981        (buff,
8982         &v_spec,
8983         &v_len,
8984         &r_spec,
8985         &r_len,
8986         &d_spec,
8987         &d_len,
8988         &n_spec,
8989         &n_len,
8990         &e_spec,
8991         &e_len,
8992         &vs_spec,
8993         &vs_len);
8994
8995     /* Drop NULL extensions on UNIX file specification */
8996     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8997         (e_len == 1) && decc_readdir_dropdotnotype)) {
8998         e_len = 0;
8999         e_spec[0] = '\0';
9000     }
9001
9002     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9003     dd->entry.d_name[n_len + e_len] = '\0';
9004     dd->entry.d_namlen = strlen(dd->entry.d_name);
9005
9006     /* Convert the filename to UNIX format if needed */
9007     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9008
9009         /* Translate the encoded characters. */
9010         /* Fixme: Unicode handling could result in embedded 0 characters */
9011         if (strchr(dd->entry.d_name, '^') != NULL) {
9012             char new_name[256];
9013             char * q;
9014             p = dd->entry.d_name;
9015             q = new_name;
9016             while (*p != 0) {
9017                 int inchars_read, outchars_added;
9018                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9019                 p += inchars_read;
9020                 q += outchars_added;
9021                 /* fix-me */
9022                 /* if outchars_added > 1, then this is a wide file specification */
9023                 /* Wide file specifications need to be passed in Perl */
9024                 /* counted strings apparently with a Unicode flag */
9025             }
9026             *q = 0;
9027             strcpy(dd->entry.d_name, new_name);
9028             dd->entry.d_namlen = strlen(dd->entry.d_name);
9029         }
9030     }
9031
9032     dd->entry.vms_verscount = 0;
9033     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9034     Safefree(buff);
9035     return &dd->entry;
9036
9037 }  /* end of readdir() */
9038 /*}}}*/
9039
9040 /*
9041  *  Read the next entry from the directory -- thread-safe version.
9042  */
9043 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9044 int
9045 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9046 {
9047     int retval;
9048
9049     MUTEX_LOCK( (perl_mutex *) dd->mutex );
9050
9051     entry = readdir(dd);
9052     *result = entry;
9053     retval = ( *result == NULL ? errno : 0 );
9054
9055     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9056
9057     return retval;
9058
9059 }  /* end of readdir_r() */
9060 /*}}}*/
9061
9062 /*
9063  *  Return something that can be used in a seekdir later.
9064  */
9065 /*{{{ long telldir(DIR *dd)*/
9066 long
9067 Perl_telldir(DIR *dd)
9068 {
9069     return dd->count;
9070 }
9071 /*}}}*/
9072
9073 /*
9074  *  Return to a spot where we used to be.  Brute force.
9075  */
9076 /*{{{ void seekdir(DIR *dd,long count)*/
9077 void
9078 Perl_seekdir(pTHX_ DIR *dd, long count)
9079 {
9080     int old_flags;
9081
9082     /* If we haven't done anything yet... */
9083     if (dd->count == 0)
9084         return;
9085
9086     /* Remember some state, and clear it. */
9087     old_flags = dd->flags;
9088     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9089     _ckvmssts(lib$find_file_end(&dd->context));
9090     dd->context = 0;
9091
9092     /* The increment is in readdir(). */
9093     for (dd->count = 0; dd->count < count; )
9094         readdir(dd);
9095
9096     dd->flags = old_flags;
9097
9098 }  /* end of seekdir() */
9099 /*}}}*/
9100
9101 /* VMS subprocess management
9102  *
9103  * my_vfork() - just a vfork(), after setting a flag to record that
9104  * the current script is trying a Unix-style fork/exec.
9105  *
9106  * vms_do_aexec() and vms_do_exec() are called in response to the
9107  * perl 'exec' function.  If this follows a vfork call, then they
9108  * call out the regular perl routines in doio.c which do an
9109  * execvp (for those who really want to try this under VMS).
9110  * Otherwise, they do exactly what the perl docs say exec should
9111  * do - terminate the current script and invoke a new command
9112  * (See below for notes on command syntax.)
9113  *
9114  * do_aspawn() and do_spawn() implement the VMS side of the perl
9115  * 'system' function.
9116  *
9117  * Note on command arguments to perl 'exec' and 'system': When handled
9118  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9119  * are concatenated to form a DCL command string.  If the first arg
9120  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
9121  * the command string is handed off to DCL directly.  Otherwise,
9122  * the first token of the command is taken as the filespec of an image
9123  * to run.  The filespec is expanded using a default type of '.EXE' and
9124  * the process defaults for device, directory, etc., and if found, the resultant
9125  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9126  * the command string as parameters.  This is perhaps a bit complicated,
9127  * but I hope it will form a happy medium between what VMS folks expect
9128  * from lib$spawn and what Unix folks expect from exec.
9129  */
9130
9131 static int vfork_called;
9132
9133 /*{{{int my_vfork()*/
9134 int
9135 my_vfork()
9136 {
9137   vfork_called++;
9138   return vfork();
9139 }
9140 /*}}}*/
9141
9142
9143 static void
9144 vms_execfree(struct dsc$descriptor_s *vmscmd)
9145 {
9146   if (vmscmd) {
9147       if (vmscmd->dsc$a_pointer) {
9148           PerlMem_free(vmscmd->dsc$a_pointer);
9149       }
9150       PerlMem_free(vmscmd);
9151   }
9152 }
9153
9154 static char *
9155 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9156 {
9157   char *junk, *tmps = Nullch;
9158   register size_t cmdlen = 0;
9159   size_t rlen;
9160   register SV **idx;
9161   STRLEN n_a;
9162
9163   idx = mark;
9164   if (really) {
9165     tmps = SvPV(really,rlen);
9166     if (*tmps) {
9167       cmdlen += rlen + 1;
9168       idx++;
9169     }
9170   }
9171
9172   for (idx++; idx <= sp; idx++) {
9173     if (*idx) {
9174       junk = SvPVx(*idx,rlen);
9175       cmdlen += rlen ? rlen + 1 : 0;
9176     }
9177   }
9178   Newx(PL_Cmd, cmdlen+1, char);
9179
9180   if (tmps && *tmps) {
9181     strcpy(PL_Cmd,tmps);
9182     mark++;
9183   }
9184   else *PL_Cmd = '\0';
9185   while (++mark <= sp) {
9186     if (*mark) {
9187       char *s = SvPVx(*mark,n_a);
9188       if (!*s) continue;
9189       if (*PL_Cmd) strcat(PL_Cmd," ");
9190       strcat(PL_Cmd,s);
9191     }
9192   }
9193   return PL_Cmd;
9194
9195 }  /* end of setup_argstr() */
9196
9197
9198 static unsigned long int
9199 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9200                    struct dsc$descriptor_s **pvmscmd)
9201 {
9202   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9203   char image_name[NAM$C_MAXRSS+1];
9204   char image_argv[NAM$C_MAXRSS+1];
9205   $DESCRIPTOR(defdsc,".EXE");
9206   $DESCRIPTOR(defdsc2,".");
9207   $DESCRIPTOR(resdsc,resspec);
9208   struct dsc$descriptor_s *vmscmd;
9209   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9210   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9211   register char *s, *rest, *cp, *wordbreak;
9212   char * cmd;
9213   int cmdlen;
9214   register int isdcl;
9215
9216   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9217   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9218
9219   /* Make a copy for modification */
9220   cmdlen = strlen(incmd);
9221   cmd = PerlMem_malloc(cmdlen+1);
9222   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9223   strncpy(cmd, incmd, cmdlen);
9224   cmd[cmdlen] = 0;
9225   image_name[0] = 0;
9226   image_argv[0] = 0;
9227
9228   vmscmd->dsc$a_pointer = NULL;
9229   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
9230   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
9231   vmscmd->dsc$w_length = 0;
9232   if (pvmscmd) *pvmscmd = vmscmd;
9233
9234   if (suggest_quote) *suggest_quote = 0;
9235
9236   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9237     PerlMem_free(cmd);
9238     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
9239   }
9240
9241   s = cmd;
9242
9243   while (*s && isspace(*s)) s++;
9244
9245   if (*s == '@' || *s == '$') {
9246     vmsspec[0] = *s;  rest = s + 1;
9247     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9248   }
9249   else { cp = vmsspec; rest = s; }
9250   if (*rest == '.' || *rest == '/') {
9251     char *cp2;
9252     for (cp2 = resspec;
9253          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9254          rest++, cp2++) *cp2 = *rest;
9255     *cp2 = '\0';
9256     if (do_tovmsspec(resspec,cp,0,NULL)) {
9257       s = vmsspec;
9258       if (*rest) {
9259         for (cp2 = vmsspec + strlen(vmsspec);
9260              *rest && cp2 - vmsspec < sizeof vmsspec;
9261              rest++, cp2++) *cp2 = *rest;
9262         *cp2 = '\0';
9263       }
9264     }
9265   }
9266   /* Intuit whether verb (first word of cmd) is a DCL command:
9267    *   - if first nonspace char is '@', it's a DCL indirection
9268    * otherwise
9269    *   - if verb contains a filespec separator, it's not a DCL command
9270    *   - if it doesn't, caller tells us whether to default to a DCL
9271    *     command, or to a local image unless told it's DCL (by leading '$')
9272    */
9273   if (*s == '@') {
9274       isdcl = 1;
9275       if (suggest_quote) *suggest_quote = 1;
9276   } else {
9277     register char *filespec = strpbrk(s,":<[.;");
9278     rest = wordbreak = strpbrk(s," \"\t/");
9279     if (!wordbreak) wordbreak = s + strlen(s);
9280     if (*s == '$') check_img = 0;
9281     if (filespec && (filespec < wordbreak)) isdcl = 0;
9282     else isdcl = !check_img;
9283   }
9284
9285   if (!isdcl) {
9286     int rsts;
9287     imgdsc.dsc$a_pointer = s;
9288     imgdsc.dsc$w_length = wordbreak - s;
9289     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9290     if (!(retsts&1)) {
9291         _ckvmssts(lib$find_file_end(&cxt));
9292         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9293       if (!(retsts & 1) && *s == '$') {
9294         _ckvmssts(lib$find_file_end(&cxt));
9295         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9296         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9297         if (!(retsts&1)) {
9298           _ckvmssts(lib$find_file_end(&cxt));
9299           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9300         }
9301       }
9302     }
9303     _ckvmssts(lib$find_file_end(&cxt));
9304
9305     if (retsts & 1) {
9306       FILE *fp;
9307       s = resspec;
9308       while (*s && !isspace(*s)) s++;
9309       *s = '\0';
9310
9311       /* check that it's really not DCL with no file extension */
9312       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9313       if (fp) {
9314         char b[256] = {0,0,0,0};
9315         read(fileno(fp), b, 256);
9316         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9317         if (isdcl) {
9318           int shebang_len;
9319
9320           /* Check for script */
9321           shebang_len = 0;
9322           if ((b[0] == '#') && (b[1] == '!'))
9323              shebang_len = 2;
9324 #ifdef ALTERNATE_SHEBANG
9325           else {
9326             shebang_len = strlen(ALTERNATE_SHEBANG);
9327             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9328               char * perlstr;
9329                 perlstr = strstr("perl",b);
9330                 if (perlstr == NULL)
9331                   shebang_len = 0;
9332             }
9333             else
9334               shebang_len = 0;
9335           }
9336 #endif
9337
9338           if (shebang_len > 0) {
9339           int i;
9340           int j;
9341           char tmpspec[NAM$C_MAXRSS + 1];
9342
9343             i = shebang_len;
9344              /* Image is following after white space */
9345             /*--------------------------------------*/
9346             while (isprint(b[i]) && isspace(b[i]))
9347                 i++;
9348
9349             j = 0;
9350             while (isprint(b[i]) && !isspace(b[i])) {
9351                 tmpspec[j++] = b[i++];
9352                 if (j >= NAM$C_MAXRSS)
9353                    break;
9354             }
9355             tmpspec[j] = '\0';
9356
9357              /* There may be some default parameters to the image */
9358             /*---------------------------------------------------*/
9359             j = 0;
9360             while (isprint(b[i])) {
9361                 image_argv[j++] = b[i++];
9362                 if (j >= NAM$C_MAXRSS)
9363                    break;
9364             }
9365             while ((j > 0) && !isprint(image_argv[j-1]))
9366                 j--;
9367             image_argv[j] = 0;
9368
9369             /* It will need to be converted to VMS format and validated */
9370             if (tmpspec[0] != '\0') {
9371               char * iname;
9372
9373                /* Try to find the exact program requested to be run */
9374               /*---------------------------------------------------*/
9375               iname = do_rmsexpand
9376                  (tmpspec, image_name, 0, ".exe",
9377                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
9378               if (iname != NULL) {
9379                 if (cando_by_name_int
9380                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9381                   /* MCR prefix needed */
9382                   isdcl = 0;
9383                 }
9384                 else {
9385                    /* Try again with a null type */
9386                   /*----------------------------*/
9387                   iname = do_rmsexpand
9388                     (tmpspec, image_name, 0, ".",
9389                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
9390                   if (iname != NULL) {
9391                     if (cando_by_name_int
9392                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9393                       /* MCR prefix needed */
9394                       isdcl = 0;
9395                     }
9396                   }
9397                 }
9398
9399                  /* Did we find the image to run the script? */
9400                 /*------------------------------------------*/
9401                 if (isdcl) {
9402                   char *tchr;
9403
9404                    /* Assume DCL or foreign command exists */
9405                   /*--------------------------------------*/
9406                   tchr = strrchr(tmpspec, '/');
9407                   if (tchr != NULL) {
9408                     tchr++;
9409                   }
9410                   else {
9411                     tchr = tmpspec;
9412                   }
9413                   strcpy(image_name, tchr);
9414                 }
9415               }
9416             }
9417           }
9418         }
9419         fclose(fp);
9420       }
9421       if (check_img && isdcl) return RMS$_FNF;
9422
9423       if (cando_by_name(S_IXUSR,0,resspec)) {
9424         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9425         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9426         if (!isdcl) {
9427             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9428             if (image_name[0] != 0) {
9429                 strcat(vmscmd->dsc$a_pointer, image_name);
9430                 strcat(vmscmd->dsc$a_pointer, " ");
9431             }
9432         } else if (image_name[0] != 0) {
9433             strcpy(vmscmd->dsc$a_pointer, image_name);
9434             strcat(vmscmd->dsc$a_pointer, " ");
9435         } else {
9436             strcpy(vmscmd->dsc$a_pointer,"@");
9437         }
9438         if (suggest_quote) *suggest_quote = 1;
9439
9440         /* If there is an image name, use original command */
9441         if (image_name[0] == 0)
9442             strcat(vmscmd->dsc$a_pointer,resspec);
9443         else {
9444             rest = cmd;
9445             while (*rest && isspace(*rest)) rest++;
9446         }
9447
9448         if (image_argv[0] != 0) {
9449           strcat(vmscmd->dsc$a_pointer,image_argv);
9450           strcat(vmscmd->dsc$a_pointer, " ");
9451         }
9452         if (rest) {
9453            int rest_len;
9454            int vmscmd_len;
9455
9456            rest_len = strlen(rest);
9457            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9458            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9459               strcat(vmscmd->dsc$a_pointer,rest);
9460            else
9461              retsts = CLI$_BUFOVF;
9462         }
9463         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9464         PerlMem_free(cmd);
9465         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9466       }
9467       else
9468         retsts = RMS$_PRV;
9469     }
9470   }
9471   /* It's either a DCL command or we couldn't find a suitable image */
9472   vmscmd->dsc$w_length = strlen(cmd);
9473
9474   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9475   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9476   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9477
9478   PerlMem_free(cmd);
9479
9480   /* check if it's a symbol (for quoting purposes) */
9481   if (suggest_quote && !*suggest_quote) {
9482     int iss;
9483     char equiv[LNM$C_NAMLENGTH];
9484     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9485     eqvdsc.dsc$a_pointer = equiv;
9486
9487     iss = lib$get_symbol(vmscmd,&eqvdsc);
9488     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9489   }
9490   if (!(retsts & 1)) {
9491     /* just hand off status values likely to be due to user error */
9492     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9493         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9494        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9495     else { _ckvmssts(retsts); }
9496   }
9497
9498   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9499
9500 }  /* end of setup_cmddsc() */
9501
9502
9503 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9504 bool
9505 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9506 {
9507 bool exec_sts;
9508 char * cmd;
9509
9510   if (sp > mark) {
9511     if (vfork_called) {           /* this follows a vfork - act Unixish */
9512       vfork_called--;
9513       if (vfork_called < 0) {
9514         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9515         vfork_called = 0;
9516       }
9517       else return do_aexec(really,mark,sp);
9518     }
9519                                            /* no vfork - act VMSish */
9520     cmd = setup_argstr(aTHX_ really,mark,sp);
9521     exec_sts = vms_do_exec(cmd);
9522     Safefree(cmd);  /* Clean up from setup_argstr() */
9523     return exec_sts;
9524   }
9525
9526   return FALSE;
9527 }  /* end of vms_do_aexec() */
9528 /*}}}*/
9529
9530 /* {{{bool vms_do_exec(char *cmd) */
9531 bool
9532 Perl_vms_do_exec(pTHX_ const char *cmd)
9533 {
9534   struct dsc$descriptor_s *vmscmd;
9535
9536   if (vfork_called) {             /* this follows a vfork - act Unixish */
9537     vfork_called--;
9538     if (vfork_called < 0) {
9539       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9540       vfork_called = 0;
9541     }
9542     else return do_exec(cmd);
9543   }
9544
9545   {                               /* no vfork - act VMSish */
9546     unsigned long int retsts;
9547
9548     TAINT_ENV();
9549     TAINT_PROPER("exec");
9550     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9551       retsts = lib$do_command(vmscmd);
9552
9553     switch (retsts) {
9554       case RMS$_FNF: case RMS$_DNF:
9555         set_errno(ENOENT); break;
9556       case RMS$_DIR:
9557         set_errno(ENOTDIR); break;
9558       case RMS$_DEV:
9559         set_errno(ENODEV); break;
9560       case RMS$_PRV:
9561         set_errno(EACCES); break;
9562       case RMS$_SYN:
9563         set_errno(EINVAL); break;
9564       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9565         set_errno(E2BIG); break;
9566       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9567         _ckvmssts(retsts); /* fall through */
9568       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9569         set_errno(EVMSERR);
9570     }
9571     set_vaxc_errno(retsts);
9572     if (ckWARN(WARN_EXEC)) {
9573       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9574              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9575     }
9576     vms_execfree(vmscmd);
9577   }
9578
9579   return FALSE;
9580
9581 }  /* end of vms_do_exec() */
9582 /*}}}*/
9583
9584 unsigned long int Perl_do_spawn(pTHX_ const char *);
9585
9586 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9587 unsigned long int
9588 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9589 {
9590 unsigned long int sts;
9591 char * cmd;
9592
9593   if (sp > mark) {
9594     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9595     sts = do_spawn(cmd);
9596     /* pp_sys will clean up cmd */
9597     return sts;
9598   }
9599   return SS$_ABORT;
9600 }  /* end of do_aspawn() */
9601 /*}}}*/
9602
9603 /* {{{unsigned long int do_spawn(char *cmd) */
9604 unsigned long int
9605 Perl_do_spawn(pTHX_ const char *cmd)
9606 {
9607   unsigned long int sts, substs;
9608
9609   /* The caller of this routine expects to Safefree(PL_Cmd) */
9610   Newx(PL_Cmd,10,char);
9611
9612   TAINT_ENV();
9613   TAINT_PROPER("spawn");
9614   if (!cmd || !*cmd) {
9615     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9616     if (!(sts & 1)) {
9617       switch (sts) {
9618         case RMS$_FNF:  case RMS$_DNF:
9619           set_errno(ENOENT); break;
9620         case RMS$_DIR:
9621           set_errno(ENOTDIR); break;
9622         case RMS$_DEV:
9623           set_errno(ENODEV); break;
9624         case RMS$_PRV:
9625           set_errno(EACCES); break;
9626         case RMS$_SYN:
9627           set_errno(EINVAL); break;
9628         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9629           set_errno(E2BIG); break;
9630         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9631           _ckvmssts(sts); /* fall through */
9632         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9633           set_errno(EVMSERR);
9634       }
9635       set_vaxc_errno(sts);
9636       if (ckWARN(WARN_EXEC)) {
9637         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9638                     Strerror(errno));
9639       }
9640     }
9641     sts = substs;
9642   }
9643   else {
9644     PerlIO * fp;
9645     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9646     if (fp != NULL)
9647       my_pclose(fp);
9648   }
9649   return sts;
9650 }  /* end of do_spawn() */
9651 /*}}}*/
9652
9653
9654 static unsigned int *sockflags, sockflagsize;
9655
9656 /*
9657  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9658  * routines found in some versions of the CRTL can't deal with sockets.
9659  * We don't shim the other file open routines since a socket isn't
9660  * likely to be opened by a name.
9661  */
9662 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9663 FILE *my_fdopen(int fd, const char *mode)
9664 {
9665   FILE *fp = fdopen(fd, mode);
9666
9667   if (fp) {
9668     unsigned int fdoff = fd / sizeof(unsigned int);
9669     Stat_t sbuf; /* native stat; we don't need flex_stat */
9670     if (!sockflagsize || fdoff > sockflagsize) {
9671       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
9672       else           Newx  (sockflags,fdoff+2,unsigned int);
9673       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9674       sockflagsize = fdoff + 2;
9675     }
9676     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9677       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9678   }
9679   return fp;
9680
9681 }
9682 /*}}}*/
9683
9684
9685 /*
9686  * Clear the corresponding bit when the (possibly) socket stream is closed.
9687  * There still a small hole: we miss an implicit close which might occur
9688  * via freopen().  >> Todo
9689  */
9690 /*{{{ int my_fclose(FILE *fp)*/
9691 int my_fclose(FILE *fp) {
9692   if (fp) {
9693     unsigned int fd = fileno(fp);
9694     unsigned int fdoff = fd / sizeof(unsigned int);
9695
9696     if (sockflagsize && fdoff <= sockflagsize)
9697       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9698   }
9699   return fclose(fp);
9700 }
9701 /*}}}*/
9702
9703
9704 /*
9705  * A simple fwrite replacement which outputs itmsz*nitm chars without
9706  * introducing record boundaries every itmsz chars.
9707  * We are using fputs, which depends on a terminating null.  We may
9708  * well be writing binary data, so we need to accommodate not only
9709  * data with nulls sprinkled in the middle but also data with no null
9710  * byte at the end.
9711  */
9712 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9713 int
9714 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9715 {
9716   register char *cp, *end, *cpd, *data;
9717   register unsigned int fd = fileno(dest);
9718   register unsigned int fdoff = fd / sizeof(unsigned int);
9719   int retval;
9720   int bufsize = itmsz * nitm + 1;
9721
9722   if (fdoff < sockflagsize &&
9723       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9724     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9725     return nitm;
9726   }
9727
9728   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9729   memcpy( data, src, itmsz*nitm );
9730   data[itmsz*nitm] = '\0';
9731
9732   end = data + itmsz * nitm;
9733   retval = (int) nitm; /* on success return # items written */
9734
9735   cpd = data;
9736   while (cpd <= end) {
9737     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9738     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9739     if (cp < end)
9740       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9741     cpd = cp + 1;
9742   }
9743
9744   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9745   return retval;
9746
9747 }  /* end of my_fwrite() */
9748 /*}}}*/
9749
9750 /*{{{ int my_flush(FILE *fp)*/
9751 int
9752 Perl_my_flush(pTHX_ FILE *fp)
9753 {
9754     int res;
9755     if ((res = fflush(fp)) == 0 && fp) {
9756 #ifdef VMS_DO_SOCKETS
9757         Stat_t s;
9758         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9759 #endif
9760             res = fsync(fileno(fp));
9761     }
9762 /*
9763  * If the flush succeeded but set end-of-file, we need to clear
9764  * the error because our caller may check ferror().  BTW, this
9765  * probably means we just flushed an empty file.
9766  */
9767     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9768
9769     return res;
9770 }
9771 /*}}}*/
9772
9773 /*
9774  * Here are replacements for the following Unix routines in the VMS environment:
9775  *      getpwuid    Get information for a particular UIC or UID
9776  *      getpwnam    Get information for a named user
9777  *      getpwent    Get information for each user in the rights database
9778  *      setpwent    Reset search to the start of the rights database
9779  *      endpwent    Finish searching for users in the rights database
9780  *
9781  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9782  * (defined in pwd.h), which contains the following fields:-
9783  *      struct passwd {
9784  *              char        *pw_name;    Username (in lower case)
9785  *              char        *pw_passwd;  Hashed password
9786  *              unsigned int pw_uid;     UIC
9787  *              unsigned int pw_gid;     UIC group  number
9788  *              char        *pw_unixdir; Default device/directory (VMS-style)
9789  *              char        *pw_gecos;   Owner name
9790  *              char        *pw_dir;     Default device/directory (Unix-style)
9791  *              char        *pw_shell;   Default CLI name (eg. DCL)
9792  *      };
9793  * If the specified user does not exist, getpwuid and getpwnam return NULL.
9794  *
9795  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9796  * not the UIC member number (eg. what's returned by getuid()),
9797  * getpwuid() can accept either as input (if uid is specified, the caller's
9798  * UIC group is used), though it won't recognise gid=0.
9799  *
9800  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9801  * information about other users in your group or in other groups, respectively.
9802  * If the required privilege is not available, then these routines fill only
9803  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9804  * string).
9805  *
9806  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9807  */
9808
9809 /* sizes of various UAF record fields */
9810 #define UAI$S_USERNAME 12
9811 #define UAI$S_IDENT    31
9812 #define UAI$S_OWNER    31
9813 #define UAI$S_DEFDEV   31
9814 #define UAI$S_DEFDIR   63
9815 #define UAI$S_DEFCLI   31
9816 #define UAI$S_PWD       8
9817
9818 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
9819                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9820                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
9821
9822 static char __empty[]= "";
9823 static struct passwd __passwd_empty=
9824     {(char *) __empty, (char *) __empty, 0, 0,
9825      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9826 static int contxt= 0;
9827 static struct passwd __pwdcache;
9828 static char __pw_namecache[UAI$S_IDENT+1];
9829
9830 /*
9831  * This routine does most of the work extracting the user information.
9832  */
9833 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9834 {
9835     static struct {
9836         unsigned char length;
9837         char pw_gecos[UAI$S_OWNER+1];
9838     } owner;
9839     static union uicdef uic;
9840     static struct {
9841         unsigned char length;
9842         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9843     } defdev;
9844     static struct {
9845         unsigned char length;
9846         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9847     } defdir;
9848     static struct {
9849         unsigned char length;
9850         char pw_shell[UAI$S_DEFCLI+1];
9851     } defcli;
9852     static char pw_passwd[UAI$S_PWD+1];
9853
9854     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9855     struct dsc$descriptor_s name_desc;
9856     unsigned long int sts;
9857
9858     static struct itmlst_3 itmlst[]= {
9859         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
9860         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
9861         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
9862         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
9863         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
9864         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
9865         {0,                0,           NULL,    NULL}};
9866
9867     name_desc.dsc$w_length=  strlen(name);
9868     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9869     name_desc.dsc$b_class=   DSC$K_CLASS_S;
9870     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9871
9872 /*  Note that sys$getuai returns many fields as counted strings. */
9873     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9874     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9875       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9876     }
9877     else { _ckvmssts(sts); }
9878     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
9879
9880     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
9881     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9882     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9883     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9884     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9885     owner.pw_gecos[lowner]=            '\0';
9886     defdev.pw_dir[ldefdev+ldefdir]= '\0';
9887     defcli.pw_shell[ldefcli]=          '\0';
9888     if (valid_uic(uic)) {
9889         pwd->pw_uid= uic.uic$l_uic;
9890         pwd->pw_gid= uic.uic$v_group;
9891     }
9892     else
9893       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9894     pwd->pw_passwd=  pw_passwd;
9895     pwd->pw_gecos=   owner.pw_gecos;
9896     pwd->pw_dir=     defdev.pw_dir;
9897     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9898     pwd->pw_shell=   defcli.pw_shell;
9899     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9900         int ldir;
9901         ldir= strlen(pwd->pw_unixdir) - 1;
9902         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9903     }
9904     else
9905         strcpy(pwd->pw_unixdir, pwd->pw_dir);
9906     if (!decc_efs_case_preserve)
9907         __mystrtolower(pwd->pw_unixdir);
9908     return 1;
9909 }
9910
9911 /*
9912  * Get information for a named user.
9913 */
9914 /*{{{struct passwd *getpwnam(char *name)*/
9915 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9916 {
9917     struct dsc$descriptor_s name_desc;
9918     union uicdef uic;
9919     unsigned long int status, sts;
9920
9921     __pwdcache = __passwd_empty;
9922     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9923       /* We still may be able to determine pw_uid and pw_gid */
9924       name_desc.dsc$w_length=  strlen(name);
9925       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9926       name_desc.dsc$b_class=   DSC$K_CLASS_S;
9927       name_desc.dsc$a_pointer= (char *) name;
9928       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9929         __pwdcache.pw_uid= uic.uic$l_uic;
9930         __pwdcache.pw_gid= uic.uic$v_group;
9931       }
9932       else {
9933         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9934           set_vaxc_errno(sts);
9935           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9936           return NULL;
9937         }
9938         else { _ckvmssts(sts); }
9939       }
9940     }
9941     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9942     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9943     __pwdcache.pw_name= __pw_namecache;
9944     return &__pwdcache;
9945 }  /* end of my_getpwnam() */
9946 /*}}}*/
9947
9948 /*
9949  * Get information for a particular UIC or UID.
9950  * Called by my_getpwent with uid=-1 to list all users.
9951 */
9952 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9953 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9954 {
9955     const $DESCRIPTOR(name_desc,__pw_namecache);
9956     unsigned short lname;
9957     union uicdef uic;
9958     unsigned long int status;
9959
9960     if (uid == (unsigned int) -1) {
9961       do {
9962         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9963         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9964           set_vaxc_errno(status);
9965           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9966           my_endpwent();
9967           return NULL;
9968         }
9969         else { _ckvmssts(status); }
9970       } while (!valid_uic (uic));
9971     }
9972     else {
9973       uic.uic$l_uic= uid;
9974       if (!uic.uic$v_group)
9975         uic.uic$v_group= PerlProc_getgid();
9976       if (valid_uic(uic))
9977         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9978       else status = SS$_IVIDENT;
9979       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9980           status == RMS$_PRV) {
9981         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9982         return NULL;
9983       }
9984       else { _ckvmssts(status); }
9985     }
9986     __pw_namecache[lname]= '\0';
9987     __mystrtolower(__pw_namecache);
9988
9989     __pwdcache = __passwd_empty;
9990     __pwdcache.pw_name = __pw_namecache;
9991
9992 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9993     The identifier's value is usually the UIC, but it doesn't have to be,
9994     so if we can, we let fillpasswd update this. */
9995     __pwdcache.pw_uid =  uic.uic$l_uic;
9996     __pwdcache.pw_gid =  uic.uic$v_group;
9997
9998     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9999     return &__pwdcache;
10000
10001 }  /* end of my_getpwuid() */
10002 /*}}}*/
10003
10004 /*
10005  * Get information for next user.
10006 */
10007 /*{{{struct passwd *my_getpwent()*/
10008 struct passwd *Perl_my_getpwent(pTHX)
10009 {
10010     return (my_getpwuid((unsigned int) -1));
10011 }
10012 /*}}}*/
10013
10014 /*
10015  * Finish searching rights database for users.
10016 */
10017 /*{{{void my_endpwent()*/
10018 void Perl_my_endpwent(pTHX)
10019 {
10020     if (contxt) {
10021       _ckvmssts(sys$finish_rdb(&contxt));
10022       contxt= 0;
10023     }
10024 }
10025 /*}}}*/
10026
10027 #ifdef HOMEGROWN_POSIX_SIGNALS
10028   /* Signal handling routines, pulled into the core from POSIX.xs.
10029    *
10030    * We need these for threads, so they've been rolled into the core,
10031    * rather than left in POSIX.xs.
10032    *
10033    * (DRS, Oct 23, 1997)
10034    */
10035
10036   /* sigset_t is atomic under VMS, so these routines are easy */
10037 /*{{{int my_sigemptyset(sigset_t *) */
10038 int my_sigemptyset(sigset_t *set) {
10039     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10040     *set = 0; return 0;
10041 }
10042 /*}}}*/
10043
10044
10045 /*{{{int my_sigfillset(sigset_t *)*/
10046 int my_sigfillset(sigset_t *set) {
10047     int i;
10048     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10049     for (i = 0; i < NSIG; i++) *set |= (1 << i);
10050     return 0;
10051 }
10052 /*}}}*/
10053
10054
10055 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10056 int my_sigaddset(sigset_t *set, int sig) {
10057     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10058     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10059     *set |= (1 << (sig - 1));
10060     return 0;
10061 }
10062 /*}}}*/
10063
10064
10065 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10066 int my_sigdelset(sigset_t *set, int sig) {
10067     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10068     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10069     *set &= ~(1 << (sig - 1));
10070     return 0;
10071 }
10072 /*}}}*/
10073
10074
10075 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10076 int my_sigismember(sigset_t *set, int sig) {
10077     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10078     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10079     return *set & (1 << (sig - 1));
10080 }
10081 /*}}}*/
10082
10083
10084 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10085 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10086     sigset_t tempmask;
10087
10088     /* If set and oset are both null, then things are badly wrong. Bail out. */
10089     if ((oset == NULL) && (set == NULL)) {
10090       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10091       return -1;
10092     }
10093
10094     /* If set's null, then we're just handling a fetch. */
10095     if (set == NULL) {
10096         tempmask = sigblock(0);
10097     }
10098     else {
10099       switch (how) {
10100       case SIG_SETMASK:
10101         tempmask = sigsetmask(*set);
10102         break;
10103       case SIG_BLOCK:
10104         tempmask = sigblock(*set);
10105         break;
10106       case SIG_UNBLOCK:
10107         tempmask = sigblock(0);
10108         sigsetmask(*oset & ~tempmask);
10109         break;
10110       default:
10111         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10112         return -1;
10113       }
10114     }
10115
10116     /* Did they pass us an oset? If so, stick our holding mask into it */
10117     if (oset)
10118       *oset = tempmask;
10119
10120     return 0;
10121 }
10122 /*}}}*/
10123 #endif  /* HOMEGROWN_POSIX_SIGNALS */
10124
10125
10126 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10127  * my_utime(), and flex_stat(), all of which operate on UTC unless
10128  * VMSISH_TIMES is true.
10129  */
10130 /* method used to handle UTC conversions:
10131  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
10132  */
10133 static int gmtime_emulation_type;
10134 /* number of secs to add to UTC POSIX-style time to get local time */
10135 static long int utc_offset_secs;
10136
10137 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10138  * in vmsish.h.  #undef them here so we can call the CRTL routines
10139  * directly.
10140  */
10141 #undef gmtime
10142 #undef localtime
10143 #undef time
10144
10145
10146 /*
10147  * DEC C previous to 6.0 corrupts the behavior of the /prefix
10148  * qualifier with the extern prefix pragma.  This provisional
10149  * hack circumvents this prefix pragma problem in previous
10150  * precompilers.
10151  */
10152 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10153 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10154 #    pragma __extern_prefix save
10155 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
10156 #    define gmtime decc$__utctz_gmtime
10157 #    define localtime decc$__utctz_localtime
10158 #    define time decc$__utc_time
10159 #    pragma __extern_prefix restore
10160
10161      struct tm *gmtime(), *localtime();
10162
10163 #  endif
10164 #endif
10165
10166
10167 static time_t toutc_dst(time_t loc) {
10168   struct tm *rsltmp;
10169
10170   if ((rsltmp = localtime(&loc)) == NULL) return -1;
10171   loc -= utc_offset_secs;
10172   if (rsltmp->tm_isdst) loc -= 3600;
10173   return loc;
10174 }
10175 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10176        ((gmtime_emulation_type || my_time(NULL)), \
10177        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10178        ((secs) - utc_offset_secs))))
10179
10180 static time_t toloc_dst(time_t utc) {
10181   struct tm *rsltmp;
10182
10183   utc += utc_offset_secs;
10184   if ((rsltmp = localtime(&utc)) == NULL) return -1;
10185   if (rsltmp->tm_isdst) utc += 3600;
10186   return utc;
10187 }
10188 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10189        ((gmtime_emulation_type || my_time(NULL)), \
10190        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10191        ((secs) + utc_offset_secs))))
10192
10193 #ifndef RTL_USES_UTC
10194 /*
10195
10196     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
10197         DST starts on 1st sun of april      at 02:00  std time
10198             ends on last sun of october     at 02:00  dst time
10199     see the UCX management command reference, SET CONFIG TIMEZONE
10200     for formatting info.
10201
10202     No, it's not as general as it should be, but then again, NOTHING
10203     will handle UK times in a sensible way.
10204 */
10205
10206
10207 /*
10208     parse the DST start/end info:
10209     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10210 */
10211
10212 static char *
10213 tz_parse_startend(char *s, struct tm *w, int *past)
10214 {
10215     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10216     int ly, dozjd, d, m, n, hour, min, sec, j, k;
10217     time_t g;
10218
10219     if (!s)    return 0;
10220     if (!w) return 0;
10221     if (!past) return 0;
10222
10223     ly = 0;
10224     if (w->tm_year % 4        == 0) ly = 1;
10225     if (w->tm_year % 100      == 0) ly = 0;
10226     if (w->tm_year+1900 % 400 == 0) ly = 1;
10227     if (ly) dinm[1]++;
10228
10229     dozjd = isdigit(*s);
10230     if (*s == 'J' || *s == 'j' || dozjd) {
10231         if (!dozjd && !isdigit(*++s)) return 0;
10232         d = *s++ - '0';
10233         if (isdigit(*s)) {
10234             d = d*10 + *s++ - '0';
10235             if (isdigit(*s)) {
10236                 d = d*10 + *s++ - '0';
10237             }
10238         }
10239         if (d == 0) return 0;
10240         if (d > 366) return 0;
10241         d--;
10242         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
10243         g = d * 86400;
10244         dozjd = 1;
10245     } else if (*s == 'M' || *s == 'm') {
10246         if (!isdigit(*++s)) return 0;
10247         m = *s++ - '0';
10248         if (isdigit(*s)) m = 10*m + *s++ - '0';
10249         if (*s != '.') return 0;
10250         if (!isdigit(*++s)) return 0;
10251         n = *s++ - '0';
10252         if (n < 1 || n > 5) return 0;
10253         if (*s != '.') return 0;
10254         if (!isdigit(*++s)) return 0;
10255         d = *s++ - '0';
10256         if (d > 6) return 0;
10257     }
10258
10259     if (*s == '/') {
10260         if (!isdigit(*++s)) return 0;
10261         hour = *s++ - '0';
10262         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10263         if (*s == ':') {
10264             if (!isdigit(*++s)) return 0;
10265             min = *s++ - '0';
10266             if (isdigit(*s)) min = 10*min + *s++ - '0';
10267             if (*s == ':') {
10268                 if (!isdigit(*++s)) return 0;
10269                 sec = *s++ - '0';
10270                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10271             }
10272         }
10273     } else {
10274         hour = 2;
10275         min = 0;
10276         sec = 0;
10277     }
10278
10279     if (dozjd) {
10280         if (w->tm_yday < d) goto before;
10281         if (w->tm_yday > d) goto after;
10282     } else {
10283         if (w->tm_mon+1 < m) goto before;
10284         if (w->tm_mon+1 > m) goto after;
10285
10286         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
10287         k = d - j; /* mday of first d */
10288         if (k <= 0) k += 7;
10289         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
10290         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10291         if (w->tm_mday < k) goto before;
10292         if (w->tm_mday > k) goto after;
10293     }
10294
10295     if (w->tm_hour < hour) goto before;
10296     if (w->tm_hour > hour) goto after;
10297     if (w->tm_min  < min)  goto before;
10298     if (w->tm_min  > min)  goto after;
10299     if (w->tm_sec  < sec)  goto before;
10300     goto after;
10301
10302 before:
10303     *past = 0;
10304     return s;
10305 after:
10306     *past = 1;
10307     return s;
10308 }
10309
10310
10311
10312
10313 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
10314
10315 static char *
10316 tz_parse_offset(char *s, int *offset)
10317 {
10318     int hour = 0, min = 0, sec = 0;
10319     int neg = 0;
10320     if (!s) return 0;
10321     if (!offset) return 0;
10322
10323     if (*s == '-') {neg++; s++;}
10324     if (*s == '+') s++;
10325     if (!isdigit(*s)) return 0;
10326     hour = *s++ - '0';
10327     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10328     if (hour > 24) return 0;
10329     if (*s == ':') {
10330         if (!isdigit(*++s)) return 0;
10331         min = *s++ - '0';
10332         if (isdigit(*s)) min = min*10 + (*s++ - '0');
10333         if (min > 59) return 0;
10334         if (*s == ':') {
10335             if (!isdigit(*++s)) return 0;
10336             sec = *s++ - '0';
10337             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10338             if (sec > 59) return 0;
10339         }
10340     }
10341
10342     *offset = (hour*60+min)*60 + sec;
10343     if (neg) *offset = -*offset;
10344     return s;
10345 }
10346
10347 /*
10348     input time is w, whatever type of time the CRTL localtime() uses.
10349     sets dst, the zone, and the gmtoff (seconds)
10350
10351     caches the value of TZ and UCX$TZ env variables; note that
10352     my_setenv looks for these and sets a flag if they're changed
10353     for efficiency.
10354
10355     We have to watch out for the "australian" case (dst starts in
10356     october, ends in april)...flagged by "reverse" and checked by
10357     scanning through the months of the previous year.
10358
10359 */
10360
10361 static int
10362 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10363 {
10364     time_t when;
10365     struct tm *w2;
10366     char *s,*s2;
10367     char *dstzone, *tz, *s_start, *s_end;
10368     int std_off, dst_off, isdst;
10369     int y, dststart, dstend;
10370     static char envtz[1025];  /* longer than any logical, symbol, ... */
10371     static char ucxtz[1025];
10372     static char reversed = 0;
10373
10374     if (!w) return 0;
10375
10376     if (tz_updated) {
10377         tz_updated = 0;
10378         reversed = -1;  /* flag need to check  */
10379         envtz[0] = ucxtz[0] = '\0';
10380         tz = my_getenv("TZ",0);
10381         if (tz) strcpy(envtz, tz);
10382         tz = my_getenv("UCX$TZ",0);
10383         if (tz) strcpy(ucxtz, tz);
10384         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
10385     }
10386     tz = envtz;
10387     if (!*tz) tz = ucxtz;
10388
10389     s = tz;
10390     while (isalpha(*s)) s++;
10391     s = tz_parse_offset(s, &std_off);
10392     if (!s) return 0;
10393     if (!*s) {                  /* no DST, hurray we're done! */
10394         isdst = 0;
10395         goto done;
10396     }
10397
10398     dstzone = s;
10399     while (isalpha(*s)) s++;
10400     s2 = tz_parse_offset(s, &dst_off);
10401     if (s2) {
10402         s = s2;
10403     } else {
10404         dst_off = std_off - 3600;
10405     }
10406
10407     if (!*s) {      /* default dst start/end?? */
10408         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
10409             s = strchr(ucxtz,',');
10410         }
10411         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
10412     }
10413     if (*s != ',') return 0;
10414
10415     when = *w;
10416     when = _toutc(when);      /* convert to utc */
10417     when = when - std_off;    /* convert to pseudolocal time*/
10418
10419     w2 = localtime(&when);
10420     y = w2->tm_year;
10421     s_start = s+1;
10422     s = tz_parse_startend(s_start,w2,&dststart);
10423     if (!s) return 0;
10424     if (*s != ',') return 0;
10425
10426     when = *w;
10427     when = _toutc(when);      /* convert to utc */
10428     when = when - dst_off;    /* convert to pseudolocal time*/
10429     w2 = localtime(&when);
10430     if (w2->tm_year != y) {   /* spans a year, just check one time */
10431         when += dst_off - std_off;
10432         w2 = localtime(&when);
10433     }
10434     s_end = s+1;
10435     s = tz_parse_startend(s_end,w2,&dstend);
10436     if (!s) return 0;
10437
10438     if (reversed == -1) {  /* need to check if start later than end */
10439         int j, ds, de;
10440
10441         when = *w;
10442         if (when < 2*365*86400) {
10443             when += 2*365*86400;
10444         } else {
10445             when -= 365*86400;
10446         }
10447         w2 =localtime(&when);
10448         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
10449
10450         for (j = 0; j < 12; j++) {
10451             w2 =localtime(&when);
10452             tz_parse_startend(s_start,w2,&ds);
10453             tz_parse_startend(s_end,w2,&de);
10454             if (ds != de) break;
10455             when += 30*86400;
10456         }
10457         reversed = 0;
10458         if (de && !ds) reversed = 1;
10459     }
10460
10461     isdst = dststart && !dstend;
10462     if (reversed) isdst = dststart  || !dstend;
10463
10464 done:
10465     if (dst)    *dst = isdst;
10466     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10467     if (isdst)  tz = dstzone;
10468     if (zone) {
10469         while(isalpha(*tz))  *zone++ = *tz++;
10470         *zone = '\0';
10471     }
10472     return 1;
10473 }
10474
10475 #endif /* !RTL_USES_UTC */
10476
10477 /* my_time(), my_localtime(), my_gmtime()
10478  * By default traffic in UTC time values, using CRTL gmtime() or
10479  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10480  * Note: We need to use these functions even when the CRTL has working
10481  * UTC support, since they also handle C<use vmsish qw(times);>
10482  *
10483  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
10484  * Modified by Charles Bailey <bailey@newman.upenn.edu>
10485  */
10486
10487 /*{{{time_t my_time(time_t *timep)*/
10488 time_t Perl_my_time(pTHX_ time_t *timep)
10489 {
10490   time_t when;
10491   struct tm *tm_p;
10492
10493   if (gmtime_emulation_type == 0) {
10494     int dstnow;
10495     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
10496                               /* results of calls to gmtime() and localtime() */
10497                               /* for same &base */
10498
10499     gmtime_emulation_type++;
10500     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10501       char off[LNM$C_NAMLENGTH+1];;
10502
10503       gmtime_emulation_type++;
10504       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10505         gmtime_emulation_type++;
10506         utc_offset_secs = 0;
10507         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10508       }
10509       else { utc_offset_secs = atol(off); }
10510     }
10511     else { /* We've got a working gmtime() */
10512       struct tm gmt, local;
10513
10514       gmt = *tm_p;
10515       tm_p = localtime(&base);
10516       local = *tm_p;
10517       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
10518       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10519       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
10520       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
10521     }
10522   }
10523
10524   when = time(NULL);
10525 # ifdef VMSISH_TIME
10526 # ifdef RTL_USES_UTC
10527   if (VMSISH_TIME) when = _toloc(when);
10528 # else
10529   if (!VMSISH_TIME) when = _toutc(when);
10530 # endif
10531 # endif
10532   if (timep != NULL) *timep = when;
10533   return when;
10534
10535 }  /* end of my_time() */
10536 /*}}}*/
10537
10538
10539 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10540 struct tm *
10541 Perl_my_gmtime(pTHX_ const time_t *timep)
10542 {
10543   char *p;
10544   time_t when;
10545   struct tm *rsltmp;
10546
10547   if (timep == NULL) {
10548     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10549     return NULL;
10550   }
10551   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10552
10553   when = *timep;
10554 # ifdef VMSISH_TIME
10555   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10556 #  endif
10557 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
10558   return gmtime(&when);
10559 # else
10560   /* CRTL localtime() wants local time as input, so does no tz correction */
10561   rsltmp = localtime(&when);
10562   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
10563   return rsltmp;
10564 #endif
10565 }  /* end of my_gmtime() */
10566 /*}}}*/
10567
10568
10569 /*{{{struct tm *my_localtime(const time_t *timep)*/
10570 struct tm *
10571 Perl_my_localtime(pTHX_ const time_t *timep)
10572 {
10573   time_t when, whenutc;
10574   struct tm *rsltmp;
10575   int dst, offset;
10576
10577   if (timep == NULL) {
10578     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10579     return NULL;
10580   }
10581   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10582   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10583
10584   when = *timep;
10585 # ifdef RTL_USES_UTC
10586 # ifdef VMSISH_TIME
10587   if (VMSISH_TIME) when = _toutc(when);
10588 # endif
10589   /* CRTL localtime() wants UTC as input, does tz correction itself */
10590   return localtime(&when);
10591
10592 # else /* !RTL_USES_UTC */
10593   whenutc = when;
10594 # ifdef VMSISH_TIME
10595   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
10596   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
10597 # endif
10598   dst = -1;
10599 #ifndef RTL_USES_UTC
10600   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
10601       when = whenutc - offset;                   /* pseudolocal time*/
10602   }
10603 # endif
10604   /* CRTL localtime() wants local time as input, so does no tz correction */
10605   rsltmp = localtime(&when);
10606   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10607   return rsltmp;
10608 # endif
10609
10610 } /*  end of my_localtime() */
10611 /*}}}*/
10612
10613 /* Reset definitions for later calls */
10614 #define gmtime(t)    my_gmtime(t)
10615 #define localtime(t) my_localtime(t)
10616 #define time(t)      my_time(t)
10617
10618
10619 /* my_utime - update modification/access time of a file
10620  *
10621  * VMS 7.3 and later implementation
10622  * Only the UTC translation is home-grown. The rest is handled by the
10623  * CRTL utime(), which will take into account the relevant feature
10624  * logicals and ODS-5 volume characteristics for true access times.
10625  *
10626  * pre VMS 7.3 implementation:
10627  * The calling sequence is identical to POSIX utime(), but under
10628  * VMS with ODS-2, only the modification time is changed; ODS-2 does
10629  * not maintain access times.  Restrictions differ from the POSIX
10630  * definition in that the time can be changed as long as the
10631  * caller has permission to execute the necessary IO$_MODIFY $QIO;
10632  * no separate checks are made to insure that the caller is the
10633  * owner of the file or has special privs enabled.
10634  * Code here is based on Joe Meadows' FILE utility.
10635  *
10636  */
10637
10638 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10639  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
10640  * in 100 ns intervals.
10641  */
10642 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10643
10644 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10645 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10646 {
10647 #if __CRTL_VER >= 70300000
10648   struct utimbuf utc_utimes, *utc_utimesp;
10649
10650   if (utimes != NULL) {
10651     utc_utimes.actime = utimes->actime;
10652     utc_utimes.modtime = utimes->modtime;
10653 # ifdef VMSISH_TIME
10654     /* If input was local; convert to UTC for sys svc */
10655     if (VMSISH_TIME) {
10656       utc_utimes.actime = _toutc(utimes->actime);
10657       utc_utimes.modtime = _toutc(utimes->modtime);
10658     }
10659 # endif
10660     utc_utimesp = &utc_utimes;
10661   }
10662   else {
10663     utc_utimesp = NULL;
10664   }
10665
10666   return utime(file, utc_utimesp);
10667
10668 #else /* __CRTL_VER < 70300000 */
10669
10670   register int i;
10671   int sts;
10672   long int bintime[2], len = 2, lowbit, unixtime,
10673            secscale = 10000000; /* seconds --> 100 ns intervals */
10674   unsigned long int chan, iosb[2], retsts;
10675   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10676   struct FAB myfab = cc$rms_fab;
10677   struct NAM mynam = cc$rms_nam;
10678 #if defined (__DECC) && defined (__VAX)
10679   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10680    * at least through VMS V6.1, which causes a type-conversion warning.
10681    */
10682 #  pragma message save
10683 #  pragma message disable cvtdiftypes
10684 #endif
10685   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10686   struct fibdef myfib;
10687 #if defined (__DECC) && defined (__VAX)
10688   /* This should be right after the declaration of myatr, but due
10689    * to a bug in VAX DEC C, this takes effect a statement early.
10690    */
10691 #  pragma message restore
10692 #endif
10693   /* cast ok for read only parameter */
10694   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10695                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10696                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10697
10698   if (file == NULL || *file == '\0') {
10699     SETERRNO(ENOENT, LIB$_INVARG);
10700     return -1;
10701   }
10702
10703   /* Convert to VMS format ensuring that it will fit in 255 characters */
10704   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10705       SETERRNO(ENOENT, LIB$_INVARG);
10706       return -1;
10707   }
10708   if (utimes != NULL) {
10709     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
10710      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10711      * Since time_t is unsigned long int, and lib$emul takes a signed long int
10712      * as input, we force the sign bit to be clear by shifting unixtime right
10713      * one bit, then multiplying by an extra factor of 2 in lib$emul().
10714      */
10715     lowbit = (utimes->modtime & 1) ? secscale : 0;
10716     unixtime = (long int) utimes->modtime;
10717 #   ifdef VMSISH_TIME
10718     /* If input was UTC; convert to local for sys svc */
10719     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10720 #   endif
10721     unixtime >>= 1;  secscale <<= 1;
10722     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10723     if (!(retsts & 1)) {
10724       SETERRNO(EVMSERR, retsts);
10725       return -1;
10726     }
10727     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10728     if (!(retsts & 1)) {
10729       SETERRNO(EVMSERR, retsts);
10730       return -1;
10731     }
10732   }
10733   else {
10734     /* Just get the current time in VMS format directly */
10735     retsts = sys$gettim(bintime);
10736     if (!(retsts & 1)) {
10737       SETERRNO(EVMSERR, retsts);
10738       return -1;
10739     }
10740   }
10741
10742   myfab.fab$l_fna = vmsspec;
10743   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10744   myfab.fab$l_nam = &mynam;
10745   mynam.nam$l_esa = esa;
10746   mynam.nam$b_ess = (unsigned char) sizeof esa;
10747   mynam.nam$l_rsa = rsa;
10748   mynam.nam$b_rss = (unsigned char) sizeof rsa;
10749   if (decc_efs_case_preserve)
10750       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10751
10752   /* Look for the file to be affected, letting RMS parse the file
10753    * specification for us as well.  I have set errno using only
10754    * values documented in the utime() man page for VMS POSIX.
10755    */
10756   retsts = sys$parse(&myfab,0,0);
10757   if (!(retsts & 1)) {
10758     set_vaxc_errno(retsts);
10759     if      (retsts == RMS$_PRV) set_errno(EACCES);
10760     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10761     else                         set_errno(EVMSERR);
10762     return -1;
10763   }
10764   retsts = sys$search(&myfab,0,0);
10765   if (!(retsts & 1)) {
10766     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10767     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10768     set_vaxc_errno(retsts);
10769     if      (retsts == RMS$_PRV) set_errno(EACCES);
10770     else if (retsts == RMS$_FNF) set_errno(ENOENT);
10771     else                         set_errno(EVMSERR);
10772     return -1;
10773   }
10774
10775   devdsc.dsc$w_length = mynam.nam$b_dev;
10776   /* cast ok for read only parameter */
10777   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10778
10779   retsts = sys$assign(&devdsc,&chan,0,0);
10780   if (!(retsts & 1)) {
10781     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10782     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10783     set_vaxc_errno(retsts);
10784     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
10785     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
10786     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
10787     else                               set_errno(EVMSERR);
10788     return -1;
10789   }
10790
10791   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10792   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10793
10794   memset((void *) &myfib, 0, sizeof myfib);
10795 #if defined(__DECC) || defined(__DECCXX)
10796   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10797   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10798   /* This prevents the revision time of the file being reset to the current
10799    * time as a result of our IO$_MODIFY $QIO. */
10800   myfib.fib$l_acctl = FIB$M_NORECORD;
10801 #else
10802   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10803   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10804   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10805 #endif
10806   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10807   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10808   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10809   _ckvmssts(sys$dassgn(chan));
10810   if (retsts & 1) retsts = iosb[0];
10811   if (!(retsts & 1)) {
10812     set_vaxc_errno(retsts);
10813     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10814     else                      set_errno(EVMSERR);
10815     return -1;
10816   }
10817
10818   return 0;
10819
10820 #endif /* #if __CRTL_VER >= 70300000 */
10821
10822 }  /* end of my_utime() */
10823 /*}}}*/
10824
10825 /*
10826  * flex_stat, flex_lstat, flex_fstat
10827  * basic stat, but gets it right when asked to stat
10828  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10829  */
10830
10831 #ifndef _USE_STD_STAT
10832 /* encode_dev packs a VMS device name string into an integer to allow
10833  * simple comparisons. This can be used, for example, to check whether two
10834  * files are located on the same device, by comparing their encoded device
10835  * names. Even a string comparison would not do, because stat() reuses the
10836  * device name buffer for each call; so without encode_dev, it would be
10837  * necessary to save the buffer and use strcmp (this would mean a number of
10838  * changes to the standard Perl code, to say nothing of what a Perl script
10839  * would have to do.
10840  *
10841  * The device lock id, if it exists, should be unique (unless perhaps compared
10842  * with lock ids transferred from other nodes). We have a lock id if the disk is
10843  * mounted cluster-wide, which is when we tend to get long (host-qualified)
10844  * device names. Thus we use the lock id in preference, and only if that isn't
10845  * available, do we try to pack the device name into an integer (flagged by
10846  * the sign bit (LOCKID_MASK) being set).
10847  *
10848  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10849  * name and its encoded form, but it seems very unlikely that we will find
10850  * two files on different disks that share the same encoded device names,
10851  * and even more remote that they will share the same file id (if the test
10852  * is to check for the same file).
10853  *
10854  * A better method might be to use sys$device_scan on the first call, and to
10855  * search for the device, returning an index into the cached array.
10856  * The number returned would be more intelligible.
10857  * This is probably not worth it, and anyway would take quite a bit longer
10858  * on the first call.
10859  */
10860 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
10861 static mydev_t encode_dev (pTHX_ const char *dev)
10862 {
10863   int i;
10864   unsigned long int f;
10865   mydev_t enc;
10866   char c;
10867   const char *q;
10868
10869   if (!dev || !dev[0]) return 0;
10870
10871 #if LOCKID_MASK
10872   {
10873     struct dsc$descriptor_s dev_desc;
10874     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10875
10876     /* For cluster-mounted disks, the disk lock identifier is unique, so we
10877        can try that first. */
10878     dev_desc.dsc$w_length =  strlen (dev);
10879     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
10880     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
10881     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
10882     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10883     if (!$VMS_STATUS_SUCCESS(status)) {
10884       switch (status) {
10885         case SS$_NOSUCHDEV:
10886           SETERRNO(ENODEV, status);
10887           return 0;
10888         default:
10889           _ckvmssts(status);
10890       }
10891     }
10892     if (lockid) return (lockid & ~LOCKID_MASK);
10893   }
10894 #endif
10895
10896   /* Otherwise we try to encode the device name */
10897   enc = 0;
10898   f = 1;
10899   i = 0;
10900   for (q = dev + strlen(dev); q--; q >= dev) {
10901     if (*q == ':')
10902         break;
10903     if (isdigit (*q))
10904       c= (*q) - '0';
10905     else if (isalpha (toupper (*q)))
10906       c= toupper (*q) - 'A' + (char)10;
10907     else
10908       continue; /* Skip '$'s */
10909     i++;
10910     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
10911     if (i>1) f *= 36;
10912     enc += f * (unsigned long int) c;
10913   }
10914   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
10915
10916 }  /* end of encode_dev() */
10917 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10918         device_no = encode_dev(aTHX_ devname)
10919 #else
10920 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10921         device_no = new_dev_no
10922 #endif
10923
10924 static int
10925 is_null_device(name)
10926     const char *name;
10927 {
10928   if (decc_bug_devnull != 0) {
10929     if (strncmp("/dev/null", name, 9) == 0)
10930       return 1;
10931   }
10932     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10933        The underscore prefix, controller letter, and unit number are
10934        independently optional; for our purposes, the colon punctuation
10935        is not.  The colon can be trailed by optional directory and/or
10936        filename, but two consecutive colons indicates a nodename rather
10937        than a device.  [pr]  */
10938   if (*name == '_') ++name;
10939   if (tolower(*name++) != 'n') return 0;
10940   if (tolower(*name++) != 'l') return 0;
10941   if (tolower(*name) == 'a') ++name;
10942   if (*name == '0') ++name;
10943   return (*name++ == ':') && (*name != ':');
10944 }
10945
10946
10947 static I32
10948 Perl_cando_by_name_int
10949    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10950 {
10951   char usrname[L_cuserid];
10952   struct dsc$descriptor_s usrdsc =
10953          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10954   char *vmsname = NULL, *fileified = NULL;
10955   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10956   unsigned short int retlen, trnlnm_iter_count;
10957   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10958   union prvdef curprv;
10959   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10960          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10961          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10962   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10963          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10964          {0,0,0,0}};
10965   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10966          {0,0,0,0}};
10967   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10968   Stat_t st;
10969   static int profile_context = -1;
10970
10971   if (!fname || !*fname) return FALSE;
10972
10973   /* Make sure we expand logical names, since sys$check_access doesn't */
10974   fileified = PerlMem_malloc(VMS_MAXRSS);
10975   if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
10976   if (!strpbrk(fname,"/]>:")) {
10977       strcpy(fileified,fname);
10978       trnlnm_iter_count = 0;
10979       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
10980         trnlnm_iter_count++;
10981         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10982       }
10983       fname = fileified;
10984   }
10985
10986   vmsname = PerlMem_malloc(VMS_MAXRSS);
10987   if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
10988   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
10989     /* Don't know if already in VMS format, so make sure */
10990     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10991       PerlMem_free(fileified);
10992       PerlMem_free(vmsname);
10993       return FALSE;
10994     }
10995   }
10996   else {
10997     strcpy(vmsname,fname);
10998   }
10999
11000   /* sys$check_access needs a file spec, not a directory spec.
11001    * Don't use flex_stat here, as that depends on thread context
11002    * having been initialized, and we may get here during startup.
11003    */
11004
11005   retlen = namdsc.dsc$w_length = strlen(vmsname);
11006   if (vmsname[retlen-1] == ']'
11007       || vmsname[retlen-1] == '>'
11008       || vmsname[retlen-1] == ':'
11009       || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11010
11011       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11012         PerlMem_free(fileified);
11013         PerlMem_free(vmsname);
11014         return FALSE;
11015       }
11016       fname = fileified;
11017   }
11018   else {
11019       fname = vmsname;
11020   }
11021
11022   retlen = namdsc.dsc$w_length = strlen(fname);
11023   namdsc.dsc$a_pointer = (char *)fname;
11024
11025   switch (bit) {
11026     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11027       access = ARM$M_EXECUTE;
11028       flags = CHP$M_READ;
11029       break;
11030     case S_IRUSR: case S_IRGRP: case S_IROTH:
11031       access = ARM$M_READ;
11032       flags = CHP$M_READ | CHP$M_USEREADALL;
11033       break;
11034     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11035       access = ARM$M_WRITE;
11036       flags = CHP$M_READ | CHP$M_WRITE;
11037       break;
11038     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11039       access = ARM$M_DELETE;
11040       flags = CHP$M_READ | CHP$M_WRITE;
11041       break;
11042     default:
11043       if (fileified != NULL)
11044         PerlMem_free(fileified);
11045       if (vmsname != NULL)
11046         PerlMem_free(vmsname);
11047       return FALSE;
11048   }
11049
11050   /* Before we call $check_access, create a user profile with the current
11051    * process privs since otherwise it just uses the default privs from the
11052    * UAF and might give false positives or negatives.  This only works on
11053    * VMS versions v6.0 and later since that's when sys$create_user_profile
11054    * became available.
11055    */
11056
11057   /* get current process privs and username */
11058   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11059   _ckvmssts(iosb[0]);
11060
11061 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11062
11063   /* find out the space required for the profile */
11064   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11065                                     &usrprodsc.dsc$w_length,&profile_context));
11066
11067   /* allocate space for the profile and get it filled in */
11068   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11069   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11070   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11071                                     &usrprodsc.dsc$w_length,&profile_context));
11072
11073   /* use the profile to check access to the file; free profile & analyze results */
11074   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11075   PerlMem_free(usrprodsc.dsc$a_pointer);
11076   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11077
11078 #else
11079
11080   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11081
11082 #endif
11083
11084   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11085       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11086       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11087     set_vaxc_errno(retsts);
11088     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11089     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11090     else set_errno(ENOENT);
11091     if (fileified != NULL)
11092       PerlMem_free(fileified);
11093     if (vmsname != NULL)
11094       PerlMem_free(vmsname);
11095     return FALSE;
11096   }
11097   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11098     if (fileified != NULL)
11099       PerlMem_free(fileified);
11100     if (vmsname != NULL)
11101       PerlMem_free(vmsname);
11102     return TRUE;
11103   }
11104   _ckvmssts(retsts);
11105
11106   if (fileified != NULL)
11107     PerlMem_free(fileified);
11108   if (vmsname != NULL)
11109     PerlMem_free(vmsname);
11110   return FALSE;  /* Should never get here */
11111
11112 }
11113
11114 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
11115 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11116  * subset of the applicable information.
11117  */
11118 bool
11119 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11120 {
11121   return cando_by_name_int
11122         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11123 }  /* end of cando() */
11124 /*}}}*/
11125
11126
11127 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11128 I32
11129 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11130 {
11131    return cando_by_name_int(bit, effective, fname, 0);
11132
11133 }  /* end of cando_by_name() */
11134 /*}}}*/
11135
11136
11137 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11138 int
11139 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11140 {
11141   if (!fstat(fd,(stat_t *) statbufp)) {
11142     char *cptr;
11143     char *vms_filename;
11144     vms_filename = PerlMem_malloc(VMS_MAXRSS);
11145     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11146
11147     /* Save name for cando by name in VMS format */
11148     cptr = getname(fd, vms_filename, 1);
11149
11150     /* This should not happen, but just in case */
11151     if (cptr == NULL) {
11152         statbufp->st_devnam[0] = 0;
11153     }
11154     else {
11155         /* Make sure that the saved name fits in 255 characters */
11156         cptr = do_rmsexpand
11157                        (vms_filename,
11158                         statbufp->st_devnam,
11159                         0,
11160                         NULL,
11161                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11162                         NULL,
11163                         NULL);
11164         if (cptr == NULL)
11165             statbufp->st_devnam[0] = 0;
11166     }
11167     PerlMem_free(vms_filename);
11168
11169     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11170     VMS_DEVICE_ENCODE
11171         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11172
11173 #   ifdef RTL_USES_UTC
11174 #   ifdef VMSISH_TIME
11175     if (VMSISH_TIME) {
11176       statbufp->st_mtime = _toloc(statbufp->st_mtime);
11177       statbufp->st_atime = _toloc(statbufp->st_atime);
11178       statbufp->st_ctime = _toloc(statbufp->st_ctime);
11179     }
11180 #   endif
11181 #   else
11182 #   ifdef VMSISH_TIME
11183     if (!VMSISH_TIME) { /* Return UTC instead of local time */
11184 #   else
11185     if (1) {
11186 #   endif
11187       statbufp->st_mtime = _toutc(statbufp->st_mtime);
11188       statbufp->st_atime = _toutc(statbufp->st_atime);
11189       statbufp->st_ctime = _toutc(statbufp->st_ctime);
11190     }
11191 #endif
11192     return 0;
11193   }
11194   return -1;
11195
11196 }  /* end of flex_fstat() */
11197 /*}}}*/
11198
11199 #if !defined(__VAX) && __CRTL_VER >= 80200000
11200 #ifdef lstat
11201 #undef lstat
11202 #endif
11203 #else
11204 #ifdef lstat
11205 #undef lstat
11206 #endif
11207 #define lstat(_x, _y) stat(_x, _y)
11208 #endif
11209
11210 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11211
11212 static int
11213 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11214 {
11215     char fileified[VMS_MAXRSS];
11216     char temp_fspec[VMS_MAXRSS];
11217     char *save_spec;
11218     int retval = -1;
11219     int saved_errno, saved_vaxc_errno;
11220
11221     if (!fspec) return retval;
11222     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11223     strcpy(temp_fspec, fspec);
11224
11225     if (decc_bug_devnull != 0) {
11226       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11227         memset(statbufp,0,sizeof *statbufp);
11228         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11229         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11230         statbufp->st_uid = 0x00010001;
11231         statbufp->st_gid = 0x0001;
11232         time((time_t *)&statbufp->st_mtime);
11233         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11234         return 0;
11235       }
11236     }
11237
11238     /* Try for a directory name first.  If fspec contains a filename without
11239      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11240      * and sea:[wine.dark]water. exist, we prefer the directory here.
11241      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11242      * not sea:[wine.dark]., if the latter exists.  If the intended target is
11243      * the file with null type, specify this by calling flex_stat() with
11244      * a '.' at the end of fspec.
11245      *
11246      * If we are in Posix filespec mode, accept the filename as is.
11247      */
11248
11249
11250 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11251   /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11252    * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11253    */
11254   if (!decc_efs_charset)
11255     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11256 #endif
11257
11258 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11259   if (decc_posix_compliant_pathnames == 0) {
11260 #endif
11261     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11262       if (lstat_flag == 0)
11263         retval = stat(fileified,(stat_t *) statbufp);
11264       else
11265         retval = lstat(fileified,(stat_t *) statbufp);
11266       save_spec = fileified;
11267     }
11268     if (retval) {
11269       if (lstat_flag == 0)
11270         retval = stat(temp_fspec,(stat_t *) statbufp);
11271       else
11272         retval = lstat(temp_fspec,(stat_t *) statbufp);
11273       save_spec = temp_fspec;
11274     }
11275 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11276   } else {
11277     if (lstat_flag == 0)
11278       retval = stat(temp_fspec,(stat_t *) statbufp);
11279     else
11280       retval = lstat(temp_fspec,(stat_t *) statbufp);
11281       save_spec = temp_fspec;
11282   }
11283 #endif
11284
11285 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11286   /* As you were... */
11287   if (!decc_efs_charset)
11288     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11289 #endif
11290
11291     if (!retval) {
11292     char * cptr;
11293       cptr = do_rmsexpand
11294        (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
11295       if (cptr == NULL)
11296         statbufp->st_devnam[0] = 0;
11297
11298       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11299       VMS_DEVICE_ENCODE
11300         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11301 #     ifdef RTL_USES_UTC
11302 #     ifdef VMSISH_TIME
11303       if (VMSISH_TIME) {
11304         statbufp->st_mtime = _toloc(statbufp->st_mtime);
11305         statbufp->st_atime = _toloc(statbufp->st_atime);
11306         statbufp->st_ctime = _toloc(statbufp->st_ctime);
11307       }
11308 #     endif
11309 #     else
11310 #     ifdef VMSISH_TIME
11311       if (!VMSISH_TIME) { /* Return UTC instead of local time */
11312 #     else
11313       if (1) {
11314 #     endif
11315         statbufp->st_mtime = _toutc(statbufp->st_mtime);
11316         statbufp->st_atime = _toutc(statbufp->st_atime);
11317         statbufp->st_ctime = _toutc(statbufp->st_ctime);
11318       }
11319 #     endif
11320     }
11321     /* If we were successful, leave errno where we found it */
11322     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
11323     return retval;
11324
11325 }  /* end of flex_stat_int() */
11326
11327
11328 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
11329 int
11330 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
11331 {
11332    return flex_stat_int(fspec, statbufp, 0);
11333 }
11334 /*}}}*/
11335
11336 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
11337 int
11338 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
11339 {
11340    return flex_stat_int(fspec, statbufp, 1);
11341 }
11342 /*}}}*/
11343
11344
11345 /*{{{char *my_getlogin()*/
11346 /* VMS cuserid == Unix getlogin, except calling sequence */
11347 char *
11348 my_getlogin(void)
11349 {
11350     static char user[L_cuserid];
11351     return cuserid(user);
11352 }
11353 /*}}}*/
11354
11355
11356 /*  rmscopy - copy a file using VMS RMS routines
11357  *
11358  *  Copies contents and attributes of spec_in to spec_out, except owner
11359  *  and protection information.  Name and type of spec_in are used as
11360  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
11361  *  should try to propagate timestamps from the input file to the output file.
11362  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
11363  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
11364  *  propagated to the output file at creation iff the output file specification
11365  *  did not contain an explicit name or type, and the revision date is always
11366  *  updated at the end of the copy operation.  If it is greater than 0, then
11367  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11368  *  other than the revision date should be propagated, and bit 1 indicates
11369  *  that the revision date should be propagated.
11370  *
11371  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11372  *
11373  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11374  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
11375  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
11376  * as part of the Perl standard distribution under the terms of the
11377  * GNU General Public License or the Perl Artistic License.  Copies
11378  * of each may be found in the Perl standard distribution.
11379  */ /* FIXME */
11380 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11381 int
11382 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11383 {
11384     char *vmsin, * vmsout, *esa, *esa_out,
11385          *rsa, *ubf;
11386     unsigned long int i, sts, sts2;
11387     int dna_len;
11388     struct FAB fab_in, fab_out;
11389     struct RAB rab_in, rab_out;
11390     rms_setup_nam(nam);
11391     rms_setup_nam(nam_out);
11392     struct XABDAT xabdat;
11393     struct XABFHC xabfhc;
11394     struct XABRDT xabrdt;
11395     struct XABSUM xabsum;
11396
11397     vmsin = PerlMem_malloc(VMS_MAXRSS);
11398     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11399     vmsout = PerlMem_malloc(VMS_MAXRSS);
11400     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11401     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11402         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11403       PerlMem_free(vmsin);
11404       PerlMem_free(vmsout);
11405       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11406       return 0;
11407     }
11408
11409     esa = PerlMem_malloc(VMS_MAXRSS);
11410     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11411     fab_in = cc$rms_fab;
11412     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11413     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11414     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11415     fab_in.fab$l_fop = FAB$M_SQO;
11416     rms_bind_fab_nam(fab_in, nam);
11417     fab_in.fab$l_xab = (void *) &xabdat;
11418
11419     rsa = PerlMem_malloc(VMS_MAXRSS);
11420     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11421     rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11422     rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11423     rms_nam_esl(nam) = 0;
11424     rms_nam_rsl(nam) = 0;
11425     rms_nam_esll(nam) = 0;
11426     rms_nam_rsll(nam) = 0;
11427 #ifdef NAM$M_NO_SHORT_UPCASE
11428     if (decc_efs_case_preserve)
11429         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11430 #endif
11431
11432     xabdat = cc$rms_xabdat;        /* To get creation date */
11433     xabdat.xab$l_nxt = (void *) &xabfhc;
11434
11435     xabfhc = cc$rms_xabfhc;        /* To get record length */
11436     xabfhc.xab$l_nxt = (void *) &xabsum;
11437
11438     xabsum = cc$rms_xabsum;        /* To get key and area information */
11439
11440     if (!((sts = sys$open(&fab_in)) & 1)) {
11441       PerlMem_free(vmsin);
11442       PerlMem_free(vmsout);
11443       PerlMem_free(esa);
11444       PerlMem_free(rsa);
11445       set_vaxc_errno(sts);
11446       switch (sts) {
11447         case RMS$_FNF: case RMS$_DNF:
11448           set_errno(ENOENT); break;
11449         case RMS$_DIR:
11450           set_errno(ENOTDIR); break;
11451         case RMS$_DEV:
11452           set_errno(ENODEV); break;
11453         case RMS$_SYN:
11454           set_errno(EINVAL); break;
11455         case RMS$_PRV:
11456           set_errno(EACCES); break;
11457         default:
11458           set_errno(EVMSERR);
11459       }
11460       return 0;
11461     }
11462
11463     nam_out = nam;
11464     fab_out = fab_in;
11465     fab_out.fab$w_ifi = 0;
11466     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11467     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11468     fab_out.fab$l_fop = FAB$M_SQO;
11469     rms_bind_fab_nam(fab_out, nam_out);
11470     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11471     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11472     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11473     esa_out = PerlMem_malloc(VMS_MAXRSS);
11474     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11475     rms_set_rsa(nam_out, NULL, 0);
11476     rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11477
11478     if (preserve_dates == 0) {  /* Act like DCL COPY */
11479       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11480       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
11481       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11482         PerlMem_free(vmsin);
11483         PerlMem_free(vmsout);
11484         PerlMem_free(esa);
11485         PerlMem_free(rsa);
11486         PerlMem_free(esa_out);
11487         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11488         set_vaxc_errno(sts);
11489         return 0;
11490       }
11491       fab_out.fab$l_xab = (void *) &xabdat;
11492       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11493         preserve_dates = 1;
11494     }
11495     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
11496       preserve_dates =0;      /* bitmask from this point forward   */
11497
11498     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11499     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11500       PerlMem_free(vmsin);
11501       PerlMem_free(vmsout);
11502       PerlMem_free(esa);
11503       PerlMem_free(rsa);
11504       PerlMem_free(esa_out);
11505       set_vaxc_errno(sts);
11506       switch (sts) {
11507         case RMS$_DNF:
11508           set_errno(ENOENT); break;
11509         case RMS$_DIR:
11510           set_errno(ENOTDIR); break;
11511         case RMS$_DEV:
11512           set_errno(ENODEV); break;
11513         case RMS$_SYN:
11514           set_errno(EINVAL); break;
11515         case RMS$_PRV:
11516           set_errno(EACCES); break;
11517         default:
11518           set_errno(EVMSERR);
11519       }
11520       return 0;
11521     }
11522     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
11523     if (preserve_dates & 2) {
11524       /* sys$close() will process xabrdt, not xabdat */
11525       xabrdt = cc$rms_xabrdt;
11526 #ifndef __GNUC__
11527       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11528 #else
11529       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11530        * is unsigned long[2], while DECC & VAXC use a struct */
11531       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11532 #endif
11533       fab_out.fab$l_xab = (void *) &xabrdt;
11534     }
11535
11536     ubf = PerlMem_malloc(32256);
11537     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11538     rab_in = cc$rms_rab;
11539     rab_in.rab$l_fab = &fab_in;
11540     rab_in.rab$l_rop = RAB$M_BIO;
11541     rab_in.rab$l_ubf = ubf;
11542     rab_in.rab$w_usz = 32256;
11543     if (!((sts = sys$connect(&rab_in)) & 1)) {
11544       sys$close(&fab_in); sys$close(&fab_out);
11545       PerlMem_free(vmsin);
11546       PerlMem_free(vmsout);
11547       PerlMem_free(esa);
11548       PerlMem_free(ubf);
11549       PerlMem_free(rsa);
11550       PerlMem_free(esa_out);
11551       set_errno(EVMSERR); set_vaxc_errno(sts);
11552       return 0;
11553     }
11554
11555     rab_out = cc$rms_rab;
11556     rab_out.rab$l_fab = &fab_out;
11557     rab_out.rab$l_rbf = ubf;
11558     if (!((sts = sys$connect(&rab_out)) & 1)) {
11559       sys$close(&fab_in); sys$close(&fab_out);
11560       PerlMem_free(vmsin);
11561       PerlMem_free(vmsout);
11562       PerlMem_free(esa);
11563       PerlMem_free(ubf);
11564       PerlMem_free(rsa);
11565       PerlMem_free(esa_out);
11566       set_errno(EVMSERR); set_vaxc_errno(sts);
11567       return 0;
11568     }
11569
11570     while ((sts = sys$read(&rab_in))) {  /* always true  */
11571       if (sts == RMS$_EOF) break;
11572       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11573       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11574         sys$close(&fab_in); sys$close(&fab_out);
11575         PerlMem_free(vmsin);
11576         PerlMem_free(vmsout);
11577         PerlMem_free(esa);
11578         PerlMem_free(ubf);
11579         PerlMem_free(rsa);
11580         PerlMem_free(esa_out);
11581         set_errno(EVMSERR); set_vaxc_errno(sts);
11582         return 0;
11583       }
11584     }
11585
11586
11587     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
11588     sys$close(&fab_in);  sys$close(&fab_out);
11589     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11590     if (!(sts & 1)) {
11591       PerlMem_free(vmsin);
11592       PerlMem_free(vmsout);
11593       PerlMem_free(esa);
11594       PerlMem_free(ubf);
11595       PerlMem_free(rsa);
11596       PerlMem_free(esa_out);
11597       set_errno(EVMSERR); set_vaxc_errno(sts);
11598       return 0;
11599     }
11600
11601     PerlMem_free(vmsin);
11602     PerlMem_free(vmsout);
11603     PerlMem_free(esa);
11604     PerlMem_free(ubf);
11605     PerlMem_free(rsa);
11606     PerlMem_free(esa_out);
11607     return 1;
11608
11609 }  /* end of rmscopy() */
11610 /*}}}*/
11611
11612
11613 /***  The following glue provides 'hooks' to make some of the routines
11614  * from this file available from Perl.  These routines are sufficiently
11615  * basic, and are required sufficiently early in the build process,
11616  * that's it's nice to have them available to miniperl as well as the
11617  * full Perl, so they're set up here instead of in an extension.  The
11618  * Perl code which handles importation of these names into a given
11619  * package lives in [.VMS]Filespec.pm in @INC.
11620  */
11621
11622 void
11623 rmsexpand_fromperl(pTHX_ CV *cv)
11624 {
11625   dXSARGS;
11626   char *fspec, *defspec = NULL, *rslt;
11627   STRLEN n_a;
11628   int fs_utf8, dfs_utf8;
11629
11630   fs_utf8 = 0;
11631   dfs_utf8 = 0;
11632   if (!items || items > 2)
11633     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11634   fspec = SvPV(ST(0),n_a);
11635   fs_utf8 = SvUTF8(ST(0));
11636   if (!fspec || !*fspec) XSRETURN_UNDEF;
11637   if (items == 2) {
11638     defspec = SvPV(ST(1),n_a);
11639     dfs_utf8 = SvUTF8(ST(1));
11640   }
11641   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11642   ST(0) = sv_newmortal();
11643   if (rslt != NULL) {
11644     sv_usepvn(ST(0),rslt,strlen(rslt));
11645     if (fs_utf8) {
11646         SvUTF8_on(ST(0));
11647     }
11648   }
11649   XSRETURN(1);
11650 }
11651
11652 void
11653 vmsify_fromperl(pTHX_ CV *cv)
11654 {
11655   dXSARGS;
11656   char *vmsified;
11657   STRLEN n_a;
11658   int utf8_fl;
11659
11660   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11661   utf8_fl = SvUTF8(ST(0));
11662   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11663   ST(0) = sv_newmortal();
11664   if (vmsified != NULL) {
11665     sv_usepvn(ST(0),vmsified,strlen(vmsified));
11666     if (utf8_fl) {
11667         SvUTF8_on(ST(0));
11668     }
11669   }
11670   XSRETURN(1);
11671 }
11672
11673 void
11674 unixify_fromperl(pTHX_ CV *cv)
11675 {
11676   dXSARGS;
11677   char *unixified;
11678   STRLEN n_a;
11679   int utf8_fl;
11680
11681   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11682   utf8_fl = SvUTF8(ST(0));
11683   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11684   ST(0) = sv_newmortal();
11685   if (unixified != NULL) {
11686     sv_usepvn(ST(0),unixified,strlen(unixified));
11687     if (utf8_fl) {
11688         SvUTF8_on(ST(0));
11689     }
11690   }
11691   XSRETURN(1);
11692 }
11693
11694 void
11695 fileify_fromperl(pTHX_ CV *cv)
11696 {
11697   dXSARGS;
11698   char *fileified;
11699   STRLEN n_a;
11700   int utf8_fl;
11701
11702   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11703   utf8_fl = SvUTF8(ST(0));
11704   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11705   ST(0) = sv_newmortal();
11706   if (fileified != NULL) {
11707     sv_usepvn(ST(0),fileified,strlen(fileified));
11708     if (utf8_fl) {
11709         SvUTF8_on(ST(0));
11710     }
11711   }
11712   XSRETURN(1);
11713 }
11714
11715 void
11716 pathify_fromperl(pTHX_ CV *cv)
11717 {
11718   dXSARGS;
11719   char *pathified;
11720   STRLEN n_a;
11721   int utf8_fl;
11722
11723   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11724   utf8_fl = SvUTF8(ST(0));
11725   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11726   ST(0) = sv_newmortal();
11727   if (pathified != NULL) {
11728     sv_usepvn(ST(0),pathified,strlen(pathified));
11729     if (utf8_fl) {
11730         SvUTF8_on(ST(0));
11731     }
11732   }
11733   XSRETURN(1);
11734 }
11735
11736 void
11737 vmspath_fromperl(pTHX_ CV *cv)
11738 {
11739   dXSARGS;
11740   char *vmspath;
11741   STRLEN n_a;
11742   int utf8_fl;
11743
11744   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11745   utf8_fl = SvUTF8(ST(0));
11746   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11747   ST(0) = sv_newmortal();
11748   if (vmspath != NULL) {
11749     sv_usepvn(ST(0),vmspath,strlen(vmspath));
11750     if (utf8_fl) {
11751         SvUTF8_on(ST(0));
11752     }
11753   }
11754   XSRETURN(1);
11755 }
11756
11757 void
11758 unixpath_fromperl(pTHX_ CV *cv)
11759 {
11760   dXSARGS;
11761   char *unixpath;
11762   STRLEN n_a;
11763   int utf8_fl;
11764
11765   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11766   utf8_fl = SvUTF8(ST(0));
11767   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11768   ST(0) = sv_newmortal();
11769   if (unixpath != NULL) {
11770     sv_usepvn(ST(0),unixpath,strlen(unixpath));
11771     if (utf8_fl) {
11772         SvUTF8_on(ST(0));
11773     }
11774   }
11775   XSRETURN(1);
11776 }
11777
11778 void
11779 candelete_fromperl(pTHX_ CV *cv)
11780 {
11781   dXSARGS;
11782   char *fspec, *fsp;
11783   SV *mysv;
11784   IO *io;
11785   STRLEN n_a;
11786
11787   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11788
11789   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11790   Newx(fspec, VMS_MAXRSS, char);
11791   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11792   if (SvTYPE(mysv) == SVt_PVGV) {
11793     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11794       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11795       ST(0) = &PL_sv_no;
11796       Safefree(fspec);
11797       XSRETURN(1);
11798     }
11799     fsp = fspec;
11800   }
11801   else {
11802     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11803       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11804       ST(0) = &PL_sv_no;
11805       Safefree(fspec);
11806       XSRETURN(1);
11807     }
11808   }
11809
11810   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11811   Safefree(fspec);
11812   XSRETURN(1);
11813 }
11814
11815 void
11816 rmscopy_fromperl(pTHX_ CV *cv)
11817 {
11818   dXSARGS;
11819   char *inspec, *outspec, *inp, *outp;
11820   int date_flag;
11821   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11822                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11823   unsigned long int sts;
11824   SV *mysv;
11825   IO *io;
11826   STRLEN n_a;
11827
11828   if (items < 2 || items > 3)
11829     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11830
11831   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11832   Newx(inspec, VMS_MAXRSS, char);
11833   if (SvTYPE(mysv) == SVt_PVGV) {
11834     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11835       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11836       ST(0) = &PL_sv_no;
11837       Safefree(inspec);
11838       XSRETURN(1);
11839     }
11840     inp = inspec;
11841   }
11842   else {
11843     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11844       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11845       ST(0) = &PL_sv_no;
11846       Safefree(inspec);
11847       XSRETURN(1);
11848     }
11849   }
11850   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11851   Newx(outspec, VMS_MAXRSS, char);
11852   if (SvTYPE(mysv) == SVt_PVGV) {
11853     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11854       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11855       ST(0) = &PL_sv_no;
11856       Safefree(inspec);
11857       Safefree(outspec);
11858       XSRETURN(1);
11859     }
11860     outp = outspec;
11861   }
11862   else {
11863     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11864       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11865       ST(0) = &PL_sv_no;
11866       Safefree(inspec);
11867       Safefree(outspec);
11868       XSRETURN(1);
11869     }
11870   }
11871   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11872
11873   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11874   Safefree(inspec);
11875   Safefree(outspec);
11876   XSRETURN(1);
11877 }
11878
11879 /* The mod2fname is limited to shorter filenames by design, so it should
11880  * not be modified to support longer EFS pathnames
11881  */
11882 void
11883 mod2fname(pTHX_ CV *cv)
11884 {
11885   dXSARGS;
11886   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11887        workbuff[NAM$C_MAXRSS*1 + 1];
11888   int total_namelen = 3, counter, num_entries;
11889   /* ODS-5 ups this, but we want to be consistent, so... */
11890   int max_name_len = 39;
11891   AV *in_array = (AV *)SvRV(ST(0));
11892
11893   num_entries = av_len(in_array);
11894
11895   /* All the names start with PL_. */
11896   strcpy(ultimate_name, "PL_");
11897
11898   /* Clean up our working buffer */
11899   Zero(work_name, sizeof(work_name), char);
11900
11901   /* Run through the entries and build up a working name */
11902   for(counter = 0; counter <= num_entries; counter++) {
11903     /* If it's not the first name then tack on a __ */
11904     if (counter) {
11905       strcat(work_name, "__");
11906     }
11907     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11908                            PL_na));
11909   }
11910
11911   /* Check to see if we actually have to bother...*/
11912   if (strlen(work_name) + 3 <= max_name_len) {
11913     strcat(ultimate_name, work_name);
11914   } else {
11915     /* It's too darned big, so we need to go strip. We use the same */
11916     /* algorithm as xsubpp does. First, strip out doubled __ */
11917     char *source, *dest, last;
11918     dest = workbuff;
11919     last = 0;
11920     for (source = work_name; *source; source++) {
11921       if (last == *source && last == '_') {
11922         continue;
11923       }
11924       *dest++ = *source;
11925       last = *source;
11926     }
11927     /* Go put it back */
11928     strcpy(work_name, workbuff);
11929     /* Is it still too big? */
11930     if (strlen(work_name) + 3 > max_name_len) {
11931       /* Strip duplicate letters */
11932       last = 0;
11933       dest = workbuff;
11934       for (source = work_name; *source; source++) {
11935         if (last == toupper(*source)) {
11936         continue;
11937         }
11938         *dest++ = *source;
11939         last = toupper(*source);
11940       }
11941       strcpy(work_name, workbuff);
11942     }
11943
11944     /* Is it *still* too big? */
11945     if (strlen(work_name) + 3 > max_name_len) {
11946       /* Too bad, we truncate */
11947       work_name[max_name_len - 2] = 0;
11948     }
11949     strcat(ultimate_name, work_name);
11950   }
11951
11952   /* Okay, return it */
11953   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11954   XSRETURN(1);
11955 }
11956
11957 void
11958 hushexit_fromperl(pTHX_ CV *cv)
11959 {
11960     dXSARGS;
11961
11962     if (items > 0) {
11963         VMSISH_HUSHED = SvTRUE(ST(0));
11964     }
11965     ST(0) = boolSV(VMSISH_HUSHED);
11966     XSRETURN(1);
11967 }
11968
11969
11970 PerlIO *
11971 Perl_vms_start_glob
11972    (pTHX_ SV *tmpglob,
11973     IO *io)
11974 {
11975     PerlIO *fp;
11976     struct vs_str_st *rslt;
11977     char *vmsspec;
11978     char *rstr;
11979     char *begin, *cp;
11980     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11981     PerlIO *tmpfp;
11982     STRLEN i;
11983     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11984     struct dsc$descriptor_vs rsdsc;
11985     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11986     unsigned long hasver = 0, isunix = 0;
11987     unsigned long int lff_flags = 0;
11988     int rms_sts;
11989
11990 #ifdef VMS_LONGNAME_SUPPORT
11991     lff_flags = LIB$M_FIL_LONG_NAMES;
11992 #endif
11993     /* The Newx macro will not allow me to assign a smaller array
11994      * to the rslt pointer, so we will assign it to the begin char pointer
11995      * and then copy the value into the rslt pointer.
11996      */
11997     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11998     rslt = (struct vs_str_st *)begin;
11999     rslt->length = 0;
12000     rstr = &rslt->str[0];
12001     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12002     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12003     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12004     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12005
12006     Newx(vmsspec, VMS_MAXRSS, char);
12007
12008         /* We could find out if there's an explicit dev/dir or version
12009            by peeking into lib$find_file's internal context at
12010            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12011            but that's unsupported, so I don't want to do it now and
12012            have it bite someone in the future. */
12013         /* Fix-me: vms_split_path() is the only way to do this, the
12014            existing method will fail with many legal EFS or UNIX specifications
12015          */
12016
12017     cp = SvPV(tmpglob,i);
12018
12019     for (; i; i--) {
12020         if (cp[i] == ';') hasver = 1;
12021         if (cp[i] == '.') {
12022             if (sts) hasver = 1;
12023             else sts = 1;
12024         }
12025         if (cp[i] == '/') {
12026             hasdir = isunix = 1;
12027             break;
12028         }
12029         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12030             hasdir = 1;
12031             break;
12032         }
12033     }
12034     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12035         int found = 0;
12036         Stat_t st;
12037         int stat_sts;
12038         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12039         if (!stat_sts && S_ISDIR(st.st_mode)) {
12040             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12041             ok = (wilddsc.dsc$a_pointer != NULL);
12042             /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12043             hasdir = 1;
12044         }
12045         else {
12046             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12047             ok = (wilddsc.dsc$a_pointer != NULL);
12048         }
12049         if (ok)
12050             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12051
12052         /* If not extended character set, replace ? with % */
12053         /* With extended character set, ? is a wildcard single character */
12054         if (!decc_efs_case_preserve) {
12055             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12056                 if (*cp == '?') *cp = '%';
12057         }
12058         sts = SS$_NORMAL;
12059         while (ok && $VMS_STATUS_SUCCESS(sts)) {
12060          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12061          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12062
12063             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12064                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
12065             if (!$VMS_STATUS_SUCCESS(sts))
12066                 break;
12067
12068             found++;
12069
12070             /* with varying string, 1st word of buffer contains result length */
12071             rstr[rslt->length] = '\0';
12072
12073              /* Find where all the components are */
12074              v_sts = vms_split_path
12075                        (rstr,
12076                         &v_spec,
12077                         &v_len,
12078                         &r_spec,
12079                         &r_len,
12080                         &d_spec,
12081                         &d_len,
12082                         &n_spec,
12083                         &n_len,
12084                         &e_spec,
12085                         &e_len,
12086                         &vs_spec,
12087                         &vs_len);
12088
12089             /* If no version on input, truncate the version on output */
12090             if (!hasver && (vs_len > 0)) {
12091                 *vs_spec = '\0';
12092                 vs_len = 0;
12093
12094                 /* No version & a null extension on UNIX handling */
12095                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12096                     e_len = 0;
12097                     *e_spec = '\0';
12098                 }
12099             }
12100
12101             if (!decc_efs_case_preserve) {
12102                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12103             }
12104
12105             if (hasdir) {
12106                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12107                 begin = rstr;
12108             }
12109             else {
12110                 /* Start with the name */
12111                 begin = n_spec;
12112             }
12113             strcat(begin,"\n");
12114             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12115         }
12116         if (cxt) (void)lib$find_file_end(&cxt);
12117
12118         if (!found) {
12119             /* Be POSIXish: return the input pattern when no matches */
12120             begin = SvPVX(tmpglob);
12121             strcat(begin,"\n");
12122             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12123         }
12124
12125         if (ok && sts != RMS$_NMF &&
12126             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12127         if (!ok) {
12128             if (!(sts & 1)) {
12129                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12130             }
12131             PerlIO_close(tmpfp);
12132             fp = NULL;
12133         }
12134         else {
12135             PerlIO_rewind(tmpfp);
12136             IoTYPE(io) = IoTYPE_RDONLY;
12137             IoIFP(io) = fp = tmpfp;
12138             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
12139         }
12140     }
12141     Safefree(vmsspec);
12142     Safefree(rslt);
12143     return fp;
12144 }
12145
12146
12147 #ifdef HAS_SYMLINK
12148 static char *
12149 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
12150                    const int *utf8_fl);
12151
12152 void
12153 vms_realpath_fromperl(pTHX_ CV *cv)
12154 {
12155   dXSARGS;
12156   char *fspec, *rslt_spec, *rslt;
12157   STRLEN n_a;
12158
12159   if (!items || items != 1)
12160     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12161
12162   fspec = SvPV(ST(0),n_a);
12163   if (!fspec || !*fspec) XSRETURN_UNDEF;
12164
12165   Newx(rslt_spec, VMS_MAXRSS + 1, char);
12166   rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12167   ST(0) = sv_newmortal();
12168   if (rslt != NULL)
12169     sv_usepvn(ST(0),rslt,strlen(rslt));
12170   else
12171     Safefree(rslt_spec);
12172   XSRETURN(1);
12173 }
12174 #endif
12175
12176 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12177 int do_vms_case_tolerant(void);
12178
12179 void
12180 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12181 {
12182   dXSARGS;
12183   ST(0) = boolSV(do_vms_case_tolerant());
12184   XSRETURN(1);
12185 }
12186 #endif
12187
12188 void
12189 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12190                           struct interp_intern *dst)
12191 {
12192     memcpy(dst,src,sizeof(struct interp_intern));
12193 }
12194
12195 void
12196 Perl_sys_intern_clear(pTHX)
12197 {
12198 }
12199
12200 void
12201 Perl_sys_intern_init(pTHX)
12202 {
12203     unsigned int ix = RAND_MAX;
12204     double x;
12205
12206     VMSISH_HUSHED = 0;
12207
12208     /* fix me later to track running under GNV */
12209     /* this allows some limited testing */
12210     MY_POSIX_EXIT = decc_filename_unix_report;
12211
12212     x = (float)ix;
12213     MY_INV_RAND_MAX = 1./x;
12214 }
12215
12216 void
12217 init_os_extras(void)
12218 {
12219   dTHX;
12220   char* file = __FILE__;
12221   if (decc_disable_to_vms_logname_translation) {
12222     no_translate_barewords = TRUE;
12223   } else {
12224     no_translate_barewords = FALSE;
12225   }
12226
12227   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
12228   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
12229   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
12230   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
12231   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
12232   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
12233   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
12234   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
12235   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
12236   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
12237   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
12238 #ifdef HAS_SYMLINK
12239   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
12240 #endif
12241 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12242   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
12243 #endif
12244
12245   store_pipelocs(aTHX);         /* will redo any earlier attempts */
12246
12247   return;
12248 }
12249
12250 #ifdef HAS_SYMLINK
12251
12252 #if __CRTL_VER == 80200000
12253 /* This missed getting in to the DECC SDK for 8.2 */
12254 char *realpath(const char *file_name, char * resolved_name, ...);
12255 #endif
12256
12257 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
12258 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
12259  * The perl fallback routine to provide realpath() is not as efficient
12260  * on OpenVMS.
12261  */
12262 static char *
12263 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
12264                    const int *utf8_fl)
12265 {
12266     return realpath(filespec, outbuf);
12267 }
12268
12269 /*}}}*/
12270 /* External entry points */
12271 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12272 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
12273 #else
12274 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12275 { return NULL; }
12276 #endif
12277
12278
12279 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12280 /* case_tolerant */
12281
12282 /*{{{int do_vms_case_tolerant(void)*/
12283 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
12284  * controlled by a process setting.
12285  */
12286 int do_vms_case_tolerant(void)
12287 {
12288     return vms_process_case_tolerant;
12289 }
12290 /*}}}*/
12291 /* External entry points */
12292 int Perl_vms_case_tolerant(void)
12293 { return do_vms_case_tolerant(); }
12294 #else
12295 int Perl_vms_case_tolerant(void)
12296 { return vms_process_case_tolerant; }
12297 #endif
12298
12299
12300  /* Start of DECC RTL Feature handling */
12301
12302 static int sys_trnlnm
12303    (const char * logname,
12304     char * value,
12305     int value_len)
12306 {
12307     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
12308     const unsigned long attr = LNM$M_CASE_BLIND;
12309     struct dsc$descriptor_s name_dsc;
12310     int status;
12311     unsigned short result;
12312     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
12313                                 {0, 0, 0, 0}};
12314
12315     name_dsc.dsc$w_length = strlen(logname);
12316     name_dsc.dsc$a_pointer = (char *)logname;
12317     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12318     name_dsc.dsc$b_class = DSC$K_CLASS_S;
12319
12320     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
12321
12322     if ($VMS_STATUS_SUCCESS(status)) {
12323
12324          /* Null terminate and return the string */
12325         /*--------------------------------------*/
12326         value[result] = 0;
12327     }
12328
12329     return status;
12330 }
12331
12332 static int sys_crelnm
12333    (const char * logname,
12334     const char * value)
12335 {
12336     int ret_val;
12337     const char * proc_table = "LNM$PROCESS_TABLE";
12338     struct dsc$descriptor_s proc_table_dsc;
12339     struct dsc$descriptor_s logname_dsc;
12340     struct itmlst_3 item_list[2];
12341
12342     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
12343     proc_table_dsc.dsc$w_length = strlen(proc_table);
12344     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12345     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
12346
12347     logname_dsc.dsc$a_pointer = (char *) logname;
12348     logname_dsc.dsc$w_length = strlen(logname);
12349     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12350     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
12351
12352     item_list[0].buflen = strlen(value);
12353     item_list[0].itmcode = LNM$_STRING;
12354     item_list[0].bufadr = (char *)value;
12355     item_list[0].retlen = NULL;
12356
12357     item_list[1].buflen = 0;
12358     item_list[1].itmcode = 0;
12359
12360     ret_val = sys$crelnm
12361                        (NULL,
12362                         (const struct dsc$descriptor_s *)&proc_table_dsc,
12363                         (const struct dsc$descriptor_s *)&logname_dsc,
12364                         NULL,
12365                         (const struct item_list_3 *) item_list);
12366
12367     return ret_val;
12368 }
12369
12370 /* C RTL Feature settings */
12371
12372 static int set_features
12373    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
12374     int (* cli_routine)(void),  /* Not documented */
12375     void *image_info)           /* Not documented */
12376 {
12377     int status;
12378     int s;
12379     int dflt;
12380     char* str;
12381     char val_str[10];
12382 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12383     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12384     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12385     unsigned long case_perm;
12386     unsigned long case_image;
12387 #endif
12388
12389     /* Allow an exception to bring Perl into the VMS debugger */
12390     vms_debug_on_exception = 0;
12391     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12392     if ($VMS_STATUS_SUCCESS(status)) {
12393        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12394          vms_debug_on_exception = 1;
12395        else
12396          vms_debug_on_exception = 0;
12397     }
12398
12399     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
12400     vms_vtf7_filenames = 0;
12401     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12402     if ($VMS_STATUS_SUCCESS(status)) {
12403        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12404          vms_vtf7_filenames = 1;
12405        else
12406          vms_vtf7_filenames = 0;
12407     }
12408
12409
12410     /* unlink all versions on unlink() or rename() */
12411     vms_vtf7_filenames = 0;
12412     status = sys_trnlnm
12413         ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
12414     if ($VMS_STATUS_SUCCESS(status)) {
12415        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12416          vms_unlink_all_versions = 1;
12417        else
12418          vms_unlink_all_versions = 0;
12419     }
12420
12421     /* Dectect running under GNV Bash or other UNIX like shell */
12422 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12423     gnv_unix_shell = 0;
12424     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12425     if ($VMS_STATUS_SUCCESS(status)) {
12426        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12427          gnv_unix_shell = 1;
12428          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12429          set_feature_default("DECC$EFS_CHARSET", 1);
12430          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12431          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12432          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12433          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12434          vms_unlink_all_versions = 1;
12435        }
12436        else
12437          gnv_unix_shell = 0;
12438     }
12439 #endif
12440
12441     /* hacks to see if known bugs are still present for testing */
12442
12443     /* Readdir is returning filenames in VMS syntax always */
12444     decc_bug_readdir_efs1 = 1;
12445     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", 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          decc_bug_readdir_efs1 = 1;
12449        else
12450          decc_bug_readdir_efs1 = 0;
12451     }
12452
12453     /* PCP mode requires creating /dev/null special device file */
12454     decc_bug_devnull = 0;
12455     status = sys_trnlnm("DECC_BUG_DEVNULL", 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           decc_bug_devnull = 1;
12459        else
12460           decc_bug_devnull = 0;
12461     }
12462
12463     /* fgetname returning a VMS name in UNIX mode */
12464     decc_bug_fgetname = 1;
12465     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12466     if ($VMS_STATUS_SUCCESS(status)) {
12467       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12468         decc_bug_fgetname = 1;
12469       else
12470         decc_bug_fgetname = 0;
12471     }
12472
12473     /* UNIX directory names with no paths are broken in a lot of places */
12474     decc_dir_barename = 1;
12475     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12476     if ($VMS_STATUS_SUCCESS(status)) {
12477       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12478         decc_dir_barename = 1;
12479       else
12480         decc_dir_barename = 0;
12481     }
12482
12483 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12484     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12485     if (s >= 0) {
12486         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12487         if (decc_disable_to_vms_logname_translation < 0)
12488             decc_disable_to_vms_logname_translation = 0;
12489     }
12490
12491     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12492     if (s >= 0) {
12493         decc_efs_case_preserve = decc$feature_get_value(s, 1);
12494         if (decc_efs_case_preserve < 0)
12495             decc_efs_case_preserve = 0;
12496     }
12497
12498     s = decc$feature_get_index("DECC$EFS_CHARSET");
12499     if (s >= 0) {
12500         decc_efs_charset = decc$feature_get_value(s, 1);
12501         if (decc_efs_charset < 0)
12502             decc_efs_charset = 0;
12503     }
12504
12505     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12506     if (s >= 0) {
12507         decc_filename_unix_report = decc$feature_get_value(s, 1);
12508         if (decc_filename_unix_report > 0)
12509             decc_filename_unix_report = 1;
12510         else
12511             decc_filename_unix_report = 0;
12512     }
12513
12514     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12515     if (s >= 0) {
12516         decc_filename_unix_only = decc$feature_get_value(s, 1);
12517         if (decc_filename_unix_only > 0) {
12518             decc_filename_unix_only = 1;
12519         }
12520         else {
12521             decc_filename_unix_only = 0;
12522         }
12523     }
12524
12525     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12526     if (s >= 0) {
12527         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12528         if (decc_filename_unix_no_version < 0)
12529             decc_filename_unix_no_version = 0;
12530     }
12531
12532     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12533     if (s >= 0) {
12534         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12535         if (decc_readdir_dropdotnotype < 0)
12536             decc_readdir_dropdotnotype = 0;
12537     }
12538
12539     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12540     if ($VMS_STATUS_SUCCESS(status)) {
12541         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12542         if (s >= 0) {
12543             dflt = decc$feature_get_value(s, 4);
12544             if (dflt > 0) {
12545                 decc_disable_posix_root = decc$feature_get_value(s, 1);
12546                 if (decc_disable_posix_root <= 0) {
12547                     decc$feature_set_value(s, 1, 1);
12548                     decc_disable_posix_root = 1;
12549                 }
12550             }
12551             else {
12552                 /* Traditionally Perl assumes this is off */
12553                 decc_disable_posix_root = 1;
12554                 decc$feature_set_value(s, 1, 1);
12555             }
12556         }
12557     }
12558
12559 #if __CRTL_VER >= 80200000
12560     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12561     if (s >= 0) {
12562         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12563         if (decc_posix_compliant_pathnames < 0)
12564             decc_posix_compliant_pathnames = 0;
12565         if (decc_posix_compliant_pathnames > 4)
12566             decc_posix_compliant_pathnames = 0;
12567     }
12568
12569 #endif
12570 #else
12571     status = sys_trnlnm
12572         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12573     if ($VMS_STATUS_SUCCESS(status)) {
12574         val_str[0] = _toupper(val_str[0]);
12575         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12576            decc_disable_to_vms_logname_translation = 1;
12577         }
12578     }
12579
12580 #ifndef __VAX
12581     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12582     if ($VMS_STATUS_SUCCESS(status)) {
12583         val_str[0] = _toupper(val_str[0]);
12584         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12585            decc_efs_case_preserve = 1;
12586         }
12587     }
12588 #endif
12589
12590     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12591     if ($VMS_STATUS_SUCCESS(status)) {
12592         val_str[0] = _toupper(val_str[0]);
12593         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12594            decc_filename_unix_report = 1;
12595         }
12596     }
12597     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12598     if ($VMS_STATUS_SUCCESS(status)) {
12599         val_str[0] = _toupper(val_str[0]);
12600         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12601            decc_filename_unix_only = 1;
12602            decc_filename_unix_report = 1;
12603         }
12604     }
12605     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12606     if ($VMS_STATUS_SUCCESS(status)) {
12607         val_str[0] = _toupper(val_str[0]);
12608         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12609            decc_filename_unix_no_version = 1;
12610         }
12611     }
12612     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12613     if ($VMS_STATUS_SUCCESS(status)) {
12614         val_str[0] = _toupper(val_str[0]);
12615         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12616            decc_readdir_dropdotnotype = 1;
12617         }
12618     }
12619 #endif
12620
12621 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12622
12623      /* Report true case tolerance */
12624     /*----------------------------*/
12625     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12626     if (!$VMS_STATUS_SUCCESS(status))
12627         case_perm = PPROP$K_CASE_BLIND;
12628     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12629     if (!$VMS_STATUS_SUCCESS(status))
12630         case_image = PPROP$K_CASE_BLIND;
12631     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12632         (case_image == PPROP$K_CASE_SENSITIVE))
12633         vms_process_case_tolerant = 0;
12634
12635 #endif
12636
12637
12638     /* CRTL can be initialized past this point, but not before. */
12639 /*    DECC$CRTL_INIT(); */
12640
12641     return SS$_NORMAL;
12642 }
12643
12644 #ifdef __DECC
12645 #pragma nostandard
12646 #pragma extern_model save
12647 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12648         const __align (LONGWORD) int spare[8] = {0};
12649
12650 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
12651 #if __DECC_VER >= 60560002
12652 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
12653 #else
12654 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
12655 #endif
12656 #endif /* __DECC */
12657
12658 const long vms_cc_features = (const long)set_features;
12659
12660 /*
12661 ** Force a reference to LIB$INITIALIZE to ensure it
12662 ** exists in the image.
12663 */
12664 int lib$initialize(void);
12665 #ifdef __DECC
12666 #pragma extern_model strict_refdef
12667 #endif
12668     int lib_init_ref = (int) lib$initialize;
12669
12670 #ifdef __DECC
12671 #pragma extern_model restore
12672 #pragma standard
12673 #endif
12674
12675 /*  End of vms.c */