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 <descrip.h>
  21 #include <devdef.h>
  22 #include <dvidef.h>
  23 #include <fibdef.h>
  24 #include <float.h>
  25 #include <fscndef.h>
  26 #include <iodef.h>
  27 #include <jpidef.h>
  28 #include <kgbdef.h>
  29 #include <libclidef.h>
  30 #include <libdef.h>
  31 #include <lib$routines.h>
  32 #include <lnmdef.h>
  33 #include <msgdef.h>
  34 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  35 #include <ppropdef.h>
  36 #endif
  37 #include <prvdef.h>
  38 #include <psldef.h>
  39 #include <rms.h>
  40 #include <shrdef.h>
  41 #include <ssdef.h>
  42 #include <starlet.h>
  43 #include <strdef.h>
  44 #include <str$routines.h>
  45 #include <syidef.h>
  46 #include <uaidef.h>
  47 #include <uicdef.h>
  48 #include <stsdef.h>
  49 #include <rmsdef.h>
  50 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
  51 #include <efndef.h>
  52 #define NO_EFN EFN$C_ENF
  53 #else
  54 #define NO_EFN 0;
  55 #endif
  56
  57 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  58 int   decc$feature_get_index(const char *name);
  59 char* decc$feature_get_name(int index);
  60 int   decc$feature_get_value(int index, int mode);
  61 int   decc$feature_set_value(int index, int mode, int value);
  62 #else
  63 #include <unixlib.h>
  64 #endif
  65
  66 #pragma member_alignment save
  67 #pragma nomember_alignment longword
  68 struct item_list_3 {
  69         unsigned short len;
  70         unsigned short code;
  71         void * bufadr;
  72         unsigned short * retadr;
  73 };
  74 #pragma member_alignment restore
  75
  76 /* More specific prototype than in starlet_c.h makes programming errors
  77    more visible.
  78  */
  79 #ifdef sys$getdviw
  80 #undef sys$getdviw
  81 #endif
  82 int sys$getdviw
  83        (unsigned long efn,
  84         unsigned short chan,
  85         const struct dsc$descriptor_s * devnam,
  86         const struct item_list_3 * itmlst,
  87         void * iosb,
  88         void * (astadr)(unsigned long),
  89         void * astprm,
  90         void * nullarg);
  91
  92 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  93
  94 static int set_feature_default(const char *name, int value)
  95 {
  96     int status;
  97     int index;
  98
  99     index = decc$feature_get_index(name);
 100
 101     status = decc$feature_set_value(index, 1, value);
 102     if (index == -1 || (status == -1)) {
 103       return -1;
 104     }
 105
 106     status = decc$feature_get_value(index, 1);
 107     if (status != value) {
 108       return -1;
 109     }
 110
 111 return 0;
 112 }
 113 #endif
 114
 115 /* Older versions of ssdef.h don't have these */
 116 #ifndef SS$_INVFILFOROP
 117 #  define SS$_INVFILFOROP 3930
 118 #endif
 119 #ifndef SS$_NOSUCHOBJECT
 120 #  define SS$_NOSUCHOBJECT 2696
 121 #endif
 122
 123 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 124 #define PERLIO_NOT_STDIO 0
 125
 126 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 127  * code below needs to get to the underlying CRTL routines. */
 128 #define DONT_MASK_RTL_CALLS
 129 #include "EXTERN.h"
 130 #include "perl.h"
 131 #include "XSUB.h"
 132 /* Anticipating future expansion in lexical warnings . . . */
 133 #ifndef WARN_INTERNAL
 134 #  define WARN_INTERNAL WARN_MISC
 135 #endif
 136
 137 #ifdef VMS_LONGNAME_SUPPORT
 138 #include <libfildef.h>
 139 #endif
 140
 141 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 142 #  define RTL_USES_UTC 1
 143 #endif
 144
 145
 146 /* gcc's header files don't #define direct access macros
 147  * corresponding to VAXC's variant structs */
 148 #ifdef __GNUC__
 149 #  define uic$v_format uic$r_uic_form.uic$v_format
 150 #  define uic$v_group uic$r_uic_form.uic$v_group
 151 #  define uic$v_member uic$r_uic_form.uic$v_member
 152 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 153 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 154 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 155 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 156 #endif
 157
 158 #if defined(NEED_AN_H_ERRNO)
 159 dEXT int h_errno;
 160 #endif
 161
 162 #ifdef __DECC
 163 #pragma message disable pragma
 164 #pragma member_alignment save
 165 #pragma nomember_alignment longword
 166 #pragma message save
 167 #pragma message disable misalgndmem
 168 #endif
 169 struct itmlst_3 {
 170   unsigned short int buflen;
 171   unsigned short int itmcode;
 172   void *bufadr;
 173   unsigned short int *retlen;
 174 };
 175
 176 struct filescan_itmlst_2 {
 177     unsigned short length;
 178     unsigned short itmcode;
 179     char * component;
 180 };
 181
 182 struct vs_str_st {
 183     unsigned short length;
 184     char str[65536];
 185 };
 186
 187 #ifdef __DECC
 188 #pragma message restore
 189 #pragma member_alignment restore
 190 #endif
 191
 192 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 193 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 194 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 195 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 196 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 197 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 198 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 199 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 200 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 201 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 202 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 203
 204 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 205 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 206 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 207 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 208
 209 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 210 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 211
 212 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 213  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 214  * the Perl facility.
 215  */
 216 #define PERL_LNM_MAX_ITER 10
 217
 218   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 219 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 220 #define MAX_DCL_SYMBOL          (8192)
 221 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 222 #else
 223 #define MAX_DCL_SYMBOL          (1024)
 224 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 225 #endif
 226
 227 static char *__mystrtolower(char *str)
 228 {
 229   if (str) for (; *str; ++str) *str= tolower(*str);
 230   return str;
 231 }
 232
 233 static struct dsc$descriptor_s fildevdsc =
 234   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 235 static struct dsc$descriptor_s crtlenvdsc =
 236   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 237 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 238 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 239 static struct dsc$descriptor_s **env_tables = defenv;
 240 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 241
 242 /* True if we shouldn't treat barewords as logicals during directory */
 243 /* munching */
 244 static int no_translate_barewords;
 245
 246 #ifndef RTL_USES_UTC
 247 static int tz_updated = 1;
 248 #endif
 249
 250 /* DECC Features that may need to affect how Perl interprets
 251  * displays filename information
 252  */
 253 static int decc_disable_to_vms_logname_translation = 1;
 254 static int decc_disable_posix_root = 1;
 255 int decc_efs_case_preserve = 0;
 256 static int decc_efs_charset = 0;
 257 static int decc_filename_unix_no_version = 0;
 258 static int decc_filename_unix_only = 0;
 259 int decc_filename_unix_report = 0;
 260 int decc_posix_compliant_pathnames = 0;
 261 int decc_readdir_dropdotnotype = 0;
 262 static int vms_process_case_tolerant = 1;
 263 int vms_vtf7_filenames = 0;
 264 int gnv_unix_shell = 0;
 265
 266 /* bug workarounds if needed */
 267 int decc_bug_readdir_efs1 = 0;
 268 int decc_bug_devnull = 1;
 269 int decc_bug_fgetname = 0;
 270 int decc_dir_barename = 0;
 271
 272 static int vms_debug_on_exception = 0;
 273
 274 /* Is this a UNIX file specification?
 275  *   No longer a simple check with EFS file specs
 276  *   For now, not a full check, but need to
 277  *   handle POSIX ^UP^ specifications
 278  *   Fixing to handle ^/ cases would require
 279  *   changes to many other conversion routines.
 280  */
 281
 282 static int is_unix_filespec(const char *path)
 283 {
 284 int ret_val;
 285 const char * pch1;
 286
 287     ret_val = 0;
 288     if (strncmp(path,"\"^UP^",5) != 0) {
 289         pch1 = strchr(path, '/');
 290         if (pch1 != NULL)
 291             ret_val = 1;
 292         else {
 293
 294             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 295             if (decc_filename_unix_report || decc_filename_unix_only) {
 296             if (strcmp(path,".") == 0)
 297                 ret_val = 1;
 298             }
 299         }
 300     }
 301     return ret_val;
 302 }
 303
 304 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 305  */
 306
 307 static void ucs2_to_vtf7
 308    (char *outspec,
 309     unsigned long ucs2_char,
 310     int * output_cnt)
 311 {
 312 unsigned char * ucs_ptr;
 313 int hex;
 314
 315     ucs_ptr = (unsigned char *)&ucs2_char;
 316
 317     outspec[0] = '^';
 318     outspec[1] = 'U';
 319     hex = (ucs_ptr[1] >> 4) & 0xf;
 320     if (hex < 0xA)
 321         outspec[2] = hex + '0';
 322     else
 323         outspec[2] = (hex - 9) + 'A';
 324     hex = ucs_ptr[1] & 0xF;
 325     if (hex < 0xA)
 326         outspec[3] = hex + '0';
 327     else {
 328         outspec[3] = (hex - 9) + 'A';
 329     }
 330     hex = (ucs_ptr[0] >> 4) & 0xf;
 331     if (hex < 0xA)
 332         outspec[4] = hex + '0';
 333     else
 334         outspec[4] = (hex - 9) + 'A';
 335     hex = ucs_ptr[1] & 0xF;
 336     if (hex < 0xA)
 337         outspec[5] = hex + '0';
 338     else {
 339         outspec[5] = (hex - 9) + 'A';
 340     }
 341     *output_cnt = 6;
 342 }
 343
 344
 345 /* This handles the conversion of a UNIX extended character set to a ^
 346  * escaped VMS character.
 347  * in a UNIX file specification.
 348  *
 349  * The output count variable contains the number of characters added
 350  * to the output string.
 351  *
 352  * The return value is the number of characters read from the input string
 353  */
 354 static int copy_expand_unix_filename_escape
 355   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 356 {
 357 int count;
 358 int scnt;
 359 int utf8_flag;
 360
 361     utf8_flag = 0;
 362     if (utf8_fl)
 363       utf8_flag = *utf8_fl;
 364
 365     count = 0;
 366     *output_cnt = 0;
 367     if (*inspec >= 0x80) {
 368         if (utf8_fl && vms_vtf7_filenames) {
 369         unsigned long ucs_char;
 370
 371             ucs_char = 0;
 372
 373             if ((*inspec & 0xE0) == 0xC0) {
 374                 /* 2 byte Unicode */
 375                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 376                 if (ucs_char >= 0x80) {
 377                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 378                     return 2;
 379                 }
 380             } else if ((*inspec & 0xF0) == 0xE0) {
 381                 /* 3 byte Unicode */
 382                 ucs_char = ((inspec[0] & 0xF) << 12) +
 383                    ((inspec[1] & 0x3f) << 6) +
 384                    (inspec[2] & 0x3f);
 385                 if (ucs_char >= 0x800) {
 386                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 387                     return 3;
 388                 }
 389
 390 #if 0 /* I do not see longer sequences supported by OpenVMS */
 391       /* Maybe some one can fix this later */
 392             } else if ((*inspec & 0xF8) == 0xF0) {
 393                 /* 4 byte Unicode */
 394                 /* UCS-4 to UCS-2 */
 395             } else if ((*inspec & 0xFC) == 0xF8) {
 396                 /* 5 byte Unicode */
 397                 /* UCS-4 to UCS-2 */
 398             } else if ((*inspec & 0xFE) == 0xFC) {
 399                 /* 6 byte Unicode */
 400                 /* UCS-4 to UCS-2 */
 401 #endif
 402             }
 403         }
 404
 405         /* High bit set, but not a unicode character! */
 406
 407         /* Non printing DECMCS or ISO Latin-1 character? */
 408         if (*inspec <= 0x9F) {
 409         int hex;
 410             outspec[0] = '^';
 411             outspec++;
 412             hex = (*inspec >> 4) & 0xF;
 413             if (hex < 0xA)
 414                 outspec[1] = hex + '0';
 415             else {
 416                 outspec[1] = (hex - 9) + 'A';
 417             }
 418             hex = *inspec & 0xF;
 419             if (hex < 0xA)
 420                 outspec[2] = hex + '0';
 421             else {
 422                 outspec[2] = (hex - 9) + 'A';
 423             }
 424             *output_cnt = 3;
 425             return 1;
 426         } else if (*inspec == 0xA0) {
 427             outspec[0] = '^';
 428             outspec[1] = 'A';
 429             outspec[2] = '0';
 430             *output_cnt = 3;
 431             return 1;
 432         } else if (*inspec == 0xFF) {
 433             outspec[0] = '^';
 434             outspec[1] = 'F';
 435             outspec[2] = 'F';
 436             *output_cnt = 3;
 437             return 1;
 438         }
 439         *outspec = *inspec;
 440         *output_cnt = 1;
 441         return 1;
 442     }
 443
 444     /* Is this a macro that needs to be passed through?
 445      * Macros start with $( and an alpha character, followed
 446      * by a string of alpha numeric characters ending with a )
 447      * If this does not match, then encode it as ODS-5.
 448      */
 449     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 450     int tcnt;
 451
 452         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 453             tcnt = 3;
 454             outspec[0] = inspec[0];
 455             outspec[1] = inspec[1];
 456             outspec[2] = inspec[2];
 457
 458             while(isalnum(inspec[tcnt]) ||
 459                   (inspec[2] == '.') || (inspec[2] == '_')) {
 460                 outspec[tcnt] = inspec[tcnt];
 461                 tcnt++;
 462             }
 463             if (inspec[tcnt] == ')') {
 464                 outspec[tcnt] = inspec[tcnt];
 465                 tcnt++;
 466                 *output_cnt = tcnt;
 467                 return tcnt;
 468             }
 469         }
 470     }
 471
 472     switch (*inspec) {
 473     case 0x7f:
 474         outspec[0] = '^';
 475         outspec[1] = '7';
 476         outspec[2] = 'F';
 477         *output_cnt = 3;
 478         return 1;
 479         break;
 480     case '?':
 481         if (decc_efs_charset == 0)
 482           outspec[0] = '%';
 483         else
 484           outspec[0] = '?';
 485         *output_cnt = 1;
 486         return 1;
 487         break;
 488     case '.':
 489     case '~':
 490     case '!':
 491     case '#':
 492     case '&':
 493     case '\'':
 494     case '`':
 495     case '(':
 496     case ')':
 497     case '+':
 498     case '@':
 499     case '{':
 500     case '}':
 501     case ',':
 502     case ';':
 503     case '[':
 504     case ']':
 505     case '%':
 506     case '^':
 507     case '=':
 508         /* Assume that this is to be escaped */
 509         outspec[0] = '^';
 510         outspec[1] = *inspec;
 511         *output_cnt = 2;
 512         return 1;
 513         break;
 514     case ' ': /* space */
 515         /* Assume that this is to be escaped */
 516         outspec[0] = '^';
 517         outspec[1] = '_';
 518         *output_cnt = 2;
 519         return 1;
 520         break;
 521     default:
 522         *outspec = *inspec;
 523         *output_cnt = 1;
 524         return 1;
 525         break;
 526     }
 527 }
 528
 529
 530 /* This handles the expansion of a '^' prefix to the proper character
 531  * in a UNIX file specification.
 532  *
 533  * The output count variable contains the number of characters added
 534  * to the output string.
 535  *
 536  * The return value is the number of characters read from the input
 537  * string
 538  */
 539 static int copy_expand_vms_filename_escape
 540   (char *outspec, const char *inspec, int *output_cnt)
 541 {
 542 int count;
 543 int scnt;
 544
 545     count = 0;
 546     *output_cnt = 0;
 547     if (*inspec == '^') {
 548         inspec++;
 549         switch (*inspec) {
 550         case '.':
 551             /* Non trailing dots should just be passed through */
 552             *outspec = *inspec;
 553             count++;
 554             (*output_cnt)++;
 555             break;
 556         case '_': /* space */
 557             *outspec = ' ';
 558             inspec++;
 559             count++;
 560             (*output_cnt)++;
 561             break;
 562         case 'U': /* Unicode - FIX-ME this is wrong. */
 563             inspec++;
 564             count++;
 565             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 566             if (scnt == 4) {
 567                 unsigned int c1, c2;
 568                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 569                 outspec[0] == c1 & 0xff;
 570                 outspec[1] == c2 & 0xff;
 571                 if (scnt > 1) {
 572                     (*output_cnt) += 2;
 573                     count += 4;
 574                 }
 575             }
 576             else {
 577                 /* Error - do best we can to continue */
 578                 *outspec = 'U';
 579                 outspec++;
 580                 (*output_cnt++);
 581                 *outspec = *inspec;
 582                 count++;
 583                 (*output_cnt++);
 584             }
 585             break;
 586         default:
 587             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 588             if (scnt == 2) {
 589                 /* Hex encoded */
 590                 unsigned int c1;
 591                 scnt = sscanf(inspec, "%2x", &c1);
 592                 outspec[0] = c1 & 0xff;
 593                 if (scnt > 0) {
 594                     (*output_cnt++);
 595                     count += 2;
 596                 }
 597             }
 598             else {
 599                 *outspec = *inspec;
 600                 count++;
 601                 (*output_cnt++);
 602             }
 603         }
 604     }
 605     else {
 606         *outspec = *inspec;
 607         count++;
 608         (*output_cnt)++;
 609     }
 610     return count;
 611 }
 612
 613
 614 int SYS$FILESCAN
 615    (const struct dsc$descriptor_s * srcstr,
 616     struct filescan_itmlst_2 * valuelist,
 617     unsigned long * fldflags,
 618     struct dsc$descriptor_s *auxout,
 619     unsigned short * retlen);
 620
 621 /* vms_split_path - Verify that the input file specification is a
 622  * VMS format file specification, and provide pointers to the components of
 623  * it.  With EFS format filenames, this is virtually the only way to
 624  * parse a VMS path specification into components.
 625  *
 626  * If the sum of the components do not add up to the length of the
 627  * string, then the passed file specification is probably a UNIX style
 628  * path.
 629  */
 630 static int vms_split_path
 631    (const char * path,
 632     char * * volume,
 633     int * vol_len,
 634     char * * root,
 635     int * root_len,
 636     char * * dir,
 637     int * dir_len,
 638     char * * name,
 639     int * name_len,
 640     char * * ext,
 641     int * ext_len,
 642     char * * version,
 643     int * ver_len)
 644 {
 645 struct dsc$descriptor path_desc;
 646 int status;
 647 unsigned long flags;
 648 int ret_stat;
 649 struct filescan_itmlst_2 item_list[9];
 650 const int filespec = 0;
 651 const int nodespec = 1;
 652 const int devspec = 2;
 653 const int rootspec = 3;
 654 const int dirspec = 4;
 655 const int namespec = 5;
 656 const int typespec = 6;
 657 const int verspec = 7;
 658
 659     /* Assume the worst for an easy exit */
 660     ret_stat = -1;
 661     *volume = NULL;
 662     *vol_len = 0;
 663     *root = NULL;
 664     *root_len = 0;
 665     *dir = NULL;
 666     *dir_len;
 667     *name = NULL;
 668     *name_len = 0;
 669     *ext = NULL;
 670     *ext_len = 0;
 671     *version = NULL;
 672     *ver_len = 0;
 673
 674     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 675     path_desc.dsc$w_length = strlen(path);
 676     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 677     path_desc.dsc$b_class = DSC$K_CLASS_S;
 678
 679     /* Get the total length, if it is shorter than the string passed
 680      * then this was probably not a VMS formatted file specification
 681      */
 682     item_list[filespec].itmcode = FSCN$_FILESPEC;
 683     item_list[filespec].length = 0;
 684     item_list[filespec].component = NULL;
 685
 686     /* If the node is present, then it gets considered as part of the
 687      * volume name to hopefully make things simple.
 688      */
 689     item_list[nodespec].itmcode = FSCN$_NODE;
 690     item_list[nodespec].length = 0;
 691     item_list[nodespec].component = NULL;
 692
 693     item_list[devspec].itmcode = FSCN$_DEVICE;
 694     item_list[devspec].length = 0;
 695     item_list[devspec].component = NULL;
 696
 697     /* root is a special case,  adding it to either the directory or
 698      * the device components will probalby complicate things for the
 699      * callers of this routine, so leave it separate.
 700      */
 701     item_list[rootspec].itmcode = FSCN$_ROOT;
 702     item_list[rootspec].length = 0;
 703     item_list[rootspec].component = NULL;
 704
 705     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 706     item_list[dirspec].length = 0;
 707     item_list[dirspec].component = NULL;
 708
 709     item_list[namespec].itmcode = FSCN$_NAME;
 710     item_list[namespec].length = 0;
 711     item_list[namespec].component = NULL;
 712
 713     item_list[typespec].itmcode = FSCN$_TYPE;
 714     item_list[typespec].length = 0;
 715     item_list[typespec].component = NULL;
 716
 717     item_list[verspec].itmcode = FSCN$_VERSION;
 718     item_list[verspec].length = 0;
 719     item_list[verspec].component = NULL;
 720
 721     item_list[8].itmcode = 0;
 722     item_list[8].length = 0;
 723     item_list[8].component = NULL;
 724
 725     status = SYS$FILESCAN
 726        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 727         &flags, NULL, NULL);
 728     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 729
 730     /* If we parsed it successfully these two lengths should be the same */
 731     if (path_desc.dsc$w_length != item_list[filespec].length)
 732         return ret_stat;
 733
 734     /* If we got here, then it is a VMS file specification */
 735     ret_stat = 0;
 736
 737     /* set the volume name */
 738     if (item_list[nodespec].length > 0) {
 739         *volume = item_list[nodespec].component;
 740         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 741     }
 742     else {
 743         *volume = item_list[devspec].component;
 744         *vol_len = item_list[devspec].length;
 745     }
 746
 747     *root = item_list[rootspec].component;
 748     *root_len = item_list[rootspec].length;
 749
 750     *dir = item_list[dirspec].component;
 751     *dir_len = item_list[dirspec].length;
 752
 753     /* Now fun with versions and EFS file specifications
 754      * The parser can not tell the difference when a "." is a version
 755      * delimiter or a part of the file specification.
 756      */
 757     if ((decc_efs_charset) &&
 758         (item_list[verspec].length > 0) &&
 759         (item_list[verspec].component[0] == '.')) {
 760         *name = item_list[namespec].component;
 761         *name_len = item_list[namespec].length + item_list[typespec].length;
 762         *ext = item_list[verspec].component;
 763         *ext_len = item_list[verspec].length;
 764         *version = NULL;
 765         *ver_len = 0;
 766     }
 767     else {
 768         *name = item_list[namespec].component;
 769         *name_len = item_list[namespec].length;
 770         *ext = item_list[typespec].component;
 771         *ext_len = item_list[typespec].length;
 772         *version = item_list[verspec].component;
 773         *ver_len = item_list[verspec].length;
 774     }
 775     return ret_stat;
 776 }
 777
 778
 779 /* my_maxidx
 780  * Routine to retrieve the maximum equivalence index for an input
 781  * logical name.  Some calls to this routine have no knowledge if
 782  * the variable is a logical or not.  So on error we return a max
 783  * index of zero.
 784  */
 785 /*{{{int my_maxidx(const char *lnm) */
 786 static int
 787 my_maxidx(const char *lnm)
 788 {
 789     int status;
 790     int midx;
 791     int attr = LNM$M_CASE_BLIND;
 792     struct dsc$descriptor lnmdsc;
 793     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 794                                 {0, 0, 0, 0}};
 795
 796     lnmdsc.dsc$w_length = strlen(lnm);
 797     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 798     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 799     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 800
 801     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 802     if ((status & 1) == 0)
 803        midx = 0;
 804
 805     return (midx);
 806 }
 807 /*}}}*/
 808
 809 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 810 int
 811 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 812   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 813 {
 814     const char *cp1;
 815     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 816     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 817     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 818     int midx;
 819     unsigned char acmode;
 820     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 821                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 822     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 823                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 824                                  {0, 0, 0, 0}};
 825     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 826 #if defined(PERL_IMPLICIT_CONTEXT)
 827     pTHX = NULL;
 828     if (PL_curinterp) {
 829       aTHX = PERL_GET_INTERP;
 830     } else {
 831       aTHX = NULL;
 832     }
 833 #endif
 834
 835     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 836       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 837     }
 838     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 839       *cp2 = _toupper(*cp1);
 840       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 841         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 842         return 0;
 843       }
 844     }
 845     lnmdsc.dsc$w_length = cp1 - lnm;
 846     lnmdsc.dsc$a_pointer = uplnm;
 847     uplnm[lnmdsc.dsc$w_length] = '\0';
 848     secure = flags & PERL__TRNENV_SECURE;
 849     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 850     if (!tabvec || !*tabvec) tabvec = env_tables;
 851
 852     for (curtab = 0; tabvec[curtab]; curtab++) {
 853       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 854         if (!ivenv && !secure) {
 855           char *eq, *end;
 856           int i;
 857           if (!environ) {
 858             ivenv = 1;
 859             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 860             continue;
 861           }
 862           retsts = SS$_NOLOGNAM;
 863           for (i = 0; environ[i]; i++) {
 864             if ((eq = strchr(environ[i],'=')) &&
 865                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 866                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 867               eq++;
 868               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 869               if (!eqvlen) continue;
 870               retsts = SS$_NORMAL;
 871               break;
 872             }
 873           }
 874           if (retsts != SS$_NOLOGNAM) break;
 875         }
 876       }
 877       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 878                !str$case_blind_compare(&tmpdsc,&clisym)) {
 879         if (!ivsym && !secure) {
 880           unsigned short int deflen = LNM$C_NAMLENGTH;
 881           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 882           /* dynamic dsc to accomodate possible long value */
 883           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 884           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 885           if (retsts & 1) {
 886             if (eqvlen > MAX_DCL_SYMBOL) {
 887               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 888               eqvlen = MAX_DCL_SYMBOL;
 889               /* Special hack--we might be called before the interpreter's */
 890               /* fully initialized, in which case either thr or PL_curcop */
 891               /* might be bogus. We have to check, since ckWARN needs them */
 892               /* both to be valid if running threaded */
 893                 if (ckWARN(WARN_MISC)) {
 894                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 895                 }
 896             }
 897             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 898           }
 899           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 900           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 901           if (retsts == LIB$_NOSUCHSYM) continue;
 902           break;
 903         }
 904       }
 905       else if (!ivlnm) {
 906         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 907           midx = my_maxidx(lnm);
 908           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 909             lnmlst[1].bufadr = cp2;
 910             eqvlen = 0;
 911             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 912             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 913             if (retsts == SS$_NOLOGNAM) break;
 914             /* PPFs have a prefix */
 915             if (
 916 #if INTSIZE == 4
 917                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 918 #endif
 919                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 920                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 921                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 922                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 923                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 924               memmove(eqv,eqv+4,eqvlen-4);
 925               eqvlen -= 4;
 926             }
 927             cp2 += eqvlen;
 928             *cp2 = '\0';
 929           }
 930           if ((retsts == SS$_IVLOGNAM) ||
 931               (retsts == SS$_NOLOGNAM)) { continue; }
 932         }
 933         else {
 934           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 935           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 936           if (retsts == SS$_NOLOGNAM) continue;
 937           eqv[eqvlen] = '\0';
 938         }
 939         eqvlen = strlen(eqv);
 940         break;
 941       }
 942     }
 943     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 944     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 945              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 946              retsts == SS$_NOLOGNAM) {
 947       set_errno(EINVAL);  set_vaxc_errno(retsts);
 948     }
 949     else _ckvmssts(retsts);
 950     return 0;
 951 }  /* end of vmstrnenv */
 952 /*}}}*/
 953
 954 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 955 /* Define as a function so we can access statics. */
 956 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 957 {
 958   return vmstrnenv(lnm,eqv,idx,fildev,
 959 #ifdef SECURE_INTERNAL_GETENV
 960                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 961 #else
 962                    0
 963 #endif
 964                                                                               );
 965 }
 966 /*}}}*/
 967
 968 /* my_getenv
 969  * Note: Uses Perl temp to store result so char * can be returned to
 970  * caller; this pointer will be invalidated at next Perl statement
 971  * transition.
 972  * We define this as a function rather than a macro in terms of my_getenv_len()
 973  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 974  * allocate SVs).
 975  */
 976 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 977 char *
 978 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 979 {
 980     const char *cp1;
 981     static char *__my_getenv_eqv = NULL;
 982     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
 983     unsigned long int idx = 0;
 984     int trnsuccess, success, secure, saverr, savvmserr;
 985     int midx, flags;
 986     SV *tmpsv;
 987
 988     midx = my_maxidx(lnm) + 1;
 989
 990     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 991       /* Set up a temporary buffer for the return value; Perl will
 992        * clean it up at the next statement transition */
 993       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 994       if (!tmpsv) return NULL;
 995       eqv = SvPVX(tmpsv);
 996     }
 997     else {
 998       /* Assume no interpreter ==> single thread */
 999       if (__my_getenv_eqv != NULL) {
1000         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1001       }
1002       else {
1003         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1004       }
1005       eqv = __my_getenv_eqv;
1006     }
1007
1008     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1009     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1010       int len;
1011       getcwd(eqv,LNM$C_NAMLENGTH);
1012
1013       len = strlen(eqv);
1014
1015       /* Get rid of "000000/ in rooted filespecs */
1016       if (len > 7) {
1017         char * zeros;
1018         zeros = strstr(eqv, "/000000/");
1019         if (zeros != NULL) {
1020           int mlen;
1021           mlen = len - (zeros - eqv) - 7;
1022           memmove(zeros, &zeros[7], mlen);
1023           len = len - 7;
1024           eqv[len] = '\0';
1025         }
1026       }
1027       return eqv;
1028     }
1029     else {
1030       /* Impose security constraints only if tainting */
1031       if (sys) {
1032         /* Impose security constraints only if tainting */
1033         secure = PL_curinterp ? PL_tainting : will_taint;
1034         saverr = errno;  savvmserr = vaxc$errno;
1035       }
1036       else {
1037         secure = 0;
1038       }
1039
1040       flags =
1041 #ifdef SECURE_INTERNAL_GETENV
1042               secure ? PERL__TRNENV_SECURE : 0
1043 #else
1044               0
1045 #endif
1046       ;
1047
1048       /* For the getenv interface we combine all the equivalence names
1049        * of a search list logical into one value to acquire a maximum
1050        * value length of 255*128 (assuming %ENV is using logicals).
1051        */
1052       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1053
1054       /* If the name contains a semicolon-delimited index, parse it
1055        * off and make sure we only retrieve the equivalence name for
1056        * that index.  */
1057       if ((cp2 = strchr(lnm,';')) != NULL) {
1058         strcpy(uplnm,lnm);
1059         uplnm[cp2-lnm] = '\0';
1060         idx = strtoul(cp2+1,NULL,0);
1061         lnm = uplnm;
1062         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1063       }
1064
1065       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1066
1067       /* Discard NOLOGNAM on internal calls since we're often looking
1068        * for an optional name, and this "error" often shows up as the
1069        * (bogus) exit status for a die() call later on.  */
1070       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1071       return success ? eqv : Nullch;
1072     }
1073
1074 }  /* end of my_getenv() */
1075 /*}}}*/
1076
1077
1078 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1079 char *
1080 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1081 {
1082     const char *cp1;
1083     char *buf, *cp2;
1084     unsigned long idx = 0;
1085     int midx, flags;
1086     static char *__my_getenv_len_eqv = NULL;
1087     int secure, saverr, savvmserr;
1088     SV *tmpsv;
1089
1090     midx = my_maxidx(lnm) + 1;
1091
1092     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1093       /* Set up a temporary buffer for the return value; Perl will
1094        * clean it up at the next statement transition */
1095       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1096       if (!tmpsv) return NULL;
1097       buf = SvPVX(tmpsv);
1098     }
1099     else {
1100       /* Assume no interpreter ==> single thread */
1101       if (__my_getenv_len_eqv != NULL) {
1102         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1103       }
1104       else {
1105         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1106       }
1107       buf = __my_getenv_len_eqv;
1108     }
1109
1110     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1111     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1112     char * zeros;
1113
1114       getcwd(buf,LNM$C_NAMLENGTH);
1115       *len = strlen(buf);
1116
1117       /* Get rid of "000000/ in rooted filespecs */
1118       if (*len > 7) {
1119       zeros = strstr(buf, "/000000/");
1120       if (zeros != NULL) {
1121         int mlen;
1122         mlen = *len - (zeros - buf) - 7;
1123         memmove(zeros, &zeros[7], mlen);
1124         *len = *len - 7;
1125         buf[*len] = '\0';
1126         }
1127       }
1128       return buf;
1129     }
1130     else {
1131       if (sys) {
1132         /* Impose security constraints only if tainting */
1133         secure = PL_curinterp ? PL_tainting : will_taint;
1134         saverr = errno;  savvmserr = vaxc$errno;
1135       }
1136       else {
1137         secure = 0;
1138       }
1139
1140       flags =
1141 #ifdef SECURE_INTERNAL_GETENV
1142               secure ? PERL__TRNENV_SECURE : 0
1143 #else
1144               0
1145 #endif
1146       ;
1147
1148       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1149
1150       if ((cp2 = strchr(lnm,';')) != NULL) {
1151         strcpy(buf,lnm);
1152         buf[cp2-lnm] = '\0';
1153         idx = strtoul(cp2+1,NULL,0);
1154         lnm = buf;
1155         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1156       }
1157
1158       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1159
1160       /* Get rid of "000000/ in rooted filespecs */
1161       if (*len > 7) {
1162       char * zeros;
1163         zeros = strstr(buf, "/000000/");
1164         if (zeros != NULL) {
1165           int mlen;
1166           mlen = *len - (zeros - buf) - 7;
1167           memmove(zeros, &zeros[7], mlen);
1168           *len = *len - 7;
1169           buf[*len] = '\0';
1170         }
1171       }
1172
1173       /* Discard NOLOGNAM on internal calls since we're often looking
1174        * for an optional name, and this "error" often shows up as the
1175        * (bogus) exit status for a die() call later on.  */
1176       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1177       return *len ? buf : Nullch;
1178     }
1179
1180 }  /* end of my_getenv_len() */
1181 /*}}}*/
1182
1183 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1184
1185 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1186
1187 /*{{{ void prime_env_iter() */
1188 void
1189 prime_env_iter(void)
1190 /* Fill the %ENV associative array with all logical names we can
1191  * find, in preparation for iterating over it.
1192  */
1193 {
1194   static int primed = 0;
1195   HV *seenhv = NULL, *envhv;
1196   SV *sv = NULL;
1197   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1198   unsigned short int chan;
1199 #ifndef CLI$M_TRUSTED
1200 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1201 #endif
1202   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1203   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1204   long int i;
1205   bool have_sym = FALSE, have_lnm = FALSE;
1206   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1207   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1208   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1209   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1210   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1211 #if defined(PERL_IMPLICIT_CONTEXT)
1212   pTHX;
1213 #endif
1214 #if defined(USE_ITHREADS)
1215   static perl_mutex primenv_mutex;
1216   MUTEX_INIT(&primenv_mutex);
1217 #endif
1218
1219 #if defined(PERL_IMPLICIT_CONTEXT)
1220     /* We jump through these hoops because we can be called at */
1221     /* platform-specific initialization time, which is before anything is */
1222     /* set up--we can't even do a plain dTHX since that relies on the */
1223     /* interpreter structure to be initialized */
1224     if (PL_curinterp) {
1225       aTHX = PERL_GET_INTERP;
1226     } else {
1227       aTHX = NULL;
1228     }
1229 #endif
1230
1231   if (primed || !PL_envgv) return;
1232   MUTEX_LOCK(&primenv_mutex);
1233   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1234   envhv = GvHVn(PL_envgv);
1235   /* Perform a dummy fetch as an lval to insure that the hash table is
1236    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1237   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1238
1239   for (i = 0; env_tables[i]; i++) {
1240      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1241          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1242      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1243   }
1244   if (have_sym || have_lnm) {
1245     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1246     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1247     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1248     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1249   }
1250
1251   for (i--; i >= 0; i--) {
1252     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1253       char *start;
1254       int j;
1255       for (j = 0; environ[j]; j++) {
1256         if (!(start = strchr(environ[j],'='))) {
1257           if (ckWARN(WARN_INTERNAL))
1258             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1259         }
1260         else {
1261           start++;
1262           sv = newSVpv(start,0);
1263           SvTAINTED_on(sv);
1264           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1265         }
1266       }
1267       continue;
1268     }
1269     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1270              !str$case_blind_compare(&tmpdsc,&clisym)) {
1271       strcpy(cmd,"Show Symbol/Global *");
1272       cmddsc.dsc$w_length = 20;
1273       if (env_tables[i]->dsc$w_length == 12 &&
1274           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1275           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1276       flags = defflags | CLI$M_NOLOGNAM;
1277     }
1278     else {
1279       strcpy(cmd,"Show Logical *");
1280       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1281         strcat(cmd," /Table=");
1282         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1283         cmddsc.dsc$w_length = strlen(cmd);
1284       }
1285       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1286       flags = defflags | CLI$M_NOCLISYM;
1287     }
1288
1289     /* Create a new subprocess to execute each command, to exclude the
1290      * remote possibility that someone could subvert a mbx or file used
1291      * to write multiple commands to a single subprocess.
1292      */
1293     do {
1294       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1295                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1296       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1297       defflags &= ~CLI$M_TRUSTED;
1298     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1299     _ckvmssts(retsts);
1300     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1301     if (seenhv) SvREFCNT_dec(seenhv);
1302     seenhv = newHV();
1303     while (1) {
1304       char *cp1, *cp2, *key;
1305       unsigned long int sts, iosb[2], retlen, keylen;
1306       register U32 hash;
1307
1308       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1309       if (sts & 1) sts = iosb[0] & 0xffff;
1310       if (sts == SS$_ENDOFFILE) {
1311         int wakect = 0;
1312         while (substs == 0) { sys$hiber(); wakect++;}
1313         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1314         _ckvmssts(substs);
1315         break;
1316       }
1317       _ckvmssts(sts);
1318       retlen = iosb[0] >> 16;
1319       if (!retlen) continue;  /* blank line */
1320       buf[retlen] = '\0';
1321       if (iosb[1] != subpid) {
1322         if (iosb[1]) {
1323           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1324         }
1325         continue;
1326       }
1327       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1328         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1329
1330       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1331       if (*cp1 == '(' || /* Logical name table name */
1332           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1333       if (*cp1 == '"') cp1++;
1334       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1335       key = cp1;  keylen = cp2 - cp1;
1336       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1337       while (*cp2 && *cp2 != '=') cp2++;
1338       while (*cp2 && *cp2 == '=') cp2++;
1339       while (*cp2 && *cp2 == ' ') cp2++;
1340       if (*cp2 == '"') {  /* String translation; may embed "" */
1341         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1342         cp2++;  cp1--; /* Skip "" surrounding translation */
1343       }
1344       else {  /* Numeric translation */
1345         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1346         cp1--;  /* stop on last non-space char */
1347       }
1348       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1349         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1350         continue;
1351       }
1352       PERL_HASH(hash,key,keylen);
1353
1354       if (cp1 == cp2 && *cp2 == '.') {
1355         /* A single dot usually means an unprintable character, such as a null
1356          * to indicate a zero-length value.  Get the actual value to make sure.
1357          */
1358         char lnm[LNM$C_NAMLENGTH+1];
1359         char eqv[MAX_DCL_SYMBOL+1];
1360         strncpy(lnm, key, keylen);
1361         int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1362         sv = newSVpvn(eqv, strlen(eqv));
1363       }
1364       else {
1365         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1366       }
1367
1368       SvTAINTED_on(sv);
1369       hv_store(envhv,key,keylen,sv,hash);
1370       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1371     }
1372     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1373       /* get the PPFs for this process, not the subprocess */
1374       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1375       char eqv[LNM$C_NAMLENGTH+1];
1376       int trnlen, i;
1377       for (i = 0; ppfs[i]; i++) {
1378         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1379         sv = newSVpv(eqv,trnlen);
1380         SvTAINTED_on(sv);
1381         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1382       }
1383     }
1384   }
1385   primed = 1;
1386   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1387   if (buf) Safefree(buf);
1388   if (seenhv) SvREFCNT_dec(seenhv);
1389   MUTEX_UNLOCK(&primenv_mutex);
1390   return;
1391
1392 }  /* end of prime_env_iter */
1393 /*}}}*/
1394
1395
1396 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1397 /* Define or delete an element in the same "environment" as
1398  * vmstrnenv().  If an element is to be deleted, it's removed from
1399  * the first place it's found.  If it's to be set, it's set in the
1400  * place designated by the first element of the table vector.
1401  * Like setenv() returns 0 for success, non-zero on error.
1402  */
1403 int
1404 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1405 {
1406     const char *cp1;
1407     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1408     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1409     int nseg = 0, j;
1410     unsigned long int retsts, usermode = PSL$C_USER;
1411     struct itmlst_3 *ile, *ilist;
1412     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1413                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1414                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1415     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1416     $DESCRIPTOR(local,"_LOCAL");
1417
1418     if (!lnm) {
1419         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1420         return SS$_IVLOGNAM;
1421     }
1422
1423     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1424       *cp2 = _toupper(*cp1);
1425       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1426         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1427         return SS$_IVLOGNAM;
1428       }
1429     }
1430     lnmdsc.dsc$w_length = cp1 - lnm;
1431     if (!tabvec || !*tabvec) tabvec = env_tables;
1432
1433     if (!eqv) {  /* we're deleting n element */
1434       for (curtab = 0; tabvec[curtab]; curtab++) {
1435         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1436         int i;
1437           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1438             if ((cp1 = strchr(environ[i],'=')) &&
1439                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1440                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1441 #ifdef HAS_SETENV
1442               return setenv(lnm,"",1) ? vaxc$errno : 0;
1443             }
1444           }
1445           ivenv = 1; retsts = SS$_NOLOGNAM;
1446 #else
1447               if (ckWARN(WARN_INTERNAL))
1448                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1449               ivenv = 1; retsts = SS$_NOSUCHPGM;
1450               break;
1451             }
1452           }
1453 #endif
1454         }
1455         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1456                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1457           unsigned int symtype;
1458           if (tabvec[curtab]->dsc$w_length == 12 &&
1459               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1460               !str$case_blind_compare(&tmpdsc,&local))
1461             symtype = LIB$K_CLI_LOCAL_SYM;
1462           else symtype = LIB$K_CLI_GLOBAL_SYM;
1463           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1464           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1465           if (retsts == LIB$_NOSUCHSYM) continue;
1466           break;
1467         }
1468         else if (!ivlnm) {
1469           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1470           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1471           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1472           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1473           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1474         }
1475       }
1476     }
1477     else {  /* we're defining a value */
1478       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1479 #ifdef HAS_SETENV
1480         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1481 #else
1482         if (ckWARN(WARN_INTERNAL))
1483           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1484         retsts = SS$_NOSUCHPGM;
1485 #endif
1486       }
1487       else {
1488         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1489         eqvdsc.dsc$w_length  = strlen(eqv);
1490         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1491             !str$case_blind_compare(&tmpdsc,&clisym)) {
1492           unsigned int symtype;
1493           if (tabvec[0]->dsc$w_length == 12 &&
1494               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1495                !str$case_blind_compare(&tmpdsc,&local))
1496             symtype = LIB$K_CLI_LOCAL_SYM;
1497           else symtype = LIB$K_CLI_GLOBAL_SYM;
1498           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1499         }
1500         else {
1501           if (!*eqv) eqvdsc.dsc$w_length = 1;
1502           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1503
1504             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1505             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1506               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1507                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1508               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1509               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1510             }
1511
1512             Newx(ilist,nseg+1,struct itmlst_3);
1513             ile = ilist;
1514             if (!ile) {
1515               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1516               return SS$_INSFMEM;
1517             }
1518             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1519
1520             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1521               ile->itmcode = LNM$_STRING;
1522               ile->bufadr = c;
1523               if ((j+1) == nseg) {
1524                 ile->buflen = strlen(c);
1525                 /* in case we are truncating one that's too long */
1526                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1527               }
1528               else {
1529                 ile->buflen = LNM$C_NAMLENGTH;
1530               }
1531             }
1532
1533             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1534             Safefree (ilist);
1535           }
1536           else {
1537             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1538           }
1539         }
1540       }
1541     }
1542     if (!(retsts & 1)) {
1543       switch (retsts) {
1544         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1545         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1546           set_errno(EVMSERR); break;
1547         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1548         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1549           set_errno(EINVAL); break;
1550         case SS$_NOPRIV:
1551           set_errno(EACCES); break;
1552         default:
1553           _ckvmssts(retsts);
1554           set_errno(EVMSERR);
1555        }
1556        set_vaxc_errno(retsts);
1557        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1558     }
1559     else {
1560       /* We reset error values on success because Perl does an hv_fetch()
1561        * before each hv_store(), and if the thing we're setting didn't
1562        * previously exist, we've got a leftover error message.  (Of course,
1563        * this fails in the face of
1564        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1565        * in that the error reported in $! isn't spurious,
1566        * but it's right more often than not.)
1567        */
1568       set_errno(0); set_vaxc_errno(retsts);
1569       return 0;
1570     }
1571
1572 }  /* end of vmssetenv() */
1573 /*}}}*/
1574
1575 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1576 /* This has to be a function since there's a prototype for it in proto.h */
1577 void
1578 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1579 {
1580     if (lnm && *lnm) {
1581       int len = strlen(lnm);
1582       if  (len == 7) {
1583         char uplnm[8];
1584         int i;
1585         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1586         if (!strcmp(uplnm,"DEFAULT")) {
1587           if (eqv && *eqv) my_chdir(eqv);
1588           return;
1589         }
1590     }
1591 #ifndef RTL_USES_UTC
1592     if (len == 6 || len == 2) {
1593       char uplnm[7];
1594       int i;
1595       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1596       uplnm[len] = '\0';
1597       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1598       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1599     }
1600 #endif
1601   }
1602   (void) vmssetenv(lnm,eqv,NULL);
1603 }
1604 /*}}}*/
1605
1606 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1607 /*  vmssetuserlnm
1608  *  sets a user-mode logical in the process logical name table
1609  *  used for redirection of sys$error
1610  */
1611 void
1612 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1613 {
1614     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1615     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1616     unsigned long int iss, attr = LNM$M_CONFINE;
1617     unsigned char acmode = PSL$C_USER;
1618     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1619                                  {0, 0, 0, 0}};
1620     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1621     d_name.dsc$w_length = strlen(name);
1622
1623     lnmlst[0].buflen = strlen(eqv);
1624     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1625
1626     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1627     if (!(iss&1)) lib$signal(iss);
1628 }
1629 /*}}}*/
1630
1631
1632 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1633 /* my_crypt - VMS password hashing
1634  * my_crypt() provides an interface compatible with the Unix crypt()
1635  * C library function, and uses sys$hash_password() to perform VMS
1636  * password hashing.  The quadword hashed password value is returned
1637  * as a NUL-terminated 8 character string.  my_crypt() does not change
1638  * the case of its string arguments; in order to match the behavior
1639  * of LOGINOUT et al., alphabetic characters in both arguments must
1640  *  be upcased by the caller.
1641  *
1642  * - fix me to call ACM services when available
1643  */
1644 char *
1645 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1646 {
1647 #   ifndef UAI$C_PREFERRED_ALGORITHM
1648 #     define UAI$C_PREFERRED_ALGORITHM 127
1649 #   endif
1650     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1651     unsigned short int salt = 0;
1652     unsigned long int sts;
1653     struct const_dsc {
1654         unsigned short int dsc$w_length;
1655         unsigned char      dsc$b_type;
1656         unsigned char      dsc$b_class;
1657         const char *       dsc$a_pointer;
1658     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1659        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1660     struct itmlst_3 uailst[3] = {
1661         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1662         { sizeof salt, UAI$_SALT,    &salt, 0},
1663         { 0,           0,            NULL,  NULL}};
1664     static char hash[9];
1665
1666     usrdsc.dsc$w_length = strlen(usrname);
1667     usrdsc.dsc$a_pointer = usrname;
1668     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1669       switch (sts) {
1670         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1671           set_errno(EACCES);
1672           break;
1673         case RMS$_RNF:
1674           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1675           break;
1676         default:
1677           set_errno(EVMSERR);
1678       }
1679       set_vaxc_errno(sts);
1680       if (sts != RMS$_RNF) return NULL;
1681     }
1682
1683     txtdsc.dsc$w_length = strlen(textpasswd);
1684     txtdsc.dsc$a_pointer = textpasswd;
1685     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1686       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1687     }
1688
1689     return (char *) hash;
1690
1691 }  /* end of my_crypt() */
1692 /*}}}*/
1693
1694
1695 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1696 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1697 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1698
1699 /* fixup barenames that are directories for internal use.
1700  * There have been problems with the consistent handling of UNIX
1701  * style directory names when routines are presented with a name that
1702  * has no directory delimitors at all.  So this routine will eventually
1703  * fix the issue.
1704  */
1705 static char * fixup_bare_dirnames(const char * name)
1706 {
1707   if (decc_disable_to_vms_logname_translation) {
1708 /* fix me */
1709   }
1710   return NULL;
1711 }
1712
1713 /* mp_do_kill_file
1714  * A little hack to get around a bug in some implemenation of remove()
1715  * that do not know how to delete a directory
1716  *
1717  * Delete any file to which user has control access, regardless of whether
1718  * delete access is explicitly allowed.
1719  * Limitations: User must have write access to parent directory.
1720  *              Does not block signals or ASTs; if interrupted in midstream
1721  *              may leave file with an altered ACL.
1722  * HANDLE WITH CARE!
1723  */
1724 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1725 static int
1726 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1727 {
1728     char *vmsname, *rspec;
1729     char *remove_name;
1730     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1731     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1732     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1733     struct myacedef {
1734       unsigned char myace$b_length;
1735       unsigned char myace$b_type;
1736       unsigned short int myace$w_flags;
1737       unsigned long int myace$l_access;
1738       unsigned long int myace$l_ident;
1739     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1740                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1741       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1742      struct itmlst_3
1743        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1744                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1745        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1746        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1747        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1748        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1749
1750     /* Expand the input spec using RMS, since the CRTL remove() and
1751      * system services won't do this by themselves, so we may miss
1752      * a file "hiding" behind a logical name or search list. */
1753     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1754     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1755
1756     if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1757       PerlMem_free(vmsname);
1758       return -1;
1759     }
1760
1761     if (decc_posix_compliant_pathnames) {
1762       /* In POSIX mode, we prefer to remove the UNIX name */
1763       rspec = vmsname;
1764       remove_name = (char *)name;
1765     }
1766     else {
1767       rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1768       if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1769       if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1770         PerlMem_free(rspec);
1771         PerlMem_free(vmsname);
1772         return -1;
1773       }
1774       PerlMem_free(vmsname);
1775       remove_name = rspec;
1776     }
1777
1778 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1779     if (dirflag != 0) {
1780         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1781           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1782           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1783
1784           do_pathify_dirspec(name, remove_name, 0, NULL);
1785           if (!rmdir(remove_name)) {
1786
1787             PerlMem_free(remove_name);
1788             PerlMem_free(rspec);
1789             return 0;   /* Can we just get rid of it? */
1790           }
1791         }
1792         else {
1793           if (!rmdir(remove_name)) {
1794             PerlMem_free(rspec);
1795             return 0;   /* Can we just get rid of it? */
1796           }
1797         }
1798     }
1799     else
1800 #endif
1801       if (!remove(remove_name)) {
1802         PerlMem_free(rspec);
1803         return 0;   /* Can we just get rid of it? */
1804       }
1805
1806     /* If not, can changing protections help? */
1807     if (vaxc$errno != RMS$_PRV) {
1808       PerlMem_free(rspec);
1809       return -1;
1810     }
1811
1812     /* No, so we get our own UIC to use as a rights identifier,
1813      * and the insert an ACE at the head of the ACL which allows us
1814      * to delete the file.
1815      */
1816     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1817     fildsc.dsc$w_length = strlen(rspec);
1818     fildsc.dsc$a_pointer = rspec;
1819     cxt = 0;
1820     newace.myace$l_ident = oldace.myace$l_ident;
1821     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1822       switch (aclsts) {
1823         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1824           set_errno(ENOENT); break;
1825         case RMS$_DIR:
1826           set_errno(ENOTDIR); break;
1827         case RMS$_DEV:
1828           set_errno(ENODEV); break;
1829         case RMS$_SYN: case SS$_INVFILFOROP:
1830           set_errno(EINVAL); break;
1831         case RMS$_PRV:
1832           set_errno(EACCES); break;
1833         default:
1834           _ckvmssts(aclsts);
1835       }
1836       set_vaxc_errno(aclsts);
1837       PerlMem_free(rspec);
1838       return -1;
1839     }
1840     /* Grab any existing ACEs with this identifier in case we fail */
1841     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1842     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1843                     || fndsts == SS$_NOMOREACE ) {
1844       /* Add the new ACE . . . */
1845       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1846         goto yourroom;
1847
1848 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1849       if (dirflag != 0)
1850         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1851           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1852           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1853
1854           do_pathify_dirspec(name, remove_name, 0, NULL);
1855           rmsts = rmdir(remove_name);
1856           PerlMem_free(remove_name);
1857         }
1858         else {
1859         rmsts = rmdir(remove_name);
1860         }
1861       else
1862 #endif
1863         rmsts = remove(remove_name);
1864       if (rmsts) {
1865         /* We blew it - dir with files in it, no write priv for
1866          * parent directory, etc.  Put things back the way they were. */
1867         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1868           goto yourroom;
1869         if (fndsts & 1) {
1870           addlst[0].bufadr = &oldace;
1871           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1872             goto yourroom;
1873         }
1874       }
1875     }
1876
1877     yourroom:
1878     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1879     /* We just deleted it, so of course it's not there.  Some versions of
1880      * VMS seem to return success on the unlock operation anyhow (after all
1881      * the unlock is successful), but others don't.
1882      */
1883     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1884     if (aclsts & 1) aclsts = fndsts;
1885     if (!(aclsts & 1)) {
1886       set_errno(EVMSERR);
1887       set_vaxc_errno(aclsts);
1888       PerlMem_free(rspec);
1889       return -1;
1890     }
1891
1892     PerlMem_free(rspec);
1893     return rmsts;
1894
1895 }  /* end of kill_file() */
1896 /*}}}*/
1897
1898
1899 /*{{{int do_rmdir(char *name)*/
1900 int
1901 Perl_do_rmdir(pTHX_ const char *name)
1902 {
1903     char dirfile[NAM$C_MAXRSS+1];
1904     int retval;
1905     Stat_t st;
1906
1907     if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1908     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1909     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1910     return retval;
1911
1912 }  /* end of do_rmdir */
1913 /*}}}*/
1914
1915 /* kill_file
1916  * Delete any file to which user has control access, regardless of whether
1917  * delete access is explicitly allowed.
1918  * Limitations: User must have write access to parent directory.
1919  *              Does not block signals or ASTs; if interrupted in midstream
1920  *              may leave file with an altered ACL.
1921  * HANDLE WITH CARE!
1922  */
1923 /*{{{int kill_file(char *name)*/
1924 int
1925 Perl_kill_file(pTHX_ const char *name)
1926 {
1927     char rspec[NAM$C_MAXRSS+1];
1928     char *tspec;
1929     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1930     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1931     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1932     struct myacedef {
1933       unsigned char myace$b_length;
1934       unsigned char myace$b_type;
1935       unsigned short int myace$w_flags;
1936       unsigned long int myace$l_access;
1937       unsigned long int myace$l_ident;
1938     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1939                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1940       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1941      struct itmlst_3
1942        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1943                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1944        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1945        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1946        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1947        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1948
1949     /* Expand the input spec using RMS, since the CRTL remove() and
1950      * system services won't do this by themselves, so we may miss
1951      * a file "hiding" behind a logical name or search list. */
1952     tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1953     if (tspec == NULL) return -1;
1954     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1955     /* If not, can changing protections help? */
1956     if (vaxc$errno != RMS$_PRV) return -1;
1957
1958     /* No, so we get our own UIC to use as a rights identifier,
1959      * and the insert an ACE at the head of the ACL which allows us
1960      * to delete the file.
1961      */
1962     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1963     fildsc.dsc$w_length = strlen(rspec);
1964     fildsc.dsc$a_pointer = rspec;
1965     cxt = 0;
1966     newace.myace$l_ident = oldace.myace$l_ident;
1967     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1968       switch (aclsts) {
1969         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1970           set_errno(ENOENT); break;
1971         case RMS$_DIR:
1972           set_errno(ENOTDIR); break;
1973         case RMS$_DEV:
1974           set_errno(ENODEV); break;
1975         case RMS$_SYN: case SS$_INVFILFOROP:
1976           set_errno(EINVAL); break;
1977         case RMS$_PRV:
1978           set_errno(EACCES); break;
1979         default:
1980           _ckvmssts(aclsts);
1981       }
1982       set_vaxc_errno(aclsts);
1983       return -1;
1984     }
1985     /* Grab any existing ACEs with this identifier in case we fail */
1986     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1987     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1988                     || fndsts == SS$_NOMOREACE ) {
1989       /* Add the new ACE . . . */
1990       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1991         goto yourroom;
1992       if ((rmsts = remove(name))) {
1993         /* We blew it - dir with files in it, no write priv for
1994          * parent directory, etc.  Put things back the way they were. */
1995         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1996           goto yourroom;
1997         if (fndsts & 1) {
1998           addlst[0].bufadr = &oldace;
1999           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2000             goto yourroom;
2001         }
2002       }
2003     }
2004
2005     yourroom:
2006     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2007     /* We just deleted it, so of course it's not there.  Some versions of
2008      * VMS seem to return success on the unlock operation anyhow (after all
2009      * the unlock is successful), but others don't.
2010      */
2011     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2012     if (aclsts & 1) aclsts = fndsts;
2013     if (!(aclsts & 1)) {
2014       set_errno(EVMSERR);
2015       set_vaxc_errno(aclsts);
2016       return -1;
2017     }
2018
2019     return rmsts;
2020
2021 }  /* end of kill_file() */
2022 /*}}}*/
2023
2024
2025 /*{{{int my_mkdir(char *,Mode_t)*/
2026 int
2027 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2028 {
2029   STRLEN dirlen = strlen(dir);
2030
2031   /* zero length string sometimes gives ACCVIO */
2032   if (dirlen == 0) return -1;
2033
2034   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2035    * null file name/type.  However, it's commonplace under Unix,
2036    * so we'll allow it for a gain in portability.
2037    */
2038   if (dir[dirlen-1] == '/') {
2039     char *newdir = savepvn(dir,dirlen-1);
2040     int ret = mkdir(newdir,mode);
2041     Safefree(newdir);
2042     return ret;
2043   }
2044   else return mkdir(dir,mode);
2045 }  /* end of my_mkdir */
2046 /*}}}*/
2047
2048 /*{{{int my_chdir(char *)*/
2049 int
2050 Perl_my_chdir(pTHX_ const char *dir)
2051 {
2052   STRLEN dirlen = strlen(dir);
2053
2054   /* zero length string sometimes gives ACCVIO */
2055   if (dirlen == 0) return -1;
2056   const char *dir1;
2057
2058   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2059    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2060    * so that existing scripts do not need to be changed.
2061    */
2062   dir1 = dir;
2063   while ((dirlen > 0) && (*dir1 == ' ')) {
2064     dir1++;
2065     dirlen--;
2066   }
2067
2068   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2069    * that implies
2070    * null file name/type.  However, it's commonplace under Unix,
2071    * so we'll allow it for a gain in portability.
2072    *
2073    * - Preview- '/' will be valid soon on VMS
2074    */
2075   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2076     char *newdir = savepvn(dir1,dirlen-1);
2077     int ret = chdir(newdir);
2078     Safefree(newdir);
2079     return ret;
2080   }
2081   else return chdir(dir1);
2082 }  /* end of my_chdir */
2083 /*}}}*/
2084
2085
2086 /*{{{FILE *my_tmpfile()*/
2087 FILE *
2088 my_tmpfile(void)
2089 {
2090   FILE *fp;
2091   char *cp;
2092
2093   if ((fp = tmpfile())) return fp;
2094
2095   cp = PerlMem_malloc(L_tmpnam+24);
2096   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2097
2098   if (decc_filename_unix_only == 0)
2099     strcpy(cp,"Sys$Scratch:");
2100   else
2101     strcpy(cp,"/tmp/");
2102   tmpnam(cp+strlen(cp));
2103   strcat(cp,".Perltmp");
2104   fp = fopen(cp,"w+","fop=dlt");
2105   PerlMem_free(cp);
2106   return fp;
2107 }
2108 /*}}}*/
2109
2110
2111 #ifndef HOMEGROWN_POSIX_SIGNALS
2112 /*
2113  * The C RTL's sigaction fails to check for invalid signal numbers so we
2114  * help it out a bit.  The docs are correct, but the actual routine doesn't
2115  * do what the docs say it will.
2116  */
2117 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2118 int
2119 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2120                    struct sigaction* oact)
2121 {
2122   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2123         SETERRNO(EINVAL, SS$_INVARG);
2124         return -1;
2125   }
2126   return sigaction(sig, act, oact);
2127 }
2128 /*}}}*/
2129 #endif
2130
2131 #ifdef KILL_BY_SIGPRC
2132 #include <errnodef.h>
2133
2134 /* We implement our own kill() using the undocumented system service
2135    sys$sigprc for one of two reasons:
2136
2137    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2138    target process to do a sys$exit, which usually can't be handled
2139    gracefully...certainly not by Perl and the %SIG{} mechanism.
2140
2141    2.) If the kill() in the CRTL can't be called from a signal
2142    handler without disappearing into the ether, i.e., the signal
2143    it purportedly sends is never trapped. Still true as of VMS 7.3.
2144
2145    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2146    in the target process rather than calling sys$exit.
2147
2148    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2149    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2150    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2151    with condition codes C$_SIG0+nsig*8, catching the exception on the
2152    target process and resignaling with appropriate arguments.
2153
2154    But we don't have that VMS 7.0+ exception handler, so if you
2155    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2156
2157    Also note that SIGTERM is listed in the docs as being "unimplemented",
2158    yet always seems to be signaled with a VMS condition code of 4 (and
2159    correctly handled for that code).  So we hardwire it in.
2160
2161    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2162    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2163    than signalling with an unrecognized (and unhandled by CRTL) code.
2164 */
2165
2166 #define _MY_SIG_MAX 17
2167
2168 static unsigned int
2169 Perl_sig_to_vmscondition_int(int sig)
2170 {
2171     static unsigned int sig_code[_MY_SIG_MAX+1] =
2172     {
2173         0,                  /*  0 ZERO     */
2174         SS$_HANGUP,         /*  1 SIGHUP   */
2175         SS$_CONTROLC,       /*  2 SIGINT   */
2176         SS$_CONTROLY,       /*  3 SIGQUIT  */
2177         SS$_RADRMOD,        /*  4 SIGILL   */
2178         SS$_BREAK,          /*  5 SIGTRAP  */
2179         SS$_OPCCUS,         /*  6 SIGABRT  */
2180         SS$_COMPAT,         /*  7 SIGEMT   */
2181 #ifdef __VAX
2182         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2183 #else
2184         SS$_HPARITH,        /*  8 SIGFPE AXP */
2185 #endif
2186         SS$_ABORT,          /*  9 SIGKILL  */
2187         SS$_ACCVIO,         /* 10 SIGBUS   */
2188         SS$_ACCVIO,         /* 11 SIGSEGV  */
2189         SS$_BADPARAM,       /* 12 SIGSYS   */
2190         SS$_NOMBX,          /* 13 SIGPIPE  */
2191         SS$_ASTFLT,         /* 14 SIGALRM  */
2192         4,                  /* 15 SIGTERM  */
2193         0,                  /* 16 SIGUSR1  */
2194         0                   /* 17 SIGUSR2  */
2195     };
2196
2197 #if __VMS_VER >= 60200000
2198     static int initted = 0;
2199     if (!initted) {
2200         initted = 1;
2201         sig_code[16] = C$_SIGUSR1;
2202         sig_code[17] = C$_SIGUSR2;
2203     }
2204 #endif
2205
2206     if (sig < _SIG_MIN) return 0;
2207     if (sig > _MY_SIG_MAX) return 0;
2208     return sig_code[sig];
2209 }
2210
2211 unsigned int
2212 Perl_sig_to_vmscondition(int sig)
2213 {
2214 #ifdef SS$_DEBUG
2215     if (vms_debug_on_exception != 0)
2216         lib$signal(SS$_DEBUG);
2217 #endif
2218     return Perl_sig_to_vmscondition_int(sig);
2219 }
2220
2221
2222 int
2223 Perl_my_kill(int pid, int sig)
2224 {
2225     dTHX;
2226     int iss;
2227     unsigned int code;
2228     int sys$sigprc(unsigned int *pidadr,
2229                      struct dsc$descriptor_s *prcname,
2230                      unsigned int code);
2231
2232      /* sig 0 means validate the PID */
2233     /*------------------------------*/
2234     if (sig == 0) {
2235         const unsigned long int jpicode = JPI$_PID;
2236         pid_t ret_pid;
2237         int status;
2238         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2239         if ($VMS_STATUS_SUCCESS(status))
2240            return 0;
2241         switch (status) {
2242         case SS$_NOSUCHNODE:
2243         case SS$_UNREACHABLE:
2244         case SS$_NONEXPR:
2245            errno = ESRCH;
2246            break;
2247         case SS$_NOPRIV:
2248            errno = EPERM;
2249            break;
2250         default:
2251            errno = EVMSERR;
2252         }
2253         vaxc$errno=status;
2254         return -1;
2255     }
2256
2257     code = Perl_sig_to_vmscondition_int(sig);
2258
2259     if (!code) {
2260         SETERRNO(EINVAL, SS$_BADPARAM);
2261         return -1;
2262     }
2263
2264     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2265      * signals are to be sent to multiple processes.
2266      *  pid = 0 - all processes in group except ones that the system exempts
2267      *  pid = -1 - all processes except ones that the system exempts
2268      *  pid = -n - all processes in group (abs(n)) except ...
2269      * For now, just report as not supported.
2270      */
2271
2272     if (pid <= 0) {
2273         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2274         return -1;
2275     }
2276
2277     iss = sys$sigprc((unsigned int *)&pid,0,code);
2278     if (iss&1) return 0;
2279
2280     switch (iss) {
2281       case SS$_NOPRIV:
2282         set_errno(EPERM);  break;
2283       case SS$_NONEXPR:
2284       case SS$_NOSUCHNODE:
2285       case SS$_UNREACHABLE:
2286         set_errno(ESRCH);  break;
2287       case SS$_INSFMEM:
2288         set_errno(ENOMEM); break;
2289       default:
2290         _ckvmssts(iss);
2291         set_errno(EVMSERR);
2292     }
2293     set_vaxc_errno(iss);
2294
2295     return -1;
2296 }
2297 #endif
2298
2299 /* Routine to convert a VMS status code to a UNIX status code.
2300 ** More tricky than it appears because of conflicting conventions with
2301 ** existing code.
2302 **
2303 ** VMS status codes are a bit mask, with the least significant bit set for
2304 ** success.
2305 **
2306 ** Special UNIX status of EVMSERR indicates that no translation is currently
2307 ** available, and programs should check the VMS status code.
2308 **
2309 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2310 ** decoding.
2311 */
2312
2313 #ifndef C_FACILITY_NO
2314 #define C_FACILITY_NO 0x350000
2315 #endif
2316 #ifndef DCL_IVVERB
2317 #define DCL_IVVERB 0x38090
2318 #endif
2319
2320 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2321 {
2322 int facility;
2323 int fac_sp;
2324 int msg_no;
2325 int msg_status;
2326 int unix_status;
2327
2328   /* Assume the best or the worst */
2329   if (vms_status & STS$M_SUCCESS)
2330     unix_status = 0;
2331   else
2332     unix_status = EVMSERR;
2333
2334   msg_status = vms_status & ~STS$M_CONTROL;
2335
2336   facility = vms_status & STS$M_FAC_NO;
2337   fac_sp = vms_status & STS$M_FAC_SP;
2338   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2339
2340   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2341     switch(msg_no) {
2342     case SS$_NORMAL:
2343         unix_status = 0;
2344         break;
2345     case SS$_ACCVIO:
2346         unix_status = EFAULT;
2347         break;
2348     case SS$_DEVOFFLINE:
2349         unix_status = EBUSY;
2350         break;
2351     case SS$_CLEARED:
2352         unix_status = ENOTCONN;
2353         break;
2354     case SS$_IVCHAN:
2355     case SS$_IVLOGNAM:
2356     case SS$_BADPARAM:
2357     case SS$_IVLOGTAB:
2358     case SS$_NOLOGNAM:
2359     case SS$_NOLOGTAB:
2360     case SS$_INVFILFOROP:
2361     case SS$_INVARG:
2362     case SS$_NOSUCHID:
2363     case SS$_IVIDENT:
2364         unix_status = EINVAL;
2365         break;
2366     case SS$_UNSUPPORTED:
2367         unix_status = ENOTSUP;
2368         break;
2369     case SS$_FILACCERR:
2370     case SS$_NOGRPPRV:
2371     case SS$_NOSYSPRV:
2372         unix_status = EACCES;
2373         break;
2374     case SS$_DEVICEFULL:
2375         unix_status = ENOSPC;
2376         break;
2377     case SS$_NOSUCHDEV:
2378         unix_status = ENODEV;
2379         break;
2380     case SS$_NOSUCHFILE:
2381     case SS$_NOSUCHOBJECT:
2382         unix_status = ENOENT;
2383         break;
2384     case SS$_ABORT:                                 /* Fatal case */
2385     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2386     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2387         unix_status = EINTR;
2388         break;
2389     case SS$_BUFFEROVF:
2390         unix_status = E2BIG;
2391         break;
2392     case SS$_INSFMEM:
2393         unix_status = ENOMEM;
2394         break;
2395     case SS$_NOPRIV:
2396         unix_status = EPERM;
2397         break;
2398     case SS$_NOSUCHNODE:
2399     case SS$_UNREACHABLE:
2400         unix_status = ESRCH;
2401         break;
2402     case SS$_NONEXPR:
2403         unix_status = ECHILD;
2404         break;
2405     default:
2406         if ((facility == 0) && (msg_no < 8)) {
2407           /* These are not real VMS status codes so assume that they are
2408           ** already UNIX status codes
2409           */
2410           unix_status = msg_no;
2411           break;
2412         }
2413     }
2414   }
2415   else {
2416     /* Translate a POSIX exit code to a UNIX exit code */
2417     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2418         unix_status = (msg_no & 0x07F8) >> 3;
2419     }
2420     else {
2421
2422          /* Documented traditional behavior for handling VMS child exits */
2423         /*--------------------------------------------------------------*/
2424         if (child_flag != 0) {
2425
2426              /* Success / Informational return 0 */
2427             /*----------------------------------*/
2428             if (msg_no & STS$K_SUCCESS)
2429                 return 0;
2430
2431              /* Warning returns 1 */
2432             /*-------------------*/
2433             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2434                 return 1;
2435
2436              /* Everything else pass through the severity bits */
2437             /*------------------------------------------------*/
2438             return (msg_no & STS$M_SEVERITY);
2439         }
2440
2441          /* Normal VMS status to ERRNO mapping attempt */
2442         /*--------------------------------------------*/
2443         switch(msg_status) {
2444         /* case RMS$_EOF: */ /* End of File */
2445         case RMS$_FNF:  /* File Not Found */
2446         case RMS$_DNF:  /* Dir Not Found */
2447                 unix_status = ENOENT;
2448                 break;
2449         case RMS$_RNF:  /* Record Not Found */
2450                 unix_status = ESRCH;
2451                 break;
2452         case RMS$_DIR:
2453                 unix_status = ENOTDIR;
2454                 break;
2455         case RMS$_DEV:
2456                 unix_status = ENODEV;
2457                 break;
2458         case RMS$_IFI:
2459         case RMS$_FAC:
2460         case RMS$_ISI:
2461                 unix_status = EBADF;
2462                 break;
2463         case RMS$_FEX:
2464                 unix_status = EEXIST;
2465                 break;
2466         case RMS$_SYN:
2467         case RMS$_FNM:
2468         case LIB$_INVSTRDES:
2469         case LIB$_INVARG:
2470         case LIB$_NOSUCHSYM:
2471         case LIB$_INVSYMNAM:
2472         case DCL_IVVERB:
2473                 unix_status = EINVAL;
2474                 break;
2475         case CLI$_BUFOVF:
2476         case RMS$_RTB:
2477         case CLI$_TKNOVF:
2478         case CLI$_RSLOVF:
2479                 unix_status = E2BIG;
2480                 break;
2481         case RMS$_PRV:  /* No privilege */
2482         case RMS$_ACC:  /* ACP file access failed */
2483         case RMS$_WLK:  /* Device write locked */
2484                 unix_status = EACCES;
2485                 break;
2486         /* case RMS$_NMF: */  /* No more files */
2487         }
2488     }
2489   }
2490
2491   return unix_status;
2492 }
2493
2494 /* Try to guess at what VMS error status should go with a UNIX errno
2495  * value.  This is hard to do as there could be many possible VMS
2496  * error statuses that caused the errno value to be set.
2497  */
2498
2499 int Perl_unix_status_to_vms(int unix_status)
2500 {
2501 int test_unix_status;
2502
2503      /* Trivial cases first */
2504     /*---------------------*/
2505     if (unix_status == EVMSERR)
2506         return vaxc$errno;
2507
2508      /* Is vaxc$errno sane? */
2509     /*---------------------*/
2510     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2511     if (test_unix_status == unix_status)
2512         return vaxc$errno;
2513
2514      /* If way out of range, must be VMS code already */
2515     /*-----------------------------------------------*/
2516     if (unix_status > EVMSERR)
2517         return unix_status;
2518
2519      /* If out of range, punt */
2520     /*-----------------------*/
2521     if (unix_status > __ERRNO_MAX)
2522         return SS$_ABORT;
2523
2524
2525      /* Ok, now we have to do it the hard way. */
2526     /*----------------------------------------*/
2527     switch(unix_status) {
2528     case 0:     return SS$_NORMAL;
2529     case EPERM: return SS$_NOPRIV;
2530     case ENOENT: return SS$_NOSUCHOBJECT;
2531     case ESRCH: return SS$_UNREACHABLE;
2532     case EINTR: return SS$_ABORT;
2533     /* case EIO: */
2534     /* case ENXIO:  */
2535     case E2BIG: return SS$_BUFFEROVF;
2536     /* case ENOEXEC */
2537     case EBADF: return RMS$_IFI;
2538     case ECHILD: return SS$_NONEXPR;
2539     /* case EAGAIN */
2540     case ENOMEM: return SS$_INSFMEM;
2541     case EACCES: return SS$_FILACCERR;
2542     case EFAULT: return SS$_ACCVIO;
2543     /* case ENOTBLK */
2544     case EBUSY: return SS$_DEVOFFLINE;
2545     case EEXIST: return RMS$_FEX;
2546     /* case EXDEV */
2547     case ENODEV: return SS$_NOSUCHDEV;
2548     case ENOTDIR: return RMS$_DIR;
2549     /* case EISDIR */
2550     case EINVAL: return SS$_INVARG;
2551     /* case ENFILE */
2552     /* case EMFILE */
2553     /* case ENOTTY */
2554     /* case ETXTBSY */
2555     /* case EFBIG */
2556     case ENOSPC: return SS$_DEVICEFULL;
2557     case ESPIPE: return LIB$_INVARG;
2558     /* case EROFS: */
2559     /* case EMLINK: */
2560     /* case EPIPE: */
2561     /* case EDOM */
2562     case ERANGE: return LIB$_INVARG;
2563     /* case EWOULDBLOCK */
2564     /* case EINPROGRESS */
2565     /* case EALREADY */
2566     /* case ENOTSOCK */
2567     /* case EDESTADDRREQ */
2568     /* case EMSGSIZE */
2569     /* case EPROTOTYPE */
2570     /* case ENOPROTOOPT */
2571     /* case EPROTONOSUPPORT */
2572     /* case ESOCKTNOSUPPORT */
2573     /* case EOPNOTSUPP */
2574     /* case EPFNOSUPPORT */
2575     /* case EAFNOSUPPORT */
2576     /* case EADDRINUSE */
2577     /* case EADDRNOTAVAIL */
2578     /* case ENETDOWN */
2579     /* case ENETUNREACH */
2580     /* case ENETRESET */
2581     /* case ECONNABORTED */
2582     /* case ECONNRESET */
2583     /* case ENOBUFS */
2584     /* case EISCONN */
2585     case ENOTCONN: return SS$_CLEARED;
2586     /* case ESHUTDOWN */
2587     /* case ETOOMANYREFS */
2588     /* case ETIMEDOUT */
2589     /* case ECONNREFUSED */
2590     /* case ELOOP */
2591     /* case ENAMETOOLONG */
2592     /* case EHOSTDOWN */
2593     /* case EHOSTUNREACH */
2594     /* case ENOTEMPTY */
2595     /* case EPROCLIM */
2596     /* case EUSERS  */
2597     /* case EDQUOT  */
2598     /* case ENOMSG  */
2599     /* case EIDRM */
2600     /* case EALIGN */
2601     /* case ESTALE */
2602     /* case EREMOTE */
2603     /* case ENOLCK */
2604     /* case ENOSYS */
2605     /* case EFTYPE */
2606     /* case ECANCELED */
2607     /* case EFAIL */
2608     /* case EINPROG */
2609     case ENOTSUP:
2610         return SS$_UNSUPPORTED;
2611     /* case EDEADLK */
2612     /* case ENWAIT */
2613     /* case EILSEQ */
2614     /* case EBADCAT */
2615     /* case EBADMSG */
2616     /* case EABANDONED */
2617     default:
2618         return SS$_ABORT; /* punt */
2619     }
2620
2621   return SS$_ABORT; /* Should not get here */
2622 }
2623
2624
2625 /* default piping mailbox size */
2626 #define PERL_BUFSIZ        512
2627
2628
2629 static void
2630 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2631 {
2632   unsigned long int mbxbufsiz;
2633   static unsigned long int syssize = 0;
2634   unsigned long int dviitm = DVI$_DEVNAM;
2635   char csize[LNM$C_NAMLENGTH+1];
2636   int sts;
2637
2638   if (!syssize) {
2639     unsigned long syiitm = SYI$_MAXBUF;
2640     /*
2641      * Get the SYSGEN parameter MAXBUF
2642      *
2643      * If the logical 'PERL_MBX_SIZE' is defined
2644      * use the value of the logical instead of PERL_BUFSIZ, but
2645      * keep the size between 128 and MAXBUF.
2646      *
2647      */
2648     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2649   }
2650
2651   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2652       mbxbufsiz = atoi(csize);
2653   } else {
2654       mbxbufsiz = PERL_BUFSIZ;
2655   }
2656   if (mbxbufsiz < 128) mbxbufsiz = 128;
2657   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2658
2659   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2660
2661   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2662   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2663
2664 }  /* end of create_mbx() */
2665
2666
2667 /*{{{  my_popen and my_pclose*/
2668
2669 typedef struct _iosb           IOSB;
2670 typedef struct _iosb*         pIOSB;
2671 typedef struct _pipe           Pipe;
2672 typedef struct _pipe*         pPipe;
2673 typedef struct pipe_details    Info;
2674 typedef struct pipe_details*  pInfo;
2675 typedef struct _srqp            RQE;
2676 typedef struct _srqp*          pRQE;
2677 typedef struct _tochildbuf      CBuf;
2678 typedef struct _tochildbuf*    pCBuf;
2679
2680 struct _iosb {
2681     unsigned short status;
2682     unsigned short count;
2683     unsigned long  dvispec;
2684 };
2685
2686 #pragma member_alignment save
2687 #pragma nomember_alignment quadword
2688 struct _srqp {          /* VMS self-relative queue entry */
2689     unsigned long qptr[2];
2690 };
2691 #pragma member_alignment restore
2692 static RQE  RQE_ZERO = {0,0};
2693
2694 struct _tochildbuf {
2695     RQE             q;
2696     int             eof;
2697     unsigned short  size;
2698     char            *buf;
2699 };
2700
2701 struct _pipe {
2702     RQE            free;
2703     RQE            wait;
2704     int            fd_out;
2705     unsigned short chan_in;
2706     unsigned short chan_out;
2707     char          *buf;
2708     unsigned int   bufsize;
2709     IOSB           iosb;
2710     IOSB           iosb2;
2711     int           *pipe_done;
2712     int            retry;
2713     int            type;
2714     int            shut_on_empty;
2715     int            need_wake;
2716     pPipe         *home;
2717     pInfo          info;
2718     pCBuf          curr;
2719     pCBuf          curr2;
2720 #if defined(PERL_IMPLICIT_CONTEXT)
2721     void            *thx;           /* Either a thread or an interpreter */
2722                                     /* pointer, depending on how we're built */
2723 #endif
2724 };
2725
2726
2727 struct pipe_details
2728 {
2729     pInfo           next;
2730     PerlIO *fp;  /* file pointer to pipe mailbox */
2731     int useFILE; /* using stdio, not perlio */
2732     int pid;   /* PID of subprocess */
2733     int mode;  /* == 'r' if pipe open for reading */
2734     int done;  /* subprocess has completed */
2735     int waiting; /* waiting for completion/closure */
2736     int             closing;        /* my_pclose is closing this pipe */
2737     unsigned long   completion;     /* termination status of subprocess */
2738     pPipe           in;             /* pipe in to sub */
2739     pPipe           out;            /* pipe out of sub */
2740     pPipe           err;            /* pipe of sub's sys$error */
2741     int             in_done;        /* true when in pipe finished */
2742     int             out_done;
2743     int             err_done;
2744 };
2745
2746 struct exit_control_block
2747 {
2748     struct exit_control_block *flink;
2749     unsigned long int   (*exit_routine)();
2750     unsigned long int arg_count;
2751     unsigned long int *status_address;
2752     unsigned long int exit_status;
2753 };
2754
2755 typedef struct _closed_pipes    Xpipe;
2756 typedef struct _closed_pipes*  pXpipe;
2757
2758 struct _closed_pipes {
2759     int             pid;            /* PID of subprocess */
2760     unsigned long   completion;     /* termination status of subprocess */
2761 };
2762 #define NKEEPCLOSED 50
2763 static Xpipe closed_list[NKEEPCLOSED];
2764 static int   closed_index = 0;
2765 static int   closed_num = 0;
2766
2767 #define RETRY_DELAY     "0 ::0.20"
2768 #define MAX_RETRY              50
2769
2770 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2771 static unsigned long mypid;
2772 static unsigned long delaytime[2];
2773
2774 static pInfo open_pipes = NULL;
2775 static $DESCRIPTOR(nl_desc, "NL:");
2776
2777 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2778
2779
2780
2781 static unsigned long int
2782 pipe_exit_routine(pTHX)
2783 {
2784     pInfo info;
2785     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2786     int sts, did_stuff, need_eof, j;
2787
2788     /*
2789         flush any pending i/o
2790     */
2791     info = open_pipes;
2792     while (info) {
2793         if (info->fp) {
2794            if (!info->useFILE)
2795                PerlIO_flush(info->fp);   /* first, flush data */
2796            else
2797                fflush((FILE *)info->fp);
2798         }
2799         info = info->next;
2800     }
2801
2802     /*
2803      next we try sending an EOF...ignore if doesn't work, make sure we
2804      don't hang
2805     */
2806     did_stuff = 0;
2807     info = open_pipes;
2808
2809     while (info) {
2810       int need_eof;
2811       _ckvmssts_noperl(sys$setast(0));
2812       if (info->in && !info->in->shut_on_empty) {
2813         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2814                           0, 0, 0, 0, 0, 0));
2815         info->waiting = 1;
2816         did_stuff = 1;
2817       }
2818       _ckvmssts_noperl(sys$setast(1));
2819       info = info->next;
2820     }
2821
2822     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2823
2824     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2825         int nwait = 0;
2826
2827         info = open_pipes;
2828         while (info) {
2829           _ckvmssts_noperl(sys$setast(0));
2830           if (info->waiting && info->done)
2831                 info->waiting = 0;
2832           nwait += info->waiting;
2833           _ckvmssts_noperl(sys$setast(1));
2834           info = info->next;
2835         }
2836         if (!nwait) break;
2837         sleep(1);
2838     }
2839
2840     did_stuff = 0;
2841     info = open_pipes;
2842     while (info) {
2843       _ckvmssts_noperl(sys$setast(0));
2844       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2845         sts = sys$forcex(&info->pid,0,&abort);
2846         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2847         did_stuff = 1;
2848       }
2849       _ckvmssts_noperl(sys$setast(1));
2850       info = info->next;
2851     }
2852
2853     /* again, wait for effect */
2854
2855     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2856         int nwait = 0;
2857
2858         info = open_pipes;
2859         while (info) {
2860           _ckvmssts_noperl(sys$setast(0));
2861           if (info->waiting && info->done)
2862                 info->waiting = 0;
2863           nwait += info->waiting;
2864           _ckvmssts_noperl(sys$setast(1));
2865           info = info->next;
2866         }
2867         if (!nwait) break;
2868         sleep(1);
2869     }
2870
2871     info = open_pipes;
2872     while (info) {
2873       _ckvmssts_noperl(sys$setast(0));
2874       if (!info->done) {  /* We tried to be nice . . . */
2875         sts = sys$delprc(&info->pid,0);
2876         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2877       }
2878       _ckvmssts_noperl(sys$setast(1));
2879       info = info->next;
2880     }
2881
2882     while(open_pipes) {
2883       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2884       else if (!(sts & 1)) retsts = sts;
2885     }
2886     return retsts;
2887 }
2888
2889 static struct exit_control_block pipe_exitblock =
2890        {(struct exit_control_block *) 0,
2891         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2892
2893 static void pipe_mbxtofd_ast(pPipe p);
2894 static void pipe_tochild1_ast(pPipe p);
2895 static void pipe_tochild2_ast(pPipe p);
2896
2897 static void
2898 popen_completion_ast(pInfo info)
2899 {
2900   pInfo i = open_pipes;
2901   int iss;
2902   int sts;
2903   pXpipe x;
2904
2905   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2906   closed_list[closed_index].pid = info->pid;
2907   closed_list[closed_index].completion = info->completion;
2908   closed_index++;
2909   if (closed_index == NKEEPCLOSED)
2910     closed_index = 0;
2911   closed_num++;
2912
2913   while (i) {
2914     if (i == info) break;
2915     i = i->next;
2916   }
2917   if (!i) return;       /* unlinked, probably freed too */
2918
2919   info->done = TRUE;
2920
2921 /*
2922     Writing to subprocess ...
2923             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2924
2925             chan_out may be waiting for "done" flag, or hung waiting
2926             for i/o completion to child...cancel the i/o.  This will
2927             put it into "snarf mode" (done but no EOF yet) that discards
2928             input.
2929
2930     Output from subprocess (stdout, stderr) needs to be flushed and
2931     shut down.   We try sending an EOF, but if the mbx is full the pipe
2932     routine should still catch the "shut_on_empty" flag, telling it to
2933     use immediate-style reads so that "mbx empty" -> EOF.
2934
2935
2936 */
2937   if (info->in && !info->in_done) {               /* only for mode=w */
2938         if (info->in->shut_on_empty && info->in->need_wake) {
2939             info->in->need_wake = FALSE;
2940             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2941         } else {
2942             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2943         }
2944   }
2945
2946   if (info->out && !info->out_done) {             /* were we also piping output? */
2947       info->out->shut_on_empty = TRUE;
2948       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2949       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2950       _ckvmssts_noperl(iss);
2951   }
2952
2953   if (info->err && !info->err_done) {        /* we were piping stderr */
2954         info->err->shut_on_empty = TRUE;
2955         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2956         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2957         _ckvmssts_noperl(iss);
2958   }
2959   _ckvmssts_noperl(sys$setef(pipe_ef));
2960
2961 }
2962
2963 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2964 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2965
2966 /*
2967     we actually differ from vmstrnenv since we use this to
2968     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2969     are pointing to the same thing
2970 */
2971
2972 static unsigned short
2973 popen_translate(pTHX_ char *logical, char *result)
2974 {
2975     int iss;
2976     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2977     $DESCRIPTOR(d_log,"");
2978     struct _il3 {
2979         unsigned short length;
2980         unsigned short code;
2981         char *         buffer_addr;
2982         unsigned short *retlenaddr;
2983     } itmlst[2];
2984     unsigned short l, ifi;
2985
2986     d_log.dsc$a_pointer = logical;
2987     d_log.dsc$w_length  = strlen(logical);
2988
2989     itmlst[0].code = LNM$_STRING;
2990     itmlst[0].length = 255;
2991     itmlst[0].buffer_addr = result;
2992     itmlst[0].retlenaddr = &l;
2993
2994     itmlst[1].code = 0;
2995     itmlst[1].length = 0;
2996     itmlst[1].buffer_addr = 0;
2997     itmlst[1].retlenaddr = 0;
2998
2999     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3000     if (iss == SS$_NOLOGNAM) {
3001         iss = SS$_NORMAL;
3002         l = 0;
3003     }
3004     if (!(iss&1)) lib$signal(iss);
3005     result[l] = '\0';
3006 /*
3007     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3008     strip it off and return the ifi, if any
3009 */
3010     ifi  = 0;
3011     if (result[0] == 0x1b && result[1] == 0x00) {
3012         memmove(&ifi,result+2,2);
3013         strcpy(result,result+4);
3014     }
3015     return ifi;     /* this is the RMS internal file id */
3016 }
3017
3018 static void pipe_infromchild_ast(pPipe p);
3019
3020 /*
3021     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3022     inside an AST routine without worrying about reentrancy and which Perl
3023     memory allocator is being used.
3024
3025     We read data and queue up the buffers, then spit them out one at a
3026     time to the output mailbox when the output mailbox is ready for one.
3027
3028 */
3029 #define INITIAL_TOCHILDQUEUE  2
3030
3031 static pPipe
3032 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3033 {
3034     pPipe p;
3035     pCBuf b;
3036     char mbx1[64], mbx2[64];
3037     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3038                                       DSC$K_CLASS_S, mbx1},
3039                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3040                                       DSC$K_CLASS_S, mbx2};
3041     unsigned int dviitm = DVI$_DEVBUFSIZ;
3042     int j, n;
3043
3044     n = sizeof(Pipe);
3045     _ckvmssts(lib$get_vm(&n, &p));
3046
3047     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3048     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3049     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3050
3051     p->buf           = 0;
3052     p->shut_on_empty = FALSE;
3053     p->need_wake     = FALSE;
3054     p->type          = 0;
3055     p->retry         = 0;
3056     p->iosb.status   = SS$_NORMAL;
3057     p->iosb2.status  = SS$_NORMAL;
3058     p->free          = RQE_ZERO;
3059     p->wait          = RQE_ZERO;
3060     p->curr          = 0;
3061     p->curr2         = 0;
3062     p->info          = 0;
3063 #ifdef PERL_IMPLICIT_CONTEXT
3064     p->thx           = aTHX;
3065 #endif
3066
3067     n = sizeof(CBuf) + p->bufsize;
3068
3069     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3070         _ckvmssts(lib$get_vm(&n, &b));
3071         b->buf = (char *) b + sizeof(CBuf);
3072         _ckvmssts(lib$insqhi(b, &p->free));
3073     }
3074
3075     pipe_tochild2_ast(p);
3076     pipe_tochild1_ast(p);
3077     strcpy(wmbx, mbx1);
3078     strcpy(rmbx, mbx2);
3079     return p;
3080 }
3081
3082 /*  reads the MBX Perl is writing, and queues */
3083
3084 static void
3085 pipe_tochild1_ast(pPipe p)
3086 {
3087     pCBuf b = p->curr;
3088     int iss = p->iosb.status;
3089     int eof = (iss == SS$_ENDOFFILE);
3090     int sts;
3091 #ifdef PERL_IMPLICIT_CONTEXT
3092     pTHX = p->thx;
3093 #endif
3094
3095     if (p->retry) {
3096         if (eof) {
3097             p->shut_on_empty = TRUE;
3098             b->eof     = TRUE;
3099             _ckvmssts(sys$dassgn(p->chan_in));
3100         } else  {
3101             _ckvmssts(iss);
3102         }
3103
3104         b->eof  = eof;
3105         b->size = p->iosb.count;
3106         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3107         if (p->need_wake) {
3108             p->need_wake = FALSE;
3109             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3110         }
3111     } else {
3112         p->retry = 1;   /* initial call */
3113     }
3114
3115     if (eof) {                  /* flush the free queue, return when done */
3116         int n = sizeof(CBuf) + p->bufsize;
3117         while (1) {
3118             iss = lib$remqti(&p->free, &b);
3119             if (iss == LIB$_QUEWASEMP) return;
3120             _ckvmssts(iss);
3121             _ckvmssts(lib$free_vm(&n, &b));
3122         }
3123     }
3124
3125     iss = lib$remqti(&p->free, &b);
3126     if (iss == LIB$_QUEWASEMP) {
3127         int n = sizeof(CBuf) + p->bufsize;
3128         _ckvmssts(lib$get_vm(&n, &b));
3129         b->buf = (char *) b + sizeof(CBuf);
3130     } else {
3131        _ckvmssts(iss);
3132     }
3133
3134     p->curr = b;
3135     iss = sys$qio(0,p->chan_in,
3136              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3137              &p->iosb,
3138              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3139     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3140     _ckvmssts(iss);
3141 }
3142
3143
3144 /* writes queued buffers to output, waits for each to complete before
3145    doing the next */
3146
3147 static void
3148 pipe_tochild2_ast(pPipe p)
3149 {
3150     pCBuf b = p->curr2;
3151     int iss = p->iosb2.status;
3152     int n = sizeof(CBuf) + p->bufsize;
3153     int done = (p->info && p->info->done) ||
3154               iss == SS$_CANCEL || iss == SS$_ABORT;
3155 #if defined(PERL_IMPLICIT_CONTEXT)
3156     pTHX = p->thx;
3157 #endif
3158
3159     do {
3160         if (p->type) {         /* type=1 has old buffer, dispose */
3161             if (p->shut_on_empty) {
3162                 _ckvmssts(lib$free_vm(&n, &b));
3163             } else {
3164                 _ckvmssts(lib$insqhi(b, &p->free));
3165             }
3166             p->type = 0;
3167         }
3168
3169         iss = lib$remqti(&p->wait, &b);
3170         if (iss == LIB$_QUEWASEMP) {
3171             if (p->shut_on_empty) {
3172                 if (done) {
3173                     _ckvmssts(sys$dassgn(p->chan_out));
3174                     *p->pipe_done = TRUE;
3175                     _ckvmssts(sys$setef(pipe_ef));
3176                 } else {
3177                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3178                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3179                 }
3180                 return;
3181             }
3182             p->need_wake = TRUE;
3183             return;
3184         }
3185         _ckvmssts(iss);
3186         p->type = 1;
3187     } while (done);
3188
3189
3190     p->curr2 = b;
3191     if (b->eof) {
3192         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3193             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3194     } else {
3195         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3196             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3197     }
3198
3199     return;
3200
3201 }
3202
3203
3204 static pPipe
3205 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3206 {
3207     pPipe p;
3208     char mbx1[64], mbx2[64];
3209     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3210                                       DSC$K_CLASS_S, mbx1},
3211                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3212                                       DSC$K_CLASS_S, mbx2};
3213     unsigned int dviitm = DVI$_DEVBUFSIZ;
3214
3215     int n = sizeof(Pipe);
3216     _ckvmssts(lib$get_vm(&n, &p));
3217     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3218     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3219
3220     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3221     n = p->bufsize * sizeof(char);
3222     _ckvmssts(lib$get_vm(&n, &p->buf));
3223     p->shut_on_empty = FALSE;
3224     p->info   = 0;
3225     p->type   = 0;
3226     p->iosb.status = SS$_NORMAL;
3227 #if defined(PERL_IMPLICIT_CONTEXT)
3228     p->thx = aTHX;
3229 #endif
3230     pipe_infromchild_ast(p);
3231
3232     strcpy(wmbx, mbx1);
3233     strcpy(rmbx, mbx2);
3234     return p;
3235 }
3236
3237 static void
3238 pipe_infromchild_ast(pPipe p)
3239 {
3240     int iss = p->iosb.status;
3241     int eof = (iss == SS$_ENDOFFILE);
3242     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3243     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3244 #if defined(PERL_IMPLICIT_CONTEXT)
3245     pTHX = p->thx;
3246 #endif
3247
3248     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3249         _ckvmssts(sys$dassgn(p->chan_out));
3250         p->chan_out = 0;
3251     }
3252
3253     /* read completed:
3254             input shutdown if EOF from self (done or shut_on_empty)
3255             output shutdown if closing flag set (my_pclose)
3256             send data/eof from child or eof from self
3257             otherwise, re-read (snarf of data from child)
3258     */
3259
3260     if (p->type == 1) {
3261         p->type = 0;
3262         if (myeof && p->chan_in) {                  /* input shutdown */
3263             _ckvmssts(sys$dassgn(p->chan_in));
3264             p->chan_in = 0;
3265         }
3266
3267         if (p->chan_out) {
3268             if (myeof || kideof) {      /* pass EOF to parent */
3269                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3270                               pipe_infromchild_ast, p,
3271                               0, 0, 0, 0, 0, 0));
3272                 return;
3273             } else if (eof) {       /* eat EOF --- fall through to read*/
3274
3275             } else {                /* transmit data */
3276                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3277                               pipe_infromchild_ast,p,
3278                               p->buf, p->iosb.count, 0, 0, 0, 0));
3279                 return;
3280             }
3281         }
3282     }
3283
3284     /*  everything shut? flag as done */
3285
3286     if (!p->chan_in && !p->chan_out) {
3287         *p->pipe_done = TRUE;
3288         _ckvmssts(sys$setef(pipe_ef));
3289         return;
3290     }
3291
3292     /* write completed (or read, if snarfing from child)
3293             if still have input active,
3294                queue read...immediate mode if shut_on_empty so we get EOF if empty
3295             otherwise,
3296                check if Perl reading, generate EOFs as needed
3297     */
3298
3299     if (p->type == 0) {
3300         p->type = 1;
3301         if (p->chan_in) {
3302             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3303                           pipe_infromchild_ast,p,
3304                           p->buf, p->bufsize, 0, 0, 0, 0);
3305             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3306             _ckvmssts(iss);
3307         } else {           /* send EOFs for extra reads */
3308             p->iosb.status = SS$_ENDOFFILE;
3309             p->iosb.dvispec = 0;
3310             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3311                       0, 0, 0,
3312                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3313         }
3314     }
3315 }
3316
3317 static pPipe
3318 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3319 {
3320     pPipe p;
3321     char mbx[64];
3322     unsigned long dviitm = DVI$_DEVBUFSIZ;
3323     struct stat s;
3324     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3325                                       DSC$K_CLASS_S, mbx};
3326     int n = sizeof(Pipe);
3327
3328     /* things like terminals and mbx's don't need this filter */
3329     if (fd && fstat(fd,&s) == 0) {
3330         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3331         char device[65];
3332         unsigned short dev_len;
3333         struct dsc$descriptor_s d_dev;
3334         char * cptr;
3335         struct item_list_3 items[3];
3336         int status;
3337         unsigned short dvi_iosb[4];
3338
3339         cptr = getname(fd, out, 1);
3340         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3341         d_dev.dsc$a_pointer = out;
3342         d_dev.dsc$w_length = strlen(out);
3343         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3344         d_dev.dsc$b_class = DSC$K_CLASS_S;
3345
3346         items[0].len = 4;
3347         items[0].code = DVI$_DEVCHAR;
3348         items[0].bufadr = &devchar;
3349         items[0].retadr = NULL;
3350         items[1].len = 64;
3351         items[1].code = DVI$_FULLDEVNAM;
3352         items[1].bufadr = device;
3353         items[1].retadr = &dev_len;
3354         items[2].len = 0;
3355         items[2].code = 0;
3356
3357         status = sys$getdviw
3358                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3359         _ckvmssts(status);
3360         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3361             device[dev_len] = 0;
3362
3363             if (!(devchar & DEV$M_DIR)) {
3364                 strcpy(out, device);
3365                 return 0;
3366             }
3367         }
3368     }
3369
3370     _ckvmssts(lib$get_vm(&n, &p));
3371     p->fd_out = dup(fd);
3372     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3373     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3374     n = (p->bufsize+1) * sizeof(char);
3375     _ckvmssts(lib$get_vm(&n, &p->buf));
3376     p->shut_on_empty = FALSE;
3377     p->retry = 0;
3378     p->info  = 0;
3379     strcpy(out, mbx);
3380
3381     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3382                   pipe_mbxtofd_ast, p,
3383                   p->buf, p->bufsize, 0, 0, 0, 0));
3384
3385     return p;
3386 }
3387
3388 static void
3389 pipe_mbxtofd_ast(pPipe p)
3390 {
3391     int iss = p->iosb.status;
3392     int done = p->info->done;
3393     int iss2;
3394     int eof = (iss == SS$_ENDOFFILE);
3395     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3396     int err = !(iss&1) && !eof;
3397 #if defined(PERL_IMPLICIT_CONTEXT)
3398     pTHX = p->thx;
3399 #endif
3400
3401     if (done && myeof) {               /* end piping */
3402         close(p->fd_out);
3403         sys$dassgn(p->chan_in);
3404         *p->pipe_done = TRUE;
3405         _ckvmssts(sys$setef(pipe_ef));
3406         return;
3407     }
3408
3409     if (!err && !eof) {             /* good data to send to file */
3410         p->buf[p->iosb.count] = '\n';
3411         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3412         if (iss2 < 0) {
3413             p->retry++;
3414             if (p->retry < MAX_RETRY) {
3415                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3416                 return;
3417             }
3418         }
3419         p->retry = 0;
3420     } else if (err) {
3421         _ckvmssts(iss);
3422     }
3423
3424
3425     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3426           pipe_mbxtofd_ast, p,
3427           p->buf, p->bufsize, 0, 0, 0, 0);
3428     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3429     _ckvmssts(iss);
3430 }
3431
3432
3433 typedef struct _pipeloc     PLOC;
3434 typedef struct _pipeloc*   pPLOC;
3435
3436 struct _pipeloc {
3437     pPLOC   next;
3438     char    dir[NAM$C_MAXRSS+1];
3439 };
3440 static pPLOC  head_PLOC = 0;
3441
3442 void
3443 free_pipelocs(pTHX_ void *head)
3444 {
3445     pPLOC p, pnext;
3446     pPLOC *pHead = (pPLOC *)head;
3447
3448     p = *pHead;
3449     while (p) {
3450         pnext = p->next;
3451         PerlMem_free(p);
3452         p = pnext;
3453     }
3454     *pHead = 0;
3455 }
3456
3457 static void
3458 store_pipelocs(pTHX)
3459 {
3460     int    i;
3461     pPLOC  p;
3462     AV    *av = 0;
3463     SV    *dirsv;
3464     GV    *gv;
3465     char  *dir, *x;
3466     char  *unixdir;
3467     char  temp[NAM$C_MAXRSS+1];
3468     STRLEN n_a;
3469
3470     if (head_PLOC)
3471         free_pipelocs(aTHX_ &head_PLOC);
3472
3473 /*  the . directory from @INC comes last */
3474
3475     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3476     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3477     p->next = head_PLOC;
3478     head_PLOC = p;
3479     strcpy(p->dir,"./");
3480
3481 /*  get the directory from $^X */
3482
3483     unixdir = PerlMem_malloc(VMS_MAXRSS);
3484     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3485
3486 #ifdef PERL_IMPLICIT_CONTEXT
3487     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3488 #else
3489     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3490 #endif
3491         strcpy(temp, PL_origargv[0]);
3492         x = strrchr(temp,']');
3493         if (x == NULL) {
3494         x = strrchr(temp,'>');
3495           if (x == NULL) {
3496             /* It could be a UNIX path */
3497             x = strrchr(temp,'/');
3498           }
3499         }
3500         if (x)
3501           x[1] = '\0';
3502         else {
3503           /* Got a bare name, so use default directory */
3504           temp[0] = '.';
3505           temp[1] = '\0';
3506         }
3507
3508         if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3509             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3510             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3511             p->next = head_PLOC;
3512             head_PLOC = p;
3513             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3514             p->dir[NAM$C_MAXRSS] = '\0';
3515         }
3516     }
3517
3518 /*  reverse order of @INC entries, skip "." since entered above */
3519
3520 #ifdef PERL_IMPLICIT_CONTEXT
3521     if (aTHX)
3522 #endif
3523     if (PL_incgv) av = GvAVn(PL_incgv);
3524
3525     for (i = 0; av && i <= AvFILL(av); i++) {
3526         dirsv = *av_fetch(av,i,TRUE);
3527
3528         if (SvROK(dirsv)) continue;
3529         dir = SvPVx(dirsv,n_a);
3530         if (strcmp(dir,".") == 0) continue;
3531         if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3532             continue;
3533
3534         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3535         p->next = head_PLOC;
3536         head_PLOC = p;
3537         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3538         p->dir[NAM$C_MAXRSS] = '\0';
3539     }
3540
3541 /* most likely spot (ARCHLIB) put first in the list */
3542
3543 #ifdef ARCHLIB_EXP
3544     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3545         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3546         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3547         p->next = head_PLOC;
3548         head_PLOC = p;
3549         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3550         p->dir[NAM$C_MAXRSS] = '\0';
3551     }
3552 #endif
3553     PerlMem_free(unixdir);
3554 }
3555
3556 static I32
3557 Perl_cando_by_name_int
3558    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3559 #if !defined(PERL_IMPLICIT_CONTEXT)
3560 #define cando_by_name_int               Perl_cando_by_name_int
3561 #else
3562 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3563 #endif
3564
3565 static char *
3566 find_vmspipe(pTHX)
3567 {
3568     static int   vmspipe_file_status = 0;
3569     static char  vmspipe_file[NAM$C_MAXRSS+1];
3570
3571     /* already found? Check and use ... need read+execute permission */
3572
3573     if (vmspipe_file_status == 1) {
3574         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3575          && cando_by_name_int
3576            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3577             return vmspipe_file;
3578         }
3579         vmspipe_file_status = 0;
3580     }
3581
3582     /* scan through stored @INC, $^X */
3583
3584     if (vmspipe_file_status == 0) {
3585         char file[NAM$C_MAXRSS+1];
3586         pPLOC  p = head_PLOC;
3587
3588         while (p) {
3589             char * exp_res;
3590             int dirlen;
3591             strcpy(file, p->dir);
3592             dirlen = strlen(file);
3593             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3594             file[NAM$C_MAXRSS] = '\0';
3595             p = p->next;
3596
3597             exp_res = do_rmsexpand
3598                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3599             if (!exp_res) continue;
3600
3601             if (cando_by_name_int
3602                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3603              && cando_by_name_int
3604                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3605                 vmspipe_file_status = 1;
3606                 return vmspipe_file;
3607             }
3608         }
3609         vmspipe_file_status = -1;   /* failed, use tempfiles */
3610     }
3611
3612     return 0;
3613 }
3614
3615 static FILE *
3616 vmspipe_tempfile(pTHX)
3617 {
3618     char file[NAM$C_MAXRSS+1];
3619     FILE *fp;
3620     static int index = 0;
3621     Stat_t s0, s1;
3622     int cmp_result;
3623
3624     /* create a tempfile */
3625
3626     /* we can't go from   W, shr=get to  R, shr=get without
3627        an intermediate vulnerable state, so don't bother trying...
3628
3629        and lib$spawn doesn't shr=put, so have to close the write
3630
3631        So... match up the creation date/time and the FID to
3632        make sure we're dealing with the same file
3633
3634     */
3635
3636     index++;
3637     if (!decc_filename_unix_only) {
3638       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3639       fp = fopen(file,"w");
3640       if (!fp) {
3641         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3642         fp = fopen(file,"w");
3643         if (!fp) {
3644             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3645             fp = fopen(file,"w");
3646         }
3647       }
3648      }
3649      else {
3650       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3651       fp = fopen(file,"w");
3652       if (!fp) {
3653         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3654         fp = fopen(file,"w");
3655         if (!fp) {
3656           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3657           fp = fopen(file,"w");
3658         }
3659       }
3660     }
3661     if (!fp) return 0;  /* we're hosed */
3662
3663     fprintf(fp,"$! 'f$verify(0)'\n");
3664     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3665     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3666     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3667     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3668     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3669     fprintf(fp,"$ perl_del    = \"delete\"\n");
3670     fprintf(fp,"$ pif         = \"if\"\n");
3671     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3672     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3673     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3674     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3675     fprintf(fp,"$!  --- build command line to get max possible length\n");
3676     fprintf(fp,"$c=perl_popen_cmd0\n");
3677     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3678     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3679     fprintf(fp,"$x=perl_popen_cmd3\n");
3680     fprintf(fp,"$c=c+x\n");
3681     fprintf(fp,"$ perl_on\n");
3682     fprintf(fp,"$ 'c'\n");
3683     fprintf(fp,"$ perl_status = $STATUS\n");
3684     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3685     fprintf(fp,"$ perl_exit 'perl_status'\n");
3686     fsync(fileno(fp));
3687
3688     fgetname(fp, file, 1);
3689     fstat(fileno(fp), (struct stat *)&s0);
3690     fclose(fp);
3691
3692     if (decc_filename_unix_only)
3693         do_tounixspec(file, file, 0, NULL);
3694     fp = fopen(file,"r","shr=get");
3695     if (!fp) return 0;
3696     fstat(fileno(fp), (struct stat *)&s1);
3697
3698     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3699     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3700         fclose(fp);
3701         return 0;
3702     }
3703
3704     return fp;
3705 }
3706
3707
3708
3709 static PerlIO *
3710 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3711 {
3712     static int handler_set_up = FALSE;
3713     unsigned long int sts, flags = CLI$M_NOWAIT;
3714     /* The use of a GLOBAL table (as was done previously) rendered
3715      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3716      * environment.  Hence we've switched to LOCAL symbol table.
3717      */
3718     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3719     int j, wait = 0, n;
3720     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3721     char *in, *out, *err, mbx[512];
3722     FILE *tpipe = 0;
3723     char tfilebuf[NAM$C_MAXRSS+1];
3724     pInfo info = NULL;
3725     char cmd_sym_name[20];
3726     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3727                                       DSC$K_CLASS_S, symbol};
3728     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3729                                       DSC$K_CLASS_S, 0};
3730     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3731                                       DSC$K_CLASS_S, cmd_sym_name};
3732     struct dsc$descriptor_s *vmscmd;
3733     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3734     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3735     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3736
3737     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
3738
3739     /* once-per-program initialization...
3740        note that the SETAST calls and the dual test of pipe_ef
3741        makes sure that only the FIRST thread through here does
3742        the initialization...all other threads wait until it's
3743        done.
3744
3745        Yeah, uglier than a pthread call, it's got all the stuff inline
3746        rather than in a separate routine.
3747     */
3748
3749     if (!pipe_ef) {
3750         _ckvmssts(sys$setast(0));
3751         if (!pipe_ef) {
3752             unsigned long int pidcode = JPI$_PID;
3753             $DESCRIPTOR(d_delay, RETRY_DELAY);
3754             _ckvmssts(lib$get_ef(&pipe_ef));
3755             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3756             _ckvmssts(sys$bintim(&d_delay, delaytime));
3757         }
3758         if (!handler_set_up) {
3759           _ckvmssts(sys$dclexh(&pipe_exitblock));
3760           handler_set_up = TRUE;
3761         }
3762         _ckvmssts(sys$setast(1));
3763     }
3764
3765     /* see if we can find a VMSPIPE.COM */
3766
3767     tfilebuf[0] = '@';
3768     vmspipe = find_vmspipe(aTHX);
3769     if (vmspipe) {
3770         strcpy(tfilebuf+1,vmspipe);
3771     } else {        /* uh, oh...we're in tempfile hell */
3772         tpipe = vmspipe_tempfile(aTHX);
3773         if (!tpipe) {       /* a fish popular in Boston */
3774             if (ckWARN(WARN_PIPE)) {
3775                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3776             }
3777         return Nullfp;
3778         }
3779         fgetname(tpipe,tfilebuf+1,1);
3780     }
3781     vmspipedsc.dsc$a_pointer = tfilebuf;
3782     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
3783
3784     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3785     if (!(sts & 1)) {
3786       switch (sts) {
3787         case RMS$_FNF:  case RMS$_DNF:
3788           set_errno(ENOENT); break;
3789         case RMS$_DIR:
3790           set_errno(ENOTDIR); break;
3791         case RMS$_DEV:
3792           set_errno(ENODEV); break;
3793         case RMS$_PRV:
3794           set_errno(EACCES); break;
3795         case RMS$_SYN:
3796           set_errno(EINVAL); break;
3797         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3798           set_errno(E2BIG); break;
3799         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3800           _ckvmssts(sts); /* fall through */
3801         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3802           set_errno(EVMSERR);
3803       }
3804       set_vaxc_errno(sts);
3805       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3806         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3807       }
3808       *psts = sts;
3809       return Nullfp;
3810     }
3811     n = sizeof(Info);
3812     _ckvmssts(lib$get_vm(&n, &info));
3813
3814     strcpy(mode,in_mode);
3815     info->mode = *mode;
3816     info->done = FALSE;
3817     info->completion = 0;
3818     info->closing    = FALSE;
3819     info->in         = 0;
3820     info->out        = 0;
3821     info->err        = 0;
3822     info->fp         = Nullfp;
3823     info->useFILE    = 0;
3824     info->waiting    = 0;
3825     info->in_done    = TRUE;
3826     info->out_done   = TRUE;
3827     info->err_done   = TRUE;
3828
3829     in = PerlMem_malloc(VMS_MAXRSS);
3830     if (in == NULL) _ckvmssts(SS$_INSFMEM);
3831     out = PerlMem_malloc(VMS_MAXRSS);
3832     if (out == NULL) _ckvmssts(SS$_INSFMEM);
3833     err = PerlMem_malloc(VMS_MAXRSS);
3834     if (err == NULL) _ckvmssts(SS$_INSFMEM);
3835
3836     in[0] = out[0] = err[0] = '\0';
3837
3838     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
3839         info->useFILE = 1;
3840         strcpy(p,p+1);
3841     }
3842     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
3843         wait = 1;
3844         strcpy(p,p+1);
3845     }
3846
3847     if (*mode == 'r') {             /* piping from subroutine */
3848
3849         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3850         if (info->out) {
3851             info->out->pipe_done = &info->out_done;
3852             info->out_done = FALSE;
3853             info->out->info = info;
3854         }
3855         if (!info->useFILE) {
3856         info->fp  = PerlIO_open(mbx, mode);
3857         } else {
3858             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3859             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3860         }
3861
3862         if (!info->fp && info->out) {
3863             sys$cancel(info->out->chan_out);
3864
3865             while (!info->out_done) {
3866                 int done;
3867                 _ckvmssts(sys$setast(0));
3868                 done = info->out_done;
3869                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3870                 _ckvmssts(sys$setast(1));
3871                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3872             }
3873
3874             if (info->out->buf) {
3875                 n = info->out->bufsize * sizeof(char);
3876                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3877             }
3878             n = sizeof(Pipe);
3879             _ckvmssts(lib$free_vm(&n, &info->out));
3880             n = sizeof(Info);
3881             _ckvmssts(lib$free_vm(&n, &info));
3882             *psts = RMS$_FNF;
3883             return Nullfp;
3884         }
3885
3886         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3887         if (info->err) {
3888             info->err->pipe_done = &info->err_done;
3889             info->err_done = FALSE;
3890             info->err->info = info;
3891         }
3892
3893     } else if (*mode == 'w') {      /* piping to subroutine */
3894
3895         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3896         if (info->out) {
3897             info->out->pipe_done = &info->out_done;
3898             info->out_done = FALSE;
3899             info->out->info = info;
3900         }
3901
3902         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3903         if (info->err) {
3904             info->err->pipe_done = &info->err_done;
3905             info->err_done = FALSE;
3906             info->err->info = info;
3907         }
3908
3909         info->in = pipe_tochild_setup(aTHX_ in,mbx);
3910         if (!info->useFILE) {
3911             info->fp  = PerlIO_open(mbx, mode);
3912         } else {
3913             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3914             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3915         }
3916
3917         if (info->in) {
3918             info->in->pipe_done = &info->in_done;
3919             info->in_done = FALSE;
3920             info->in->info = info;
3921         }
3922
3923         /* error cleanup */
3924         if (!info->fp && info->in) {
3925             info->done = TRUE;
3926             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3927                               0, 0, 0, 0, 0, 0, 0, 0));
3928
3929             while (!info->in_done) {
3930                 int done;
3931                 _ckvmssts(sys$setast(0));
3932                 done = info->in_done;
3933                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3934                 _ckvmssts(sys$setast(1));
3935                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3936             }
3937
3938             if (info->in->buf) {
3939                 n = info->in->bufsize * sizeof(char);
3940                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3941             }
3942             n = sizeof(Pipe);
3943             _ckvmssts(lib$free_vm(&n, &info->in));
3944             n = sizeof(Info);
3945             _ckvmssts(lib$free_vm(&n, &info));
3946             *psts = RMS$_FNF;
3947             return Nullfp;
3948         }
3949
3950
3951     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
3952         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3953         if (info->out) {
3954             info->out->pipe_done = &info->out_done;
3955             info->out_done = FALSE;
3956             info->out->info = info;
3957         }
3958
3959         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3960         if (info->err) {
3961             info->err->pipe_done = &info->err_done;
3962             info->err_done = FALSE;
3963             info->err->info = info;
3964         }
3965     }
3966
3967     symbol[MAX_DCL_SYMBOL] = '\0';
3968
3969     strncpy(symbol, in, MAX_DCL_SYMBOL);
3970     d_symbol.dsc$w_length = strlen(symbol);
3971     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3972
3973     strncpy(symbol, err, MAX_DCL_SYMBOL);
3974     d_symbol.dsc$w_length = strlen(symbol);
3975     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3976
3977     strncpy(symbol, out, MAX_DCL_SYMBOL);
3978     d_symbol.dsc$w_length = strlen(symbol);
3979     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3980
3981     /* Done with the names for the pipes */
3982     PerlMem_free(err);
3983     PerlMem_free(out);
3984     PerlMem_free(in);
3985
3986     p = vmscmd->dsc$a_pointer;
3987     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
3988     if (*p == '$') p++;                         /* remove leading $ */
3989     while (*p == ' ' || *p == '\t') p++;
3990
3991     for (j = 0; j < 4; j++) {
3992         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3993         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3994
3995     strncpy(symbol, p, MAX_DCL_SYMBOL);
3996     d_symbol.dsc$w_length = strlen(symbol);
3997     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3998
3999         if (strlen(p) > MAX_DCL_SYMBOL) {
4000             p += MAX_DCL_SYMBOL;
4001         } else {
4002             p += strlen(p);
4003         }
4004     }
4005     _ckvmssts(sys$setast(0));
4006     info->next=open_pipes;  /* prepend to list */
4007     open_pipes=info;
4008     _ckvmssts(sys$setast(1));
4009     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4010      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4011      * have SYS$COMMAND if we need it.
4012      */
4013     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4014                       0, &info->pid, &info->completion,
4015                       0, popen_completion_ast,info,0,0,0));
4016
4017     /* if we were using a tempfile, close it now */
4018
4019     if (tpipe) fclose(tpipe);
4020
4021     /* once the subprocess is spawned, it has copied the symbols and
4022        we can get rid of ours */
4023
4024     for (j = 0; j < 4; j++) {
4025         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4026         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4027     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4028     }
4029     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4030     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4031     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4032     vms_execfree(vmscmd);
4033
4034 #ifdef PERL_IMPLICIT_CONTEXT
4035     if (aTHX)
4036 #endif
4037     PL_forkprocess = info->pid;
4038
4039     if (wait) {
4040          int done = 0;
4041          while (!done) {
4042              _ckvmssts(sys$setast(0));
4043              done = info->done;
4044              if (!done) _ckvmssts(sys$clref(pipe_ef));
4045              _ckvmssts(sys$setast(1));
4046              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4047          }
4048         *psts = info->completion;
4049 /* Caller thinks it is open and tries to close it. */
4050 /* This causes some problems, as it changes the error status */
4051 /*        my_pclose(info->fp); */
4052     } else {
4053         *psts = SS$_NORMAL;
4054     }
4055     return info->fp;
4056 }  /* end of safe_popen */
4057
4058
4059 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4060 PerlIO *
4061 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4062 {
4063     int sts;
4064     TAINT_ENV();
4065     TAINT_PROPER("popen");
4066     PERL_FLUSHALL_FOR_CHILD;
4067     return safe_popen(aTHX_ cmd,mode,&sts);
4068 }
4069
4070 /*}}}*/
4071
4072 /*{{{  I32 my_pclose(PerlIO *fp)*/
4073 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4074 {
4075     pInfo info, last = NULL;
4076     unsigned long int retsts;
4077     int done, iss, n;
4078
4079     for (info = open_pipes; info != NULL; last = info, info = info->next)
4080         if (info->fp == fp) break;
4081
4082     if (info == NULL) {  /* no such pipe open */
4083       set_errno(ECHILD); /* quoth POSIX */
4084       set_vaxc_errno(SS$_NONEXPR);
4085       return -1;
4086     }
4087
4088     /* If we were writing to a subprocess, insure that someone reading from
4089      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4090      * produce an EOF record in the mailbox.
4091      *
4092      *  well, at least sometimes it *does*, so we have to watch out for
4093      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4094      */
4095      if (info->fp) {
4096         if (!info->useFILE)
4097             PerlIO_flush(info->fp);   /* first, flush data */
4098         else
4099             fflush((FILE *)info->fp);
4100     }
4101
4102     _ckvmssts(sys$setast(0));
4103      info->closing = TRUE;
4104      done = info->done && info->in_done && info->out_done && info->err_done;
4105      /* hanging on write to Perl's input? cancel it */
4106      if (info->mode == 'r' && info->out && !info->out_done) {
4107         if (info->out->chan_out) {
4108             _ckvmssts(sys$cancel(info->out->chan_out));
4109             if (!info->out->chan_in) {   /* EOF generation, need AST */
4110                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4111             }
4112         }
4113      }
4114      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4115          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4116                            0, 0, 0, 0, 0, 0));
4117     _ckvmssts(sys$setast(1));
4118     if (info->fp) {
4119      if (!info->useFILE)
4120         PerlIO_close(info->fp);
4121      else
4122         fclose((FILE *)info->fp);
4123     }
4124      /*
4125         we have to wait until subprocess completes, but ALSO wait until all
4126         the i/o completes...otherwise we'll be freeing the "info" structure
4127         that the i/o ASTs could still be using...
4128      */
4129
4130      while (!done) {
4131          _ckvmssts(sys$setast(0));
4132          done = info->done && info->in_done && info->out_done && info->err_done;
4133          if (!done) _ckvmssts(sys$clref(pipe_ef));
4134          _ckvmssts(sys$setast(1));
4135          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4136      }
4137      retsts = info->completion;
4138
4139     /* remove from list of open pipes */
4140     _ckvmssts(sys$setast(0));
4141     if (last) last->next = info->next;
4142     else open_pipes = info->next;
4143     _ckvmssts(sys$setast(1));
4144
4145     /* free buffers and structures */
4146
4147     if (info->in) {
4148         if (info->in->buf) {
4149             n = info->in->bufsize * sizeof(char);
4150             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4151         }
4152         n = sizeof(Pipe);
4153         _ckvmssts(lib$free_vm(&n, &info->in));
4154     }
4155     if (info->out) {
4156         if (info->out->buf) {
4157             n = info->out->bufsize * sizeof(char);
4158             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4159         }
4160         n = sizeof(Pipe);
4161         _ckvmssts(lib$free_vm(&n, &info->out));
4162     }
4163     if (info->err) {
4164         if (info->err->buf) {
4165             n = info->err->bufsize * sizeof(char);
4166             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4167         }
4168         n = sizeof(Pipe);
4169         _ckvmssts(lib$free_vm(&n, &info->err));
4170     }
4171     n = sizeof(Info);
4172     _ckvmssts(lib$free_vm(&n, &info));
4173
4174     return retsts;
4175
4176 }  /* end of my_pclose() */
4177
4178 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4179   /* Roll our own prototype because we want this regardless of whether
4180    * _VMS_WAIT is defined.
4181    */
4182   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4183 #endif
4184 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4185    created with popen(); otherwise partially emulate waitpid() unless
4186    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4187    Also check processes not considered by the CRTL waitpid().
4188  */
4189 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4190 Pid_t
4191 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4192 {
4193     pInfo info;
4194     int done;
4195     int sts;
4196     int j;
4197
4198     if (statusp) *statusp = 0;
4199
4200     for (info = open_pipes; info != NULL; info = info->next)
4201         if (info->pid == pid) break;
4202
4203     if (info != NULL) {  /* we know about this child */
4204       while (!info->done) {
4205           _ckvmssts(sys$setast(0));
4206           done = info->done;
4207           if (!done) _ckvmssts(sys$clref(pipe_ef));
4208           _ckvmssts(sys$setast(1));
4209           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4210       }
4211
4212       if (statusp) *statusp = info->completion;
4213       return pid;
4214     }
4215
4216     /* child that already terminated? */
4217
4218     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4219         if (closed_list[j].pid == pid) {
4220             if (statusp) *statusp = closed_list[j].completion;
4221             return pid;
4222         }
4223     }
4224
4225     /* fall through if this child is not one of our own pipe children */
4226
4227 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4228
4229       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4230        * in 7.2 did we get a version that fills in the VMS completion
4231        * status as Perl has always tried to do.
4232        */
4233
4234       sts = __vms_waitpid( pid, statusp, flags );
4235
4236       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4237          return sts;
4238
4239       /* If the real waitpid tells us the child does not exist, we
4240        * fall through here to implement waiting for a child that
4241        * was created by some means other than exec() (say, spawned
4242        * from DCL) or to wait for a process that is not a subprocess
4243        * of the current process.
4244        */
4245
4246 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4247
4248     {
4249       $DESCRIPTOR(intdsc,"0 00:00:01");
4250       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4251       unsigned long int pidcode = JPI$_PID, mypid;
4252       unsigned long int interval[2];
4253       unsigned int jpi_iosb[2];
4254       struct itmlst_3 jpilist[2] = {
4255           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4256           {                      0,         0,                 0, 0}
4257       };
4258
4259       if (pid <= 0) {
4260         /* Sorry folks, we don't presently implement rooting around for
4261            the first child we can find, and we definitely don't want to
4262            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4263          */
4264         set_errno(ENOTSUP);
4265         return -1;
4266       }
4267
4268       /* Get the owner of the child so I can warn if it's not mine. If the
4269        * process doesn't exist or I don't have the privs to look at it,
4270        * I can go home early.
4271        */
4272       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4273       if (sts & 1) sts = jpi_iosb[0];
4274       if (!(sts & 1)) {
4275         switch (sts) {
4276             case SS$_NONEXPR:
4277                 set_errno(ECHILD);
4278                 break;
4279             case SS$_NOPRIV:
4280                 set_errno(EACCES);
4281                 break;
4282             default:
4283                 _ckvmssts(sts);
4284         }
4285         set_vaxc_errno(sts);
4286         return -1;
4287       }
4288
4289       if (ckWARN(WARN_EXEC)) {
4290         /* remind folks they are asking for non-standard waitpid behavior */
4291         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4292         if (ownerpid != mypid)
4293           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4294                       "waitpid: process %x is not a child of process %x",
4295                       pid,mypid);
4296       }
4297
4298       /* simply check on it once a second until it's not there anymore. */
4299
4300       _ckvmssts(sys$bintim(&intdsc,interval));
4301       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4302             _ckvmssts(sys$schdwk(0,0,interval,0));
4303             _ckvmssts(sys$hiber());
4304       }
4305       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4306
4307       _ckvmssts(sts);
4308       return pid;
4309     }
4310 }  /* end of waitpid() */
4311 /*}}}*/
4312 /*}}}*/
4313 /*}}}*/
4314
4315 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4316 char *
4317 my_gconvert(double val, int ndig, int trail, char *buf)
4318 {
4319   static char __gcvtbuf[DBL_DIG+1];
4320   char *loc;
4321
4322   loc = buf ? buf : __gcvtbuf;
4323
4324 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4325   if (val < 1) {
4326     sprintf(loc,"%.*g",ndig,val);
4327     return loc;
4328   }
4329 #endif
4330
4331   if (val) {
4332     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4333     return gcvt(val,ndig,loc);
4334   }
4335   else {
4336     loc[0] = '0'; loc[1] = '\0';
4337     return loc;
4338   }
4339
4340 }
4341 /*}}}*/
4342
4343 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4344 static int rms_free_search_context(struct FAB * fab)
4345 {
4346 struct NAM * nam;
4347
4348     nam = fab->fab$l_nam;
4349     nam->nam$b_nop |= NAM$M_SYNCHK;
4350     nam->nam$l_rlf = NULL;
4351     fab->fab$b_dns = 0;
4352     return sys$parse(fab, NULL, NULL);
4353 }
4354
4355 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4356 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4357 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4358 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4359 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4360 #define rms_nam_esll(nam) nam.nam$b_esl
4361 #define rms_nam_esl(nam) nam.nam$b_esl
4362 #define rms_nam_name(nam) nam.nam$l_name
4363 #define rms_nam_namel(nam) nam.nam$l_name
4364 #define rms_nam_type(nam) nam.nam$l_type
4365 #define rms_nam_typel(nam) nam.nam$l_type
4366 #define rms_nam_ver(nam) nam.nam$l_ver
4367 #define rms_nam_verl(nam) nam.nam$l_ver
4368 #define rms_nam_rsll(nam) nam.nam$b_rsl
4369 #define rms_nam_rsl(nam) nam.nam$b_rsl
4370 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4371 #define rms_set_fna(fab, nam, name, size) \
4372         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4373 #define rms_get_fna(fab, nam) fab.fab$l_fna
4374 #define rms_set_dna(fab, nam, name, size) \
4375         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4376 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4377 #define rms_set_esa(fab, nam, name, size) \
4378         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4379 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4380         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4381 #define rms_set_rsa(nam, name, size) \
4382         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4383 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4384         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4385 #define rms_nam_name_type_l_size(nam) \
4386         (nam.nam$b_name + nam.nam$b_type)
4387 #else
4388 static int rms_free_search_context(struct FAB * fab)
4389 {
4390 struct NAML * nam;
4391
4392     nam = fab->fab$l_naml;
4393     nam->naml$b_nop |= NAM$M_SYNCHK;
4394     nam->naml$l_rlf = NULL;
4395     nam->naml$l_long_defname_size = 0;
4396
4397     fab->fab$b_dns = 0;
4398     return sys$parse(fab, NULL, NULL);
4399 }
4400
4401 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4402 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4403 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4404 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4405 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4406 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4407 #define rms_nam_esl(nam) nam.naml$b_esl
4408 #define rms_nam_name(nam) nam.naml$l_name
4409 #define rms_nam_namel(nam) nam.naml$l_long_name
4410 #define rms_nam_type(nam) nam.naml$l_type
4411 #define rms_nam_typel(nam) nam.naml$l_long_type
4412 #define rms_nam_ver(nam) nam.naml$l_ver
4413 #define rms_nam_verl(nam) nam.naml$l_long_ver
4414 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4415 #define rms_nam_rsl(nam) nam.naml$b_rsl
4416 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4417 #define rms_set_fna(fab, nam, name, size) \
4418         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4419         nam.naml$l_long_filename_size = size; \
4420         nam.naml$l_long_filename = name;}
4421 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4422 #define rms_set_dna(fab, nam, name, size) \
4423         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4424         nam.naml$l_long_defname_size = size; \
4425         nam.naml$l_long_defname = name; }
4426 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4427 #define rms_set_esa(fab, nam, name, size) \
4428         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4429         nam.naml$l_long_expand_alloc = size; \
4430         nam.naml$l_long_expand = name; }
4431 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4432         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4433         nam.naml$l_long_expand = l_name; \
4434         nam.naml$l_long_expand_alloc = l_size; }
4435 #define rms_set_rsa(nam, name, size) \
4436         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4437         nam.naml$l_long_result = name; \
4438         nam.naml$l_long_result_alloc = size; }
4439 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4440         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4441         nam.naml$l_long_result = l_name; \
4442         nam.naml$l_long_result_alloc = l_size; }
4443 #define rms_nam_name_type_l_size(nam) \
4444         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4445 #endif
4446
4447
4448 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4449 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4450  * to expand file specification.  Allows for a single default file
4451  * specification and a simple mask of options.  If outbuf is non-NULL,
4452  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4453  * the resultant file specification is placed.  If outbuf is NULL, the
4454  * resultant file specification is placed into a static buffer.
4455  * The third argument, if non-NULL, is taken to be a default file
4456  * specification string.  The fourth argument is unused at present.
4457  * rmesexpand() returns the address of the resultant string if
4458  * successful, and NULL on error.
4459  *
4460  * New functionality for previously unused opts value:
4461  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4462  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
4463  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4464  */
4465 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4466
4467 static char *
4468 mp_do_rmsexpand
4469    (pTHX_ const char *filespec,
4470     char *outbuf,
4471     int ts,
4472     const char *defspec,
4473     unsigned opts,
4474     int * fs_utf8,
4475     int * dfs_utf8)
4476 {
4477   static char __rmsexpand_retbuf[VMS_MAXRSS];
4478   char * vmsfspec, *tmpfspec;
4479   char * esa, *cp, *out = NULL;
4480   char * tbuf;
4481   char * esal;
4482   char * outbufl;
4483   struct FAB myfab = cc$rms_fab;
4484   rms_setup_nam(mynam);
4485   STRLEN speclen;
4486   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4487   int sts;
4488
4489   /* temp hack until UTF8 is actually implemented */
4490   if (fs_utf8 != NULL)
4491     *fs_utf8 = 0;
4492
4493   if (!filespec || !*filespec) {
4494     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4495     return NULL;
4496   }
4497   if (!outbuf) {
4498     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4499     else    outbuf = __rmsexpand_retbuf;
4500   }
4501
4502   vmsfspec = NULL;
4503   tmpfspec = NULL;
4504   outbufl = NULL;
4505
4506   isunix = 0;
4507   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4508     isunix = is_unix_filespec(filespec);
4509     if (isunix) {
4510       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4511       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4512       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4513         PerlMem_free(vmsfspec);
4514         if (out)
4515            Safefree(out);
4516         return NULL;
4517       }
4518       filespec = vmsfspec;
4519
4520       /* Unless we are forcing to VMS format, a UNIX input means
4521        * UNIX output, and that requires long names to be used
4522        */
4523       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4524         opts |= PERL_RMSEXPAND_M_LONG;
4525       else {
4526         isunix = 0;
4527       }
4528     }
4529   }
4530
4531   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4532   rms_bind_fab_nam(myfab, mynam);
4533
4534   if (defspec && *defspec) {
4535     int t_isunix;
4536     t_isunix = is_unix_filespec(defspec);
4537     if (t_isunix) {
4538       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4539       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4540       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4541         PerlMem_free(tmpfspec);
4542         if (vmsfspec != NULL)
4543             PerlMem_free(vmsfspec);
4544         if (out)
4545            Safefree(out);
4546         return NULL;
4547       }
4548       defspec = tmpfspec;
4549     }
4550     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4551   }
4552
4553   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4554   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4555 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4556   esal = PerlMem_malloc(VMS_MAXRSS);
4557   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4558 #endif
4559   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4560
4561   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4562     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4563   }
4564   else {
4565 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4566     outbufl = PerlMem_malloc(VMS_MAXRSS);
4567     if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4568     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4569 #else
4570     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4571 #endif
4572   }
4573
4574 #ifdef NAM$M_NO_SHORT_UPCASE
4575   if (decc_efs_case_preserve)
4576     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4577 #endif
4578
4579   /* First attempt to parse as an existing file */
4580   retsts = sys$parse(&myfab,0,0);
4581   if (!(retsts & STS$K_SUCCESS)) {
4582
4583     /* Could not find the file, try as syntax only if error is not fatal */
4584     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4585     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4586       retsts = sys$parse(&myfab,0,0);
4587       if (retsts & STS$K_SUCCESS) goto expanded;
4588     }
4589
4590      /* Still could not parse the file specification */
4591     /*----------------------------------------------*/
4592     sts = rms_free_search_context(&myfab); /* Free search context */
4593     if (out) Safefree(out);
4594     if (tmpfspec != NULL)
4595         PerlMem_free(tmpfspec);
4596     if (vmsfspec != NULL)
4597         PerlMem_free(vmsfspec);
4598     if (outbufl != NULL)
4599         PerlMem_free(outbufl);
4600     PerlMem_free(esa);
4601     PerlMem_free(esal);
4602     set_vaxc_errno(retsts);
4603     if      (retsts == RMS$_PRV) set_errno(EACCES);
4604     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4605     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4606     else                         set_errno(EVMSERR);
4607     return NULL;
4608   }
4609   retsts = sys$search(&myfab,0,0);
4610   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4611     sts = rms_free_search_context(&myfab); /* Free search context */
4612     if (out) Safefree(out);
4613     if (tmpfspec != NULL)
4614         PerlMem_free(tmpfspec);
4615     if (vmsfspec != NULL)
4616         PerlMem_free(vmsfspec);
4617     if (outbufl != NULL)
4618         PerlMem_free(outbufl);
4619     PerlMem_free(esa);
4620     PerlMem_free(esal);
4621     set_vaxc_errno(retsts);
4622     if      (retsts == RMS$_PRV) set_errno(EACCES);
4623     else                         set_errno(EVMSERR);
4624     return NULL;
4625   }
4626
4627   /* If the input filespec contained any lowercase characters,
4628    * downcase the result for compatibility with Unix-minded code. */
4629   expanded:
4630   if (!decc_efs_case_preserve) {
4631     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4632       if (islower(*tbuf)) { haslower = 1; break; }
4633   }
4634
4635    /* Is a long or a short name expected */
4636   /*------------------------------------*/
4637   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4638     if (rms_nam_rsll(mynam)) {
4639         tbuf = outbuf;
4640         speclen = rms_nam_rsll(mynam);
4641     }
4642     else {
4643         tbuf = esal; /* Not esa */
4644         speclen = rms_nam_esll(mynam);
4645     }
4646   }
4647   else {
4648     if (rms_nam_rsl(mynam)) {
4649         tbuf = outbuf;
4650         speclen = rms_nam_rsl(mynam);
4651     }
4652     else {
4653         tbuf = esa; /* Not esal */
4654         speclen = rms_nam_esl(mynam);
4655     }
4656   }
4657   tbuf[speclen] = '\0';
4658
4659   /* Trim off null fields added by $PARSE
4660    * If type > 1 char, must have been specified in original or default spec
4661    * (not true for version; $SEARCH may have added version of existing file).
4662    */
4663   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4664   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4665     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4666              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4667   }
4668   else {
4669     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4670              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4671   }
4672   if (trimver || trimtype) {
4673     if (defspec && *defspec) {
4674       char *defesal = NULL;
4675       defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4676       if (defesal != NULL) {
4677         struct FAB deffab = cc$rms_fab;
4678         rms_setup_nam(defnam);
4679
4680         rms_bind_fab_nam(deffab, defnam);
4681
4682         /* Cast ok */
4683         rms_set_fna
4684             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4685
4686         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4687
4688         rms_clear_nam_nop(defnam);
4689         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4690 #ifdef NAM$M_NO_SHORT_UPCASE
4691         if (decc_efs_case_preserve)
4692           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4693 #endif
4694         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4695           if (trimver) {
4696              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4697           }
4698           if (trimtype) {
4699             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4700           }
4701         }
4702         PerlMem_free(defesal);
4703       }
4704     }
4705     if (trimver) {
4706       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4707         if (*(rms_nam_verl(mynam)) != '\"')
4708           speclen = rms_nam_verl(mynam) - tbuf;
4709       }
4710       else {
4711         if (*(rms_nam_ver(mynam)) != '\"')
4712           speclen = rms_nam_ver(mynam) - tbuf;
4713       }
4714     }
4715     if (trimtype) {
4716       /* If we didn't already trim version, copy down */
4717       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4718         if (speclen > rms_nam_verl(mynam) - tbuf)
4719           memmove
4720            (rms_nam_typel(mynam),
4721             rms_nam_verl(mynam),
4722             speclen - (rms_nam_verl(mynam) - tbuf));
4723           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4724       }
4725       else {
4726         if (speclen > rms_nam_ver(mynam) - tbuf)
4727           memmove
4728            (rms_nam_type(mynam),
4729             rms_nam_ver(mynam),
4730             speclen - (rms_nam_ver(mynam) - tbuf));
4731           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4732       }
4733     }
4734   }
4735
4736    /* Done with these copies of the input files */
4737   /*-------------------------------------------*/
4738   if (vmsfspec != NULL)
4739         PerlMem_free(vmsfspec);
4740   if (tmpfspec != NULL)
4741         PerlMem_free(tmpfspec);
4742
4743   /* If we just had a directory spec on input, $PARSE "helpfully"
4744    * adds an empty name and type for us */
4745   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4746     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4747         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
4748         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4749       speclen = rms_nam_namel(mynam) - tbuf;
4750   }
4751   else {
4752     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4753         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
4754         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4755       speclen = rms_nam_name(mynam) - tbuf;
4756   }
4757
4758   /* Posix format specifications must have matching quotes */
4759   if (speclen < (VMS_MAXRSS - 1)) {
4760     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
4761       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
4762         tbuf[speclen] = '\"';
4763         speclen++;
4764       }
4765     }
4766   }
4767   tbuf[speclen] = '\0';
4768   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
4769
4770   /* Have we been working with an expanded, but not resultant, spec? */
4771   /* Also, convert back to Unix syntax if necessary. */
4772
4773   if (!rms_nam_rsll(mynam)) {
4774     if (isunix) {
4775       if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
4776         if (out) Safefree(out);
4777         PerlMem_free(esal);
4778         PerlMem_free(esa);
4779         if (outbufl != NULL)
4780             PerlMem_free(outbufl);
4781         return NULL;
4782       }
4783     }
4784     else strcpy(outbuf,esa);
4785   }
4786   else if (isunix) {
4787     tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4788     if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4789     if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
4790         if (out) Safefree(out);
4791         PerlMem_free(esa);
4792         PerlMem_free(esal);
4793         PerlMem_free(tmpfspec);
4794         if (outbufl != NULL)
4795             PerlMem_free(outbufl);
4796         return NULL;
4797     }
4798     strcpy(outbuf,tmpfspec);
4799     PerlMem_free(tmpfspec);
4800   }
4801
4802   rms_set_rsal(mynam, NULL, 0, NULL, 0);
4803   sts = rms_free_search_context(&myfab); /* Free search context */
4804   PerlMem_free(esa);
4805   PerlMem_free(esal);
4806   if (outbufl != NULL)
4807      PerlMem_free(outbufl);
4808   return outbuf;
4809 }
4810 /*}}}*/
4811 /* External entry points */
4812 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4813 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
4814 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4815 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
4816 char *Perl_rmsexpand_utf8
4817   (pTHX_ const char *spec, char *buf, const char *def,
4818    unsigned opt, int * fs_utf8, int * dfs_utf8)
4819 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
4820 char *Perl_rmsexpand_utf8_ts
4821   (pTHX_ const char *spec, char *buf, const char *def,
4822    unsigned opt, int * fs_utf8, int * dfs_utf8)
4823 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
4824
4825
4826 /*
4827 ** The following routines are provided to make life easier when
4828 ** converting among VMS-style and Unix-style directory specifications.
4829 ** All will take input specifications in either VMS or Unix syntax. On
4830 ** failure, all return NULL.  If successful, the routines listed below
4831 ** return a pointer to a buffer containing the appropriately
4832 ** reformatted spec (and, therefore, subsequent calls to that routine
4833 ** will clobber the result), while the routines of the same names with
4834 ** a _ts suffix appended will return a pointer to a mallocd string
4835 ** containing the appropriately reformatted spec.
4836 ** In all cases, only explicit syntax is altered; no check is made that
4837 ** the resulting string is valid or that the directory in question
4838 ** actually exists.
4839 **
4840 **   fileify_dirspec() - convert a directory spec into the name of the
4841 **     directory file (i.e. what you can stat() to see if it's a dir).
4842 **     The style (VMS or Unix) of the result is the same as the style
4843 **     of the parameter passed in.
4844 **   pathify_dirspec() - convert a directory spec into a path (i.e.
4845 **     what you prepend to a filename to indicate what directory it's in).
4846 **     The style (VMS or Unix) of the result is the same as the style
4847 **     of the parameter passed in.
4848 **   tounixpath() - convert a directory spec into a Unix-style path.
4849 **   tovmspath() - convert a directory spec into a VMS-style path.
4850 **   tounixspec() - convert any file spec into a Unix-style file spec.
4851 **   tovmsspec() - convert any file spec into a VMS-style spec.
4852 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
4853 **
4854 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
4855 ** Permission is given to distribute this code as part of the Perl
4856 ** standard distribution under the terms of the GNU General Public
4857 ** License or the Perl Artistic License.  Copies of each may be
4858 ** found in the Perl standard distribution.
4859  */
4860
4861 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
4862 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
4863 {
4864     static char __fileify_retbuf[VMS_MAXRSS];
4865     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4866     char *retspec, *cp1, *cp2, *lastdir;
4867     char *trndir, *vmsdir;
4868     unsigned short int trnlnm_iter_count;
4869     int sts;
4870     if (utf8_fl != NULL)
4871         *utf8_fl = 0;
4872
4873     if (!dir || !*dir) {
4874       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4875     }
4876     dirlen = strlen(dir);
4877     while (dirlen && dir[dirlen-1] == '/') --dirlen;
4878     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4879       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4880         dir = "/sys$disk";
4881         dirlen = 9;
4882       }
4883       else
4884         dirlen = 1;
4885     }
4886     if (dirlen > (VMS_MAXRSS - 1)) {
4887       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4888       return NULL;
4889     }
4890     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
4891     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
4892     if (!strpbrk(dir+1,"/]>:")  &&
4893         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4894       strcpy(trndir,*dir == '/' ? dir + 1: dir);
4895       trnlnm_iter_count = 0;
4896       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4897         trnlnm_iter_count++;
4898         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4899       }
4900       dirlen = strlen(trndir);
4901     }
4902     else {
4903       strncpy(trndir,dir,dirlen);
4904       trndir[dirlen] = '\0';
4905     }
4906
4907     /* At this point we are done with *dir and use *trndir which is a
4908      * copy that can be modified.  *dir must not be modified.
4909      */
4910
4911     /* If we were handed a rooted logical name or spec, treat it like a
4912      * simple directory, so that
4913      *    $ Define myroot dev:[dir.]
4914      *    ... do_fileify_dirspec("myroot",buf,1) ...
4915      * does something useful.
4916      */
4917     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4918       trndir[--dirlen] = '\0';
4919       trndir[dirlen-1] = ']';
4920     }
4921     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4922       trndir[--dirlen] = '\0';
4923       trndir[dirlen-1] = '>';
4924     }
4925
4926     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4927       /* If we've got an explicit filename, we can just shuffle the string. */
4928       if (*(cp1+1)) hasfilename = 1;
4929       /* Similarly, we can just back up a level if we've got multiple levels
4930          of explicit directories in a VMS spec which ends with directories. */
4931       else {
4932         for (cp2 = cp1; cp2 > trndir; cp2--) {
4933           if (*cp2 == '.') {
4934             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4935 /* fix-me, can not scan EFS file specs backward like this */
4936               *cp2 = *cp1; *cp1 = '\0';
4937               hasfilename = 1;
4938               break;
4939             }
4940           }
4941           if (*cp2 == '[' || *cp2 == '<') break;
4942         }
4943       }
4944     }
4945
4946     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
4947     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
4948     cp1 = strpbrk(trndir,"]:>");
4949     if (hasfilename || !cp1) { /* Unix-style path or filename */
4950       if (trndir[0] == '.') {
4951         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4952           PerlMem_free(trndir);
4953           PerlMem_free(vmsdir);
4954           return do_fileify_dirspec("[]",buf,ts,NULL);
4955         }
4956         else if (trndir[1] == '.' &&
4957                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4958           PerlMem_free(trndir);
4959           PerlMem_free(vmsdir);
4960           return do_fileify_dirspec("[-]",buf,ts,NULL);
4961         }
4962       }
4963       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
4964         dirlen -= 1;                 /* to last element */
4965         lastdir = strrchr(trndir,'/');
4966       }
4967       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4968         /* If we have "/." or "/..", VMSify it and let the VMS code
4969          * below expand it, rather than repeating the code to handle
4970          * relative components of a filespec here */
4971         do {
4972           if (*(cp1+2) == '.') cp1++;
4973           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4974             char * ret_chr;
4975             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
4976                 PerlMem_free(trndir);
4977                 PerlMem_free(vmsdir);
4978                 return NULL;
4979             }
4980             if (strchr(vmsdir,'/') != NULL) {
4981               /* If do_tovmsspec() returned it, it must have VMS syntax
4982                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
4983                * the time to check this here only so we avoid a recursion
4984                * loop; otherwise, gigo.
4985                */
4986               PerlMem_free(trndir);
4987               PerlMem_free(vmsdir);
4988               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
4989               return NULL;
4990             }
4991             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
4992                 PerlMem_free(trndir);
4993                 PerlMem_free(vmsdir);
4994                 return NULL;
4995             }
4996             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
4997             PerlMem_free(trndir);
4998             PerlMem_free(vmsdir);
4999             return ret_chr;
5000           }
5001           cp1++;
5002         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5003         lastdir = strrchr(trndir,'/');
5004       }
5005       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5006         char * ret_chr;
5007         /* Ditto for specs that end in an MFD -- let the VMS code
5008          * figure out whether it's a real device or a rooted logical. */
5009
5010         /* This should not happen any more.  Allowing the fake /000000
5011          * in a UNIX pathname causes all sorts of problems when trying
5012          * to run in UNIX emulation.  So the VMS to UNIX conversions
5013          * now remove the fake /000000 directories.
5014          */
5015
5016         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5017         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5018             PerlMem_free(trndir);
5019             PerlMem_free(vmsdir);
5020             return NULL;
5021         }
5022         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5023             PerlMem_free(trndir);
5024             PerlMem_free(vmsdir);
5025             return NULL;
5026         }
5027         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5028         PerlMem_free(trndir);
5029         PerlMem_free(vmsdir);
5030         return ret_chr;
5031       }
5032       else {
5033
5034         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5035              !(lastdir = cp1 = strrchr(trndir,']')) &&
5036              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5037         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5038           int ver; char *cp3;
5039
5040           /* For EFS or ODS-5 look for the last dot */
5041           if (decc_efs_charset) {
5042               cp2 = strrchr(cp1,'.');
5043           }
5044           if (vms_process_case_tolerant) {
5045               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5046                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5047                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5048                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5049                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5050                             (ver || *cp3)))))) {
5051                   PerlMem_free(trndir);
5052                   PerlMem_free(vmsdir);
5053                   set_errno(ENOTDIR);
5054                   set_vaxc_errno(RMS$_DIR);
5055                   return NULL;
5056               }
5057           }
5058           else {
5059               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5060                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5061                   !*(cp2+3) || *(cp2+3) != 'R' ||
5062                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5063                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5064                             (ver || *cp3)))))) {
5065                  PerlMem_free(trndir);
5066                  PerlMem_free(vmsdir);
5067                  set_errno(ENOTDIR);
5068                  set_vaxc_errno(RMS$_DIR);
5069                  return NULL;
5070               }
5071           }
5072           dirlen = cp2 - trndir;
5073         }
5074       }
5075
5076       retlen = dirlen + 6;
5077       if (buf) retspec = buf;
5078       else if (ts) Newx(retspec,retlen+1,char);
5079       else retspec = __fileify_retbuf;
5080       memcpy(retspec,trndir,dirlen);
5081       retspec[dirlen] = '\0';
5082
5083       /* We've picked up everything up to the directory file name.
5084          Now just add the type and version, and we're set. */
5085       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5086         strcat(retspec,".dir;1");
5087       else
5088         strcat(retspec,".DIR;1");
5089       PerlMem_free(trndir);
5090       PerlMem_free(vmsdir);
5091       return retspec;
5092     }
5093     else {  /* VMS-style directory spec */
5094
5095       char *esa, term, *cp;
5096       unsigned long int sts, cmplen, haslower = 0;
5097       unsigned int nam_fnb;
5098       char * nam_type;
5099       struct FAB dirfab = cc$rms_fab;
5100       rms_setup_nam(savnam);
5101       rms_setup_nam(dirnam);
5102
5103       esa = PerlMem_malloc(VMS_MAXRSS + 1);
5104       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5105       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5106       rms_bind_fab_nam(dirfab, dirnam);
5107       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5108       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5109 #ifdef NAM$M_NO_SHORT_UPCASE
5110       if (decc_efs_case_preserve)
5111         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5112 #endif
5113
5114       for (cp = trndir; *cp; cp++)
5115         if (islower(*cp)) { haslower = 1; break; }
5116       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5117         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5118           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5119           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5120         }
5121         if (!sts) {
5122           PerlMem_free(esa);
5123           PerlMem_free(trndir);
5124           PerlMem_free(vmsdir);
5125           set_errno(EVMSERR);
5126           set_vaxc_errno(dirfab.fab$l_sts);
5127           return NULL;
5128         }
5129       }
5130       else {
5131         savnam = dirnam;
5132         /* Does the file really exist? */
5133         if (sys$search(&dirfab)& STS$K_SUCCESS) {
5134           /* Yes; fake the fnb bits so we'll check type below */
5135         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5136         }
5137         else { /* No; just work with potential name */
5138           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5139           else {
5140             int fab_sts;
5141             fab_sts = dirfab.fab$l_sts;
5142             sts = rms_free_search_context(&dirfab);
5143             PerlMem_free(esa);
5144             PerlMem_free(trndir);
5145             PerlMem_free(vmsdir);
5146             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
5147             return NULL;
5148           }
5149         }
5150       }
5151       esa[rms_nam_esll(dirnam)] = '\0';
5152       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5153         cp1 = strchr(esa,']');
5154         if (!cp1) cp1 = strchr(esa,'>');
5155         if (cp1) {  /* Should always be true */
5156           rms_nam_esll(dirnam) -= cp1 - esa - 1;
5157           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5158         }
5159       }
5160       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5161         /* Yep; check version while we're at it, if it's there. */
5162         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5163         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5164           /* Something other than .DIR[;1].  Bzzt. */
5165           sts = rms_free_search_context(&dirfab);
5166           PerlMem_free(esa);
5167           PerlMem_free(trndir);
5168           PerlMem_free(vmsdir);
5169           set_errno(ENOTDIR);
5170           set_vaxc_errno(RMS$_DIR);
5171           return NULL;
5172         }
5173       }
5174
5175       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5176         /* They provided at least the name; we added the type, if necessary, */
5177         if (buf) retspec = buf;                            /* in sys$parse() */
5178         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5179         else retspec = __fileify_retbuf;
5180         strcpy(retspec,esa);
5181         sts = rms_free_search_context(&dirfab);
5182         PerlMem_free(trndir);
5183         PerlMem_free(esa);
5184         PerlMem_free(vmsdir);
5185         return retspec;
5186       }
5187       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5188         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5189         *cp1 = '\0';
5190         rms_nam_esll(dirnam) -= 9;
5191       }
5192       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5193       if (cp1 == NULL) { /* should never happen */
5194         sts = rms_free_search_context(&dirfab);
5195         PerlMem_free(trndir);
5196         PerlMem_free(esa);
5197         PerlMem_free(vmsdir);
5198         return NULL;
5199       }
5200       term = *cp1;
5201       *cp1 = '\0';
5202       retlen = strlen(esa);
5203       cp1 = strrchr(esa,'.');
5204       /* ODS-5 directory specifications can have extra "." in them. */
5205       /* Fix-me, can not scan EFS file specifications backwards */
5206       while (cp1 != NULL) {
5207         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5208           break;
5209         else {
5210            cp1--;
5211            while ((cp1 > esa) && (*cp1 != '.'))
5212              cp1--;
5213         }
5214         if (cp1 == esa)
5215           cp1 = NULL;
5216       }
5217
5218       if ((cp1) != NULL) {
5219         /* There's more than one directory in the path.  Just roll back. */
5220         *cp1 = term;
5221         if (buf) retspec = buf;
5222         else if (ts) Newx(retspec,retlen+7,char);
5223         else retspec = __fileify_retbuf;
5224         strcpy(retspec,esa);
5225       }
5226       else {
5227         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5228           /* Go back and expand rooted logical name */
5229           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5230 #ifdef NAM$M_NO_SHORT_UPCASE
5231           if (decc_efs_case_preserve)
5232             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5233 #endif
5234           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5235             sts = rms_free_search_context(&dirfab);
5236             PerlMem_free(esa);
5237             PerlMem_free(trndir);
5238             PerlMem_free(vmsdir);
5239             set_errno(EVMSERR);
5240             set_vaxc_errno(dirfab.fab$l_sts);
5241             return NULL;
5242           }
5243           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5244           if (buf) retspec = buf;
5245           else if (ts) Newx(retspec,retlen+16,char);
5246           else retspec = __fileify_retbuf;
5247           cp1 = strstr(esa,"][");
5248           if (!cp1) cp1 = strstr(esa,"]<");
5249           dirlen = cp1 - esa;
5250           memcpy(retspec,esa,dirlen);
5251           if (!strncmp(cp1+2,"000000]",7)) {
5252             retspec[dirlen-1] = '\0';
5253             /* fix-me Not full ODS-5, just extra dots in directories for now */
5254             cp1 = retspec + dirlen - 1;
5255             while (cp1 > retspec)
5256             {
5257               if (*cp1 == '[')
5258                 break;
5259               if (*cp1 == '.') {
5260                 if (*(cp1-1) != '^')
5261                   break;
5262               }
5263               cp1--;
5264             }
5265             if (*cp1 == '.') *cp1 = ']';
5266             else {
5267               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5268               memmove(cp1+1,"000000]",7);
5269             }
5270           }
5271           else {
5272             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5273             retspec[retlen] = '\0';
5274             /* Convert last '.' to ']' */
5275             cp1 = retspec+retlen-1;
5276             while (*cp != '[') {
5277               cp1--;
5278               if (*cp1 == '.') {
5279                 /* Do not trip on extra dots in ODS-5 directories */
5280                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5281                 break;
5282               }
5283             }
5284             if (*cp1 == '.') *cp1 = ']';
5285             else {
5286               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5287               memmove(cp1+1,"000000]",7);
5288             }
5289           }
5290         }
5291         else {  /* This is a top-level dir.  Add the MFD to the path. */
5292           if (buf) retspec = buf;
5293           else if (ts) Newx(retspec,retlen+16,char);
5294           else retspec = __fileify_retbuf;
5295           cp1 = esa;
5296           cp2 = retspec;
5297           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5298           strcpy(cp2,":[000000]");
5299           cp1 += 2;
5300           strcpy(cp2+9,cp1);
5301         }
5302       }
5303       sts = rms_free_search_context(&dirfab);
5304       /* We've set up the string up through the filename.  Add the
5305          type and version, and we're done. */
5306       strcat(retspec,".DIR;1");
5307
5308       /* $PARSE may have upcased filespec, so convert output to lower
5309        * case if input contained any lowercase characters. */
5310       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5311       PerlMem_free(trndir);
5312       PerlMem_free(esa);
5313       PerlMem_free(vmsdir);
5314       return retspec;
5315     }
5316 }  /* end of do_fileify_dirspec() */
5317 /*}}}*/
5318 /* External entry points */
5319 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5320 { return do_fileify_dirspec(dir,buf,0,NULL); }
5321 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5322 { return do_fileify_dirspec(dir,buf,1,NULL); }
5323 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5324 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5325 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5326 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5327
5328 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5329 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5330 {
5331     static char __pathify_retbuf[VMS_MAXRSS];
5332     unsigned long int retlen;
5333     char *retpath, *cp1, *cp2, *trndir;
5334     unsigned short int trnlnm_iter_count;
5335     STRLEN trnlen;
5336     int sts;
5337     if (utf8_fl != NULL)
5338         *utf8_fl = 0;
5339
5340     if (!dir || !*dir) {
5341       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5342     }
5343
5344     trndir = PerlMem_malloc(VMS_MAXRSS);
5345     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5346     if (*dir) strcpy(trndir,dir);
5347     else getcwd(trndir,VMS_MAXRSS - 1);
5348
5349     trnlnm_iter_count = 0;
5350     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5351            && my_trnlnm(trndir,trndir,0)) {
5352       trnlnm_iter_count++;
5353       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5354       trnlen = strlen(trndir);
5355
5356       /* Trap simple rooted lnms, and return lnm:[000000] */
5357       if (!strcmp(trndir+trnlen-2,".]")) {
5358         if (buf) retpath = buf;
5359         else if (ts) Newx(retpath,strlen(dir)+10,char);
5360         else retpath = __pathify_retbuf;
5361         strcpy(retpath,dir);
5362         strcat(retpath,":[000000]");
5363         PerlMem_free(trndir);
5364         return retpath;
5365       }
5366     }
5367
5368     /* At this point we do not work with *dir, but the copy in
5369      * *trndir that is modifiable.
5370      */
5371
5372     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5373       if (*trndir == '.' && (*(trndir+1) == '\0' ||
5374                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5375         retlen = 2 + (*(trndir+1) != '\0');
5376       else {
5377         if ( !(cp1 = strrchr(trndir,'/')) &&
5378              !(cp1 = strrchr(trndir,']')) &&
5379              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5380         if ((cp2 = strchr(cp1,'.')) != NULL &&
5381             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
5382              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
5383               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5384               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5385           int ver; char *cp3;
5386
5387           /* For EFS or ODS-5 look for the last dot */
5388           if (decc_efs_charset) {
5389             cp2 = strrchr(cp1,'.');
5390           }
5391           if (vms_process_case_tolerant) {
5392               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5393                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5394                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5395                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5396                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5397                             (ver || *cp3)))))) {
5398                 PerlMem_free(trndir);
5399                 set_errno(ENOTDIR);
5400                 set_vaxc_errno(RMS$_DIR);
5401                 return NULL;
5402               }
5403           }
5404           else {
5405               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5406                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5407                   !*(cp2+3) || *(cp2+3) != 'R' ||
5408                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5409                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5410                             (ver || *cp3)))))) {
5411                 PerlMem_free(trndir);
5412                 set_errno(ENOTDIR);
5413                 set_vaxc_errno(RMS$_DIR);
5414                 return NULL;
5415               }
5416           }
5417           retlen = cp2 - trndir + 1;
5418         }
5419         else {  /* No file type present.  Treat the filename as a directory. */
5420           retlen = strlen(trndir) + 1;
5421         }
5422       }
5423       if (buf) retpath = buf;
5424       else if (ts) Newx(retpath,retlen+1,char);
5425       else retpath = __pathify_retbuf;
5426       strncpy(retpath, trndir, retlen-1);
5427       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5428         retpath[retlen-1] = '/';      /* with '/', add it. */
5429         retpath[retlen] = '\0';
5430       }
5431       else retpath[retlen-1] = '\0';
5432     }
5433     else {  /* VMS-style directory spec */
5434       char *esa, *cp;
5435       unsigned long int sts, cmplen, haslower;
5436       struct FAB dirfab = cc$rms_fab;
5437       int dirlen;
5438       rms_setup_nam(savnam);
5439       rms_setup_nam(dirnam);
5440
5441       /* If we've got an explicit filename, we can just shuffle the string. */
5442       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5443              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
5444         if ((cp2 = strchr(cp1,'.')) != NULL) {
5445           int ver; char *cp3;
5446           if (vms_process_case_tolerant) {
5447               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5448                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5449                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5450                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5451                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5452                             (ver || *cp3)))))) {
5453                PerlMem_free(trndir);
5454                set_errno(ENOTDIR);
5455                set_vaxc_errno(RMS$_DIR);
5456                return NULL;
5457              }
5458           }
5459           else {
5460               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5461                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5462                   !*(cp2+3) || *(cp2+3) != 'R' ||
5463                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5464                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5465                             (ver || *cp3)))))) {
5466                PerlMem_free(trndir);
5467                set_errno(ENOTDIR);
5468                set_vaxc_errno(RMS$_DIR);
5469                return NULL;
5470              }
5471           }
5472         }
5473         else {  /* No file type, so just draw name into directory part */
5474           for (cp2 = cp1; *cp2; cp2++) ;
5475         }
5476         *cp2 = *cp1;
5477         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5478         *cp1 = '.';
5479         /* We've now got a VMS 'path'; fall through */
5480       }
5481
5482       dirlen = strlen(trndir);
5483       if (trndir[dirlen-1] == ']' ||
5484           trndir[dirlen-1] == '>' ||
5485           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5486         if (buf) retpath = buf;
5487         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5488         else retpath = __pathify_retbuf;
5489         strcpy(retpath,trndir);
5490         PerlMem_free(trndir);
5491         return retpath;
5492       }
5493       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5494       esa = PerlMem_malloc(VMS_MAXRSS);
5495       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5496       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5497       rms_bind_fab_nam(dirfab, dirnam);
5498       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5499 #ifdef NAM$M_NO_SHORT_UPCASE
5500       if (decc_efs_case_preserve)
5501           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5502 #endif
5503
5504       for (cp = trndir; *cp; cp++)
5505         if (islower(*cp)) { haslower = 1; break; }
5506
5507       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5508         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5509           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5510           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5511         }
5512         if (!sts) {
5513           PerlMem_free(trndir);
5514           PerlMem_free(esa);
5515           set_errno(EVMSERR);
5516           set_vaxc_errno(dirfab.fab$l_sts);
5517           return NULL;
5518         }
5519       }
5520       else {
5521         savnam = dirnam;
5522         /* Does the file really exist? */
5523         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5524           if (dirfab.fab$l_sts != RMS$_FNF) {
5525             int sts1;
5526             sts1 = rms_free_search_context(&dirfab);
5527             PerlMem_free(trndir);
5528             PerlMem_free(esa);
5529             set_errno(EVMSERR);
5530             set_vaxc_errno(dirfab.fab$l_sts);
5531             return NULL;
5532           }
5533           dirnam = savnam; /* No; just work with potential name */
5534         }
5535       }
5536       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5537         /* Yep; check version while we're at it, if it's there. */
5538         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5539         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5540           int sts2;
5541           /* Something other than .DIR[;1].  Bzzt. */
5542           sts2 = rms_free_search_context(&dirfab);
5543           PerlMem_free(trndir);
5544           PerlMem_free(esa);
5545           set_errno(ENOTDIR);
5546           set_vaxc_errno(RMS$_DIR);
5547           return NULL;
5548         }
5549       }
5550       /* OK, the type was fine.  Now pull any file name into the
5551          directory path. */
5552       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5553       else {
5554         cp1 = strrchr(esa,'>');
5555         *(rms_nam_typel(dirnam)) = '>';
5556       }
5557       *cp1 = '.';
5558       *(rms_nam_typel(dirnam) + 1) = '\0';
5559       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5560       if (buf) retpath = buf;
5561       else if (ts) Newx(retpath,retlen,char);
5562       else retpath = __pathify_retbuf;
5563       strcpy(retpath,esa);
5564       PerlMem_free(esa);
5565       sts = rms_free_search_context(&dirfab);
5566       /* $PARSE may have upcased filespec, so convert output to lower
5567        * case if input contained any lowercase characters. */
5568       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5569     }
5570
5571     PerlMem_free(trndir);
5572     return retpath;
5573 }  /* end of do_pathify_dirspec() */
5574 /*}}}*/
5575 /* External entry points */
5576 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5577 { return do_pathify_dirspec(dir,buf,0,NULL); }
5578 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5579 { return do_pathify_dirspec(dir,buf,1,NULL); }
5580 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5581 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5582 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5583 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5584
5585 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5586 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5587 {
5588   static char __tounixspec_retbuf[VMS_MAXRSS];
5589   char *dirend, *rslt, *cp1, *cp3, *tmp;
5590   const char *cp2;
5591   int devlen, dirlen, retlen = VMS_MAXRSS;
5592   int expand = 1; /* guarantee room for leading and trailing slashes */
5593   unsigned short int trnlnm_iter_count;
5594   int cmp_rslt;
5595   if (utf8_fl != NULL)
5596     *utf8_fl = 0;
5597
5598   if (spec == NULL) return NULL;
5599   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5600   if (buf) rslt = buf;
5601   else if (ts) {
5602     Newx(rslt, VMS_MAXRSS, char);
5603   }
5604   else rslt = __tounixspec_retbuf;
5605
5606   /* New VMS specific format needs translation
5607    * glob passes filenames with trailing '\n' and expects this preserved.
5608    */
5609   if (decc_posix_compliant_pathnames) {
5610     if (strncmp(spec, "\"^UP^", 5) == 0) {
5611       char * uspec;
5612       char *tunix;
5613       int tunix_len;
5614       int nl_flag;
5615
5616       tunix = PerlMem_malloc(VMS_MAXRSS);
5617       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5618       strcpy(tunix, spec);
5619       tunix_len = strlen(tunix);
5620       nl_flag = 0;
5621       if (tunix[tunix_len - 1] == '\n') {
5622         tunix[tunix_len - 1] = '\"';
5623         tunix[tunix_len] = '\0';
5624         tunix_len--;
5625         nl_flag = 1;
5626       }
5627       uspec = decc$translate_vms(tunix);
5628       PerlMem_free(tunix);
5629       if ((int)uspec > 0) {
5630         strcpy(rslt,uspec);
5631         if (nl_flag) {
5632           strcat(rslt,"\n");
5633         }
5634         else {
5635           /* If we can not translate it, makemaker wants as-is */
5636           strcpy(rslt, spec);
5637         }
5638         return rslt;
5639       }
5640     }
5641   }
5642
5643   cmp_rslt = 0; /* Presume VMS */
5644   cp1 = strchr(spec, '/');
5645   if (cp1 == NULL)
5646     cmp_rslt = 0;
5647
5648     /* Look for EFS ^/ */
5649     if (decc_efs_charset) {
5650       while (cp1 != NULL) {
5651         cp2 = cp1 - 1;
5652         if (*cp2 != '^') {
5653           /* Found illegal VMS, assume UNIX */
5654           cmp_rslt = 1;
5655           break;
5656         }
5657       cp1++;
5658       cp1 = strchr(cp1, '/');
5659     }
5660   }
5661
5662   /* Look for "." and ".." */
5663   if (decc_filename_unix_report) {
5664     if (spec[0] == '.') {
5665       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5666         cmp_rslt = 1;
5667       }
5668       else {
5669         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5670           cmp_rslt = 1;
5671         }
5672       }
5673     }
5674   }
5675   /* This is already UNIX or at least nothing VMS understands */
5676   if (cmp_rslt) {
5677     strcpy(rslt,spec);
5678     return rslt;
5679   }
5680
5681   cp1 = rslt;
5682   cp2 = spec;
5683   dirend = strrchr(spec,']');
5684   if (dirend == NULL) dirend = strrchr(spec,'>');
5685   if (dirend == NULL) dirend = strchr(spec,':');
5686   if (dirend == NULL) {
5687     strcpy(rslt,spec);
5688     return rslt;
5689   }
5690
5691   /* Special case 1 - sys$posix_root = / */
5692 #if __CRTL_VER >= 70000000
5693   if (!decc_disable_posix_root) {
5694     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5695       *cp1 = '/';
5696       cp1++;
5697       cp2 = cp2 + 15;
5698       }
5699   }
5700 #endif
5701
5702   /* Special case 2 - Convert NLA0: to /dev/null */
5703 #if __CRTL_VER < 70000000
5704   cmp_rslt = strncmp(spec,"NLA0:", 5);
5705   if (cmp_rslt != 0)
5706      cmp_rslt = strncmp(spec,"nla0:", 5);
5707 #else
5708   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5709 #endif
5710   if (cmp_rslt == 0) {
5711     strcpy(rslt, "/dev/null");
5712     cp1 = cp1 + 9;
5713     cp2 = cp2 + 5;
5714     if (spec[6] != '\0') {
5715       cp1[9] == '/';
5716       cp1++;
5717       cp2++;
5718     }
5719   }
5720
5721    /* Also handle special case "SYS$SCRATCH:" */
5722 #if __CRTL_VER < 70000000
5723   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5724   if (cmp_rslt != 0)
5725      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5726 #else
5727   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5728 #endif
5729   tmp = PerlMem_malloc(VMS_MAXRSS);
5730   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
5731   if (cmp_rslt == 0) {
5732   int islnm;
5733
5734     islnm = my_trnlnm(tmp, "TMP", 0);
5735     if (!islnm) {
5736       strcpy(rslt, "/tmp");
5737       cp1 = cp1 + 4;
5738       cp2 = cp2 + 12;
5739       if (spec[12] != '\0') {
5740         cp1[4] == '/';
5741         cp1++;
5742         cp2++;
5743       }
5744     }
5745   }
5746
5747   if (*cp2 != '[' && *cp2 != '<') {
5748     *(cp1++) = '/';
5749   }
5750   else {  /* the VMS spec begins with directories */
5751     cp2++;
5752     if (*cp2 == ']' || *cp2 == '>') {
5753       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5754       PerlMem_free(tmp);
5755       return rslt;
5756     }
5757     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5758       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
5759         if (ts) Safefree(rslt);
5760         PerlMem_free(tmp);
5761         return NULL;
5762       }
5763       trnlnm_iter_count = 0;
5764       do {
5765         cp3 = tmp;
5766         while (*cp3 != ':' && *cp3) cp3++;
5767         *(cp3++) = '\0';
5768         if (strchr(cp3,']') != NULL) break;
5769         trnlnm_iter_count++;
5770         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5771       } while (vmstrnenv(tmp,tmp,0,fildev,0));
5772       if (ts && !buf &&
5773           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5774         retlen = devlen + dirlen;
5775         Renew(rslt,retlen+1+2*expand,char);
5776         cp1 = rslt;
5777       }
5778       cp3 = tmp;
5779       *(cp1++) = '/';
5780       while (*cp3) {
5781         *(cp1++) = *(cp3++);
5782         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
5783             PerlMem_free(tmp);
5784             return NULL; /* No room */
5785         }
5786       }
5787       *(cp1++) = '/';
5788     }
5789     if ((*cp2 == '^')) {
5790         /* EFS file escape, pass the next character as is */
5791         /* Fix me: HEX encoding for UNICODE not implemented */
5792         cp2++;
5793     }
5794     else if ( *cp2 == '.') {
5795       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5796         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5797         cp2 += 3;
5798       }
5799       else cp2++;
5800     }
5801   }
5802   PerlMem_free(tmp);
5803   for (; cp2 <= dirend; cp2++) {
5804     if ((*cp2 == '^')) {
5805         /* EFS file escape, pass the next character as is */
5806         /* Fix me: HEX encoding for UNICODE not implemented */
5807         cp2++;
5808         *(cp1++) = *cp2;
5809     }
5810     if (*cp2 == ':') {
5811       *(cp1++) = '/';
5812       if (*(cp2+1) == '[') cp2++;
5813     }
5814     else if (*cp2 == ']' || *cp2 == '>') {
5815       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5816     }
5817     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5818       *(cp1++) = '/';
5819       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5820         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5821                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5822         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5823             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5824       }
5825       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5826         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5827         cp2 += 2;
5828       }
5829     }
5830     else if (*cp2 == '-') {
5831       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5832         while (*cp2 == '-') {
5833           cp2++;
5834           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5835         }
5836         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5837           if (ts) Safefree(rslt);                        /* filespecs like */
5838           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
5839           return NULL;
5840         }
5841       }
5842       else *(cp1++) = *cp2;
5843     }
5844     else *(cp1++) = *cp2;
5845   }
5846   while (*cp2) *(cp1++) = *(cp2++);
5847   *cp1 = '\0';
5848
5849   /* This still leaves /000000/ when working with a
5850    * VMS device root or concealed root.
5851    */
5852   {
5853   int ulen;
5854   char * zeros;
5855
5856       ulen = strlen(rslt);
5857
5858       /* Get rid of "000000/ in rooted filespecs */
5859       if (ulen > 7) {
5860         zeros = strstr(rslt, "/000000/");
5861         if (zeros != NULL) {
5862           int mlen;
5863           mlen = ulen - (zeros - rslt) - 7;
5864           memmove(zeros, &zeros[7], mlen);
5865           ulen = ulen - 7;
5866           rslt[ulen] = '\0';
5867         }
5868       }
5869   }
5870
5871   return rslt;
5872
5873 }  /* end of do_tounixspec() */
5874 /*}}}*/
5875 /* External entry points */
5876 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
5877   { return do_tounixspec(spec,buf,0, NULL); }
5878 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
5879   { return do_tounixspec(spec,buf,1, NULL); }
5880 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
5881   { return do_tounixspec(spec,buf,0, utf8_fl); }
5882 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
5883   { return do_tounixspec(spec,buf,1, utf8_fl); }
5884
5885 #if __CRTL_VER >= 70200000 && !defined(__VAX)
5886
5887 /*
5888  This procedure is used to identify if a path is based in either
5889  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
5890  it returns the OpenVMS format directory for it.
5891
5892  It is expecting specifications of only '/' or '/xxxx/'
5893
5894  If a posix root does not exist, or 'xxxx' is not a directory
5895  in the posix root, it returns a failure.
5896
5897  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
5898
5899  It is used only internally by posix_to_vmsspec_hardway().
5900  */
5901
5902 static int posix_root_to_vms
5903   (char *vmspath, int vmspath_len,
5904    const char *unixpath,
5905    const int * utf8_fl) {
5906 int sts;
5907 struct FAB myfab = cc$rms_fab;
5908 struct NAML mynam = cc$rms_naml;
5909 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5910  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5911 char *esa;
5912 char *vms_delim;
5913 int dir_flag;
5914 int unixlen;
5915
5916     dir_flag = 0;
5917     unixlen = strlen(unixpath);
5918     if (unixlen == 0) {
5919       vmspath[0] = '\0';
5920       return RMS$_FNF;
5921     }
5922
5923 #if __CRTL_VER >= 80200000
5924   /* If not a posix spec already, convert it */
5925   if (decc_posix_compliant_pathnames) {
5926     if (strncmp(unixpath,"\"^UP^",5) != 0) {
5927       sprintf(vmspath,"\"^UP^%s\"",unixpath);
5928     }
5929     else {
5930       /* This is already a VMS specification, no conversion */
5931       unixlen--;
5932       strncpy(vmspath,unixpath, vmspath_len);
5933     }
5934   }
5935   else
5936 #endif
5937   {
5938   int path_len;
5939   int i,j;
5940
5941      /* Check to see if this is under the POSIX root */
5942      if (decc_disable_posix_root) {
5943         return RMS$_FNF;
5944      }
5945
5946      /* Skip leading / */
5947      if (unixpath[0] == '/') {
5948         unixpath++;
5949         unixlen--;
5950      }
5951
5952
5953      strcpy(vmspath,"SYS$POSIX_ROOT:");
5954
5955      /* If this is only the / , or blank, then... */
5956      if (unixpath[0] == '\0') {
5957         /* by definition, this is the answer */
5958         return SS$_NORMAL;
5959      }
5960
5961      /* Need to look up a directory */
5962      vmspath[15] = '[';
5963      vmspath[16] = '\0';
5964
5965      /* Copy and add '^' escape characters as needed */
5966      j = 16;
5967      i = 0;
5968      while (unixpath[i] != 0) {
5969      int k;
5970
5971         j += copy_expand_unix_filename_escape
5972             (&vmspath[j], &unixpath[i], &k, utf8_fl);
5973         i += k;
5974      }
5975
5976      path_len = strlen(vmspath);
5977      if (vmspath[path_len - 1] == '/')
5978         path_len--;
5979      vmspath[path_len] = ']';
5980      path_len++;
5981      vmspath[path_len] = '\0';
5982
5983   }
5984   vmspath[vmspath_len] = 0;
5985   if (unixpath[unixlen - 1] == '/')
5986   dir_flag = 1;
5987   esa = PerlMem_malloc(VMS_MAXRSS);
5988   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5989   myfab.fab$l_fna = vmspath;
5990   myfab.fab$b_fns = strlen(vmspath);
5991   myfab.fab$l_naml = &mynam;
5992   mynam.naml$l_esa = NULL;
5993   mynam.naml$b_ess = 0;
5994   mynam.naml$l_long_expand = esa;
5995   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
5996   mynam.naml$l_rsa = NULL;
5997   mynam.naml$b_rss = 0;
5998   if (decc_efs_case_preserve)
5999     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6000 #ifdef NAML$M_OPEN_SPECIAL
6001   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6002 #endif
6003
6004   /* Set up the remaining naml fields */
6005   sts = sys$parse(&myfab);
6006
6007   /* It failed! Try again as a UNIX filespec */
6008   if (!(sts & 1)) {
6009     PerlMem_free(esa);
6010     return sts;
6011   }
6012
6013    /* get the Device ID and the FID */
6014    sts = sys$search(&myfab);
6015    /* on any failure, returned the POSIX ^UP^ filespec */
6016    if (!(sts & 1)) {
6017       PerlMem_free(esa);
6018       return sts;
6019    }
6020    specdsc.dsc$a_pointer = vmspath;
6021    specdsc.dsc$w_length = vmspath_len;
6022
6023    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6024    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6025    sts = lib$fid_to_name
6026       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6027
6028   /* on any failure, returned the POSIX ^UP^ filespec */
6029   if (!(sts & 1)) {
6030      /* This can happen if user does not have permission to read directories */
6031      if (strncmp(unixpath,"\"^UP^",5) != 0)
6032        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6033      else
6034        strcpy(vmspath, unixpath);
6035   }
6036   else {
6037     vmspath[specdsc.dsc$w_length] = 0;
6038
6039     /* Are we expecting a directory? */
6040     if (dir_flag != 0) {
6041     int i;
6042     char *eptr;
6043
6044       eptr = NULL;
6045
6046       i = specdsc.dsc$w_length - 1;
6047       while (i > 0) {
6048       int zercnt;
6049         zercnt = 0;
6050         /* Version must be '1' */
6051         if (vmspath[i--] != '1')
6052           break;
6053         /* Version delimiter is one of ".;" */
6054         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6055           break;
6056         i--;
6057         if (vmspath[i--] != 'R')
6058           break;
6059         if (vmspath[i--] != 'I')
6060           break;
6061         if (vmspath[i--] != 'D')
6062           break;
6063         if (vmspath[i--] != '.')
6064           break;
6065         eptr = &vmspath[i+1];
6066         while (i > 0) {
6067           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6068             if (vmspath[i-1] != '^') {
6069               if (zercnt != 6) {
6070                 *eptr = vmspath[i];
6071                 eptr[1] = '\0';
6072                 vmspath[i] = '.';
6073                 break;
6074               }
6075               else {
6076                 /* Get rid of 6 imaginary zero directory filename */
6077                 vmspath[i+1] = '\0';
6078               }
6079             }
6080           }
6081           if (vmspath[i] == '0')
6082             zercnt++;
6083           else
6084             zercnt = 10;
6085           i--;
6086         }
6087         break;
6088       }
6089     }
6090   }
6091   PerlMem_free(esa);
6092   return sts;
6093 }
6094
6095 /* /dev/mumble needs to be handled special.
6096    /dev/null becomes NLA0:, And there is the potential for other stuff
6097    like /dev/tty which may need to be mapped to something.
6098 */
6099
6100 static int
6101 slash_dev_special_to_vms
6102    (const char * unixptr,
6103     char * vmspath,
6104     int vmspath_len)
6105 {
6106 char * nextslash;
6107 int len;
6108 int cmp;
6109 int islnm;
6110
6111     unixptr += 4;
6112     nextslash = strchr(unixptr, '/');
6113     len = strlen(unixptr);
6114     if (nextslash != NULL)
6115         len = nextslash - unixptr;
6116     cmp = strncmp("null", unixptr, 5);
6117     if (cmp == 0) {
6118         if (vmspath_len >= 6) {
6119             strcpy(vmspath, "_NLA0:");
6120             return SS$_NORMAL;
6121         }
6122     }
6123 }
6124
6125
6126 /* The built in routines do not understand perl's special needs, so
6127     doing a manual conversion from UNIX to VMS
6128
6129     If the utf8_fl is not null and points to a non-zero value, then
6130     treat 8 bit characters as UTF-8.
6131
6132     The sequence starting with '$(' and ending with ')' will be passed
6133     through with out interpretation instead of being escaped.
6134
6135   */
6136 static int posix_to_vmsspec_hardway
6137   (char *vmspath, int vmspath_len,
6138    const char *unixpath,
6139    int dir_flag,
6140    int * utf8_fl) {
6141
6142 char *esa;
6143 const char *unixptr;
6144 const char *unixend;
6145 char *vmsptr;
6146 const char *lastslash;
6147 const char *lastdot;
6148 int unixlen;
6149 int vmslen;
6150 int dir_start;
6151 int dir_dot;
6152 int quoted;
6153 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6154 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6155
6156   if (utf8_fl != NULL)
6157     *utf8_fl = 0;
6158
6159   unixptr = unixpath;
6160   dir_dot = 0;
6161
6162   /* Ignore leading "/" characters */
6163   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6164     unixptr++;
6165   }
6166   unixlen = strlen(unixptr);
6167
6168   /* Do nothing with blank paths */
6169   if (unixlen == 0) {
6170     vmspath[0] = '\0';
6171     return SS$_NORMAL;
6172   }
6173
6174   quoted = 0;
6175   /* This could have a "^UP^ on the front */
6176   if (strncmp(unixptr,"\"^UP^",5) == 0) {
6177     quoted = 1;
6178     unixptr+= 5;
6179     unixlen-= 5;
6180   }
6181
6182   lastslash = strrchr(unixptr,'/');
6183   lastdot = strrchr(unixptr,'.');
6184   unixend = strrchr(unixptr,'\"');
6185   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6186     unixend = unixptr + unixlen;
6187   }
6188
6189   /* last dot is last dot or past end of string */
6190   if (lastdot == NULL)
6191     lastdot = unixptr + unixlen;
6192
6193   /* if no directories, set last slash to beginning of string */
6194   if (lastslash == NULL) {
6195     lastslash = unixptr;
6196   }
6197   else {
6198     /* Watch out for trailing "." after last slash, still a directory */
6199     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6200       lastslash = unixptr + unixlen;
6201     }
6202
6203     /* Watch out for traiing ".." after last slash, still a directory */
6204     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6205       lastslash = unixptr + unixlen;
6206     }
6207
6208     /* dots in directories are aways escaped */
6209     if (lastdot < lastslash)
6210       lastdot = unixptr + unixlen;
6211   }
6212
6213   /* if (unixptr < lastslash) then we are in a directory */
6214
6215   dir_start = 0;
6216
6217   vmsptr = vmspath;
6218   vmslen = 0;
6219
6220   /* Start with the UNIX path */
6221   if (*unixptr != '/') {
6222     /* relative paths */
6223
6224     /* If allowing logical names on relative pathnames, then handle here */
6225     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6226         !decc_posix_compliant_pathnames) {
6227     char * nextslash;
6228     int seg_len;
6229     char * trn;
6230     int islnm;
6231
6232         /* Find the next slash */
6233         nextslash = strchr(unixptr,'/');
6234
6235         esa = PerlMem_malloc(vmspath_len);
6236         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6237
6238         trn = PerlMem_malloc(VMS_MAXRSS);
6239         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6240
6241         if (nextslash != NULL) {
6242
6243             seg_len = nextslash - unixptr;
6244             strncpy(esa, unixptr, seg_len);
6245             esa[seg_len] = 0;
6246         }
6247         else {
6248             strcpy(esa, unixptr);
6249             seg_len = strlen(unixptr);
6250         }
6251         /* trnlnm(section) */
6252         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6253
6254         if (islnm) {
6255             /* Now fix up the directory */
6256
6257             /* Split up the path to find the components */
6258             sts = vms_split_path
6259                   (trn,
6260                    &v_spec,
6261                    &v_len,
6262                    &r_spec,
6263                    &r_len,
6264                    &d_spec,
6265                    &d_len,
6266                    &n_spec,
6267                    &n_len,
6268                    &e_spec,
6269                    &e_len,
6270                    &vs_spec,
6271                    &vs_len);
6272
6273             while (sts == 0) {
6274             char * strt;
6275             int cmp;
6276
6277                 /* A logical name must be a directory  or the full
6278                    specification.  It is only a full specification if
6279                    it is the only component */
6280                 if ((unixptr[seg_len] == '\0') ||
6281                     (unixptr[seg_len+1] == '\0')) {
6282
6283                     /* Is a directory being required? */
6284                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6285                         /* Not a logical name */
6286                         break;
6287                     }
6288
6289
6290                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6291                         /* This must be a directory */
6292                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6293                             strcpy(vmsptr, esa);
6294                             vmslen=strlen(vmsptr);
6295                             vmsptr[vmslen] = ':';
6296                             vmslen++;
6297                             vmsptr[vmslen] = '\0';
6298                             return SS$_NORMAL;
6299                         }
6300                     }
6301
6302                 }
6303
6304
6305                 /* must be dev/directory - ignore version */
6306                 if ((n_len + e_len) != 0)
6307                     break;
6308
6309                 /* transfer the volume */
6310                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6311                     strncpy(vmsptr, v_spec, v_len);
6312                     vmsptr += v_len;
6313                     vmsptr[0] = '\0';
6314                     vmslen += v_len;
6315                 }
6316
6317                 /* unroot the rooted directory */
6318                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6319                     r_spec[0] = '[';
6320                     r_spec[r_len - 1] = ']';
6321
6322                     /* This should not be there, but nothing is perfect */
6323                     if (r_len > 9) {
6324                         cmp = strcmp(&r_spec[1], "000000.");
6325                         if (cmp == 0) {
6326                             r_spec += 7;
6327                             r_spec[7] = '[';
6328                             r_len -= 7;
6329                             if (r_len == 2)
6330                                 r_len = 0;
6331                         }
6332                     }
6333                     if (r_len > 0) {
6334                         strncpy(vmsptr, r_spec, r_len);
6335                         vmsptr += r_len;
6336                         vmslen += r_len;
6337                         vmsptr[0] = '\0';
6338                     }
6339                 }
6340                 /* Bring over the directory. */
6341                 if ((d_len > 0) &&
6342                     ((d_len + vmslen) < vmspath_len)) {
6343                     d_spec[0] = '[';
6344                     d_spec[d_len - 1] = ']';
6345                     if (d_len > 9) {
6346                         cmp = strcmp(&d_spec[1], "000000.");
6347                         if (cmp == 0) {
6348                             d_spec += 7;
6349                             d_spec[7] = '[';
6350                             d_len -= 7;
6351                             if (d_len == 2)
6352                                 d_len = 0;
6353                         }
6354                     }
6355
6356                     if (r_len > 0) {
6357                         /* Remove the redundant root */
6358                         if (r_len > 0) {
6359                             /* remove the ][ */
6360                             vmsptr--;
6361                             vmslen--;
6362                             d_spec++;
6363                             d_len--;
6364                         }
6365                         strncpy(vmsptr, d_spec, d_len);
6366                             vmsptr += d_len;
6367                             vmslen += d_len;
6368                             vmsptr[0] = '\0';
6369                     }
6370                 }
6371                 break;
6372             }
6373         }
6374
6375         PerlMem_free(esa);
6376         PerlMem_free(trn);
6377     }
6378
6379     if (lastslash > unixptr) {
6380     int dotdir_seen;
6381
6382       /* skip leading ./ */
6383       dotdir_seen = 0;
6384       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6385         dotdir_seen = 1;
6386         unixptr++;
6387         unixptr++;
6388       }
6389
6390       /* Are we still in a directory? */
6391       if (unixptr <= lastslash) {
6392         *vmsptr++ = '[';
6393         vmslen = 1;
6394         dir_start = 1;
6395
6396         /* if not backing up, then it is relative forward. */
6397         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6398               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6399           *vmsptr++ = '.';
6400           vmslen++;
6401           dir_dot = 1;
6402           }
6403        }
6404        else {
6405          if (dotdir_seen) {
6406            /* Perl wants an empty directory here to tell the difference
6407             * between a DCL commmand and a filename
6408             */
6409           *vmsptr++ = '[';
6410           *vmsptr++ = ']';
6411           vmslen = 2;
6412         }
6413       }
6414     }
6415     else {
6416       /* Handle two special files . and .. */
6417       if (unixptr[0] == '.') {
6418         if (&unixptr[1] == unixend) {
6419           *vmsptr++ = '[';
6420           *vmsptr++ = ']';
6421           vmslen += 2;
6422           *vmsptr++ = '\0';
6423           return SS$_NORMAL;
6424         }
6425         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6426           *vmsptr++ = '[';
6427           *vmsptr++ = '-';
6428           *vmsptr++ = ']';
6429           vmslen += 3;
6430           *vmsptr++ = '\0';
6431           return SS$_NORMAL;
6432         }
6433       }
6434     }
6435   }
6436   else {        /* Absolute PATH handling */
6437   int sts;
6438   char * nextslash;
6439   int seg_len;
6440     /* Need to find out where root is */
6441
6442     /* In theory, this procedure should never get an absolute POSIX pathname
6443      * that can not be found on the POSIX root.
6444      * In practice, that can not be relied on, and things will show up
6445      * here that are a VMS device name or concealed logical name instead.
6446      * So to make things work, this procedure must be tolerant.
6447      */
6448     esa = PerlMem_malloc(vmspath_len);
6449     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6450
6451     sts = SS$_NORMAL;
6452     nextslash = strchr(&unixptr[1],'/');
6453     seg_len = 0;
6454     if (nextslash != NULL) {
6455     int cmp;
6456       seg_len = nextslash - &unixptr[1];
6457       strncpy(vmspath, unixptr, seg_len + 1);
6458       vmspath[seg_len+1] = 0;
6459       cmp = 1;
6460       if (seg_len == 3) {
6461         cmp = strncmp(vmspath, "dev", 4);
6462         if (cmp == 0) {
6463             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6464             if (sts = SS$_NORMAL)
6465                 return SS$_NORMAL;
6466         }
6467       }
6468       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6469     }
6470
6471     if ($VMS_STATUS_SUCCESS(sts)) {
6472       /* This is verified to be a real path */
6473
6474       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6475       if ($VMS_STATUS_SUCCESS(sts)) {
6476         strcpy(vmspath, esa);
6477         vmslen = strlen(vmspath);
6478         vmsptr = vmspath + vmslen;
6479         unixptr++;
6480         if (unixptr < lastslash) {
6481         char * rptr;
6482           vmsptr--;
6483           *vmsptr++ = '.';
6484           dir_start = 1;
6485           dir_dot = 1;
6486           if (vmslen > 7) {
6487           int cmp;
6488             rptr = vmsptr - 7;
6489             cmp = strcmp(rptr,"000000.");
6490             if (cmp == 0) {
6491               vmslen -= 7;
6492               vmsptr -= 7;
6493               vmsptr[1] = '\0';
6494             } /* removing 6 zeros */
6495           } /* vmslen < 7, no 6 zeros possible */
6496         } /* Not in a directory */
6497       } /* Posix root found */
6498       else {
6499         /* No posix root, fall back to default directory */
6500         strcpy(vmspath, "SYS$DISK:[");
6501         vmsptr = &vmspath[10];
6502         vmslen = 10;
6503         if (unixptr > lastslash) {
6504            *vmsptr = ']';
6505            vmsptr++;
6506            vmslen++;
6507         }
6508         else {
6509            dir_start = 1;
6510         }
6511       }
6512     } /* end of verified real path handling */
6513     else {
6514     int add_6zero;
6515     int islnm;
6516
6517       /* Ok, we have a device or a concealed root that is not in POSIX
6518        * or we have garbage.  Make the best of it.
6519        */
6520
6521       /* Posix to VMS destroyed this, so copy it again */
6522       strncpy(vmspath, &unixptr[1], seg_len);
6523       vmspath[seg_len] = 0;
6524       vmslen = seg_len;
6525       vmsptr = &vmsptr[vmslen];
6526       islnm = 0;
6527
6528       /* Now do we need to add the fake 6 zero directory to it? */
6529       add_6zero = 1;
6530       if ((*lastslash == '/') && (nextslash < lastslash)) {
6531         /* No there is another directory */
6532         add_6zero = 0;
6533       }
6534       else {
6535       int trnend;
6536       int cmp;
6537
6538         /* now we have foo:bar or foo:[000000]bar to decide from */
6539         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6540
6541         if (!islnm && !decc_posix_compliant_pathnames) {
6542
6543             cmp = strncmp("bin", vmspath, 4);
6544             if (cmp == 0) {
6545                 /* bin => SYS$SYSTEM: */
6546                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6547             }
6548             else {
6549                 /* tmp => SYS$SCRATCH: */
6550                 cmp = strncmp("tmp", vmspath, 4);
6551                 if (cmp == 0) {
6552                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6553                 }
6554             }
6555         }
6556
6557         trnend = islnm ? islnm - 1 : 0;
6558
6559         /* if this was a logical name, ']' or '>' must be present */
6560         /* if not a logical name, then assume a device and hope. */
6561         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6562
6563         /* if log name and trailing '.' then rooted - treat as device */
6564         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6565
6566         /* Fix me, if not a logical name, a device lookup should be
6567          * done to see if the device is file structured.  If the device
6568          * is not file structured, the 6 zeros should not be put on.
6569          *
6570          * As it is, perl is occasionally looking for dev:[000000]tty.
6571          * which looks a little strange.
6572          *
6573          * Not that easy to detect as "/dev" may be file structured with
6574          * special device files.
6575          */
6576
6577         if ((add_6zero == 0) && (*nextslash == '/') &&
6578             (&nextslash[1] == unixend)) {
6579           /* No real directory present */
6580           add_6zero = 1;
6581         }
6582       }
6583
6584       /* Put the device delimiter on */
6585       *vmsptr++ = ':';
6586       vmslen++;
6587       unixptr = nextslash;
6588       unixptr++;
6589
6590       /* Start directory if needed */
6591       if (!islnm || add_6zero) {
6592         *vmsptr++ = '[';
6593         vmslen++;
6594         dir_start = 1;
6595       }
6596
6597       /* add fake 000000] if needed */
6598       if (add_6zero) {
6599         *vmsptr++ = '0';
6600         *vmsptr++ = '0';
6601         *vmsptr++ = '0';
6602         *vmsptr++ = '0';
6603         *vmsptr++ = '0';
6604         *vmsptr++ = '0';
6605         *vmsptr++ = ']';
6606         vmslen += 7;
6607         dir_start = 0;
6608       }
6609
6610     } /* non-POSIX translation */
6611     PerlMem_free(esa);
6612   } /* End of relative/absolute path handling */
6613
6614   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6615   int dash_flag;
6616   int in_cnt;
6617   int out_cnt;
6618
6619     dash_flag = 0;
6620
6621     if (dir_start != 0) {
6622
6623       /* First characters in a directory are handled special */
6624       while ((*unixptr == '/') ||
6625              ((*unixptr == '.') &&
6626               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6627                 (&unixptr[1]==unixend)))) {
6628       int loop_flag;
6629
6630         loop_flag = 0;
6631
6632         /* Skip redundant / in specification */
6633         while ((*unixptr == '/') && (dir_start != 0)) {
6634           loop_flag = 1;
6635           unixptr++;
6636           if (unixptr == lastslash)
6637             break;
6638         }
6639         if (unixptr == lastslash)
6640           break;
6641
6642         /* Skip redundant ./ characters */
6643         while ((*unixptr == '.') &&
6644                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6645           loop_flag = 1;
6646           unixptr++;
6647           if (unixptr == lastslash)
6648             break;
6649           if (*unixptr == '/')
6650             unixptr++;
6651         }
6652         if (unixptr == lastslash)
6653           break;
6654
6655         /* Skip redundant ../ characters */
6656         while ((*unixptr == '.') && (unixptr[1] == '.') &&
6657              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6658           /* Set the backing up flag */
6659           loop_flag = 1;
6660           dir_dot = 0;
6661           dash_flag = 1;
6662           *vmsptr++ = '-';
6663           vmslen++;
6664           unixptr++; /* first . */
6665           unixptr++; /* second . */
6666           if (unixptr == lastslash)
6667             break;
6668           if (*unixptr == '/') /* The slash */
6669             unixptr++;
6670         }
6671         if (unixptr == lastslash)
6672           break;
6673
6674         /* To do: Perl expects /.../ to be translated to [...] on VMS */
6675         /* Not needed when VMS is pretending to be UNIX. */
6676
6677         /* Is this loop stuck because of too many dots? */
6678         if (loop_flag == 0) {
6679           /* Exit the loop and pass the rest through */
6680           break;
6681         }
6682       }
6683
6684       /* Are we done with directories yet? */
6685       if (unixptr >= lastslash) {
6686
6687         /* Watch out for trailing dots */
6688         if (dir_dot != 0) {
6689             vmslen --;
6690             vmsptr--;
6691         }
6692         *vmsptr++ = ']';
6693         vmslen++;
6694         dash_flag = 0;
6695         dir_start = 0;
6696         if (*unixptr == '/')
6697           unixptr++;
6698       }
6699       else {
6700         /* Have we stopped backing up? */
6701         if (dash_flag) {
6702           *vmsptr++ = '.';
6703           vmslen++;
6704           dash_flag = 0;
6705           /* dir_start continues to be = 1 */
6706         }
6707         if (*unixptr == '-') {
6708           *vmsptr++ = '^';
6709           *vmsptr++ = *unixptr++;
6710           vmslen += 2;
6711           dir_start = 0;
6712
6713           /* Now are we done with directories yet? */
6714           if (unixptr >= lastslash) {
6715
6716             /* Watch out for trailing dots */
6717             if (dir_dot != 0) {
6718               vmslen --;
6719               vmsptr--;
6720             }
6721
6722             *vmsptr++ = ']';
6723             vmslen++;
6724             dash_flag = 0;
6725             dir_start = 0;
6726           }
6727         }
6728       }
6729     }
6730
6731     /* All done? */
6732     if (unixptr >= unixend)
6733       break;
6734
6735     /* Normal characters - More EFS work probably needed */
6736     dir_start = 0;
6737     dir_dot = 0;
6738
6739     switch(*unixptr) {
6740     case '/':
6741         /* remove multiple / */
6742         while (unixptr[1] == '/') {
6743            unixptr++;
6744         }
6745         if (unixptr == lastslash) {
6746           /* Watch out for trailing dots */
6747           if (dir_dot != 0) {
6748             vmslen --;
6749             vmsptr--;
6750           }
6751           *vmsptr++ = ']';
6752         }
6753         else {
6754           dir_start = 1;
6755           *vmsptr++ = '.';
6756           dir_dot = 1;
6757
6758           /* To do: Perl expects /.../ to be translated to [...] on VMS */
6759           /* Not needed when VMS is pretending to be UNIX. */
6760
6761         }
6762         dash_flag = 0;
6763         if (unixptr != unixend)
6764           unixptr++;
6765         vmslen++;
6766         break;
6767     case '.':
6768         if ((unixptr < lastdot) || (unixptr < lastslash) ||
6769             (&unixptr[1] == unixend)) {
6770           *vmsptr++ = '^';
6771           *vmsptr++ = '.';
6772           vmslen += 2;
6773           unixptr++;
6774
6775           /* trailing dot ==> '^..' on VMS */
6776           if (unixptr == unixend) {
6777             *vmsptr++ = '.';
6778             vmslen++;
6779             unixptr++;
6780           }
6781           break;
6782         }
6783
6784         *vmsptr++ = *unixptr++;
6785         vmslen ++;
6786         break;
6787     case '"':
6788         if (quoted && (&unixptr[1] == unixend)) {
6789             unixptr++;
6790             break;
6791         }
6792         in_cnt = copy_expand_unix_filename_escape
6793                 (vmsptr, unixptr, &out_cnt, utf8_fl);
6794         vmsptr += out_cnt;
6795         unixptr += in_cnt;
6796         break;
6797     case '~':
6798     case ';':
6799     case '\\':
6800     case '?':
6801     case ' ':
6802     default:
6803         in_cnt = copy_expand_unix_filename_escape
6804                 (vmsptr, unixptr, &out_cnt, utf8_fl);
6805         vmsptr += out_cnt;
6806         unixptr += in_cnt;
6807         break;
6808     }
6809   }
6810
6811   /* Make sure directory is closed */
6812   if (unixptr == lastslash) {
6813     char *vmsptr2;
6814     vmsptr2 = vmsptr - 1;
6815
6816     if (*vmsptr2 != ']') {
6817       *vmsptr2--;
6818
6819       /* directories do not end in a dot bracket */
6820       if (*vmsptr2 == '.') {
6821         vmsptr2--;
6822
6823         /* ^. is allowed */
6824         if (*vmsptr2 != '^') {
6825           vmsptr--; /* back up over the dot */
6826         }
6827       }
6828       *vmsptr++ = ']';
6829     }
6830   }
6831   else {
6832     char *vmsptr2;
6833     /* Add a trailing dot if a file with no extension */
6834     vmsptr2 = vmsptr - 1;
6835     if ((vmslen > 1) &&
6836         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6837         (*vmsptr2 != ')') && (*lastdot != '.')) {
6838         *vmsptr++ = '.';
6839         vmslen++;
6840     }
6841   }
6842
6843   *vmsptr = '\0';
6844   return SS$_NORMAL;
6845 }
6846 #endif
6847
6848  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
6849 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
6850 {
6851 char * result;
6852 int utf8_flag;
6853
6854    /* If a UTF8 flag is being passed, honor it */
6855    utf8_flag = 0;
6856    if (utf8_fl != NULL) {
6857      utf8_flag = *utf8_fl;
6858     *utf8_fl = 0;
6859    }
6860
6861    if (utf8_flag) {
6862      /* If there is a possibility of UTF8, then if any UTF8 characters
6863         are present, then they must be converted to VTF-7
6864       */
6865      result = strcpy(rslt, path); /* FIX-ME */
6866    }
6867    else
6868      result = strcpy(rslt, path);
6869
6870    return result;
6871 }
6872
6873
6874 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
6875 static char *mp_do_tovmsspec
6876    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
6877   static char __tovmsspec_retbuf[VMS_MAXRSS];
6878   char *rslt, *dirend;
6879   char *lastdot;
6880   char *vms_delim;
6881   register char *cp1;
6882   const char *cp2;
6883   unsigned long int infront = 0, hasdir = 1;
6884   int rslt_len;
6885   int no_type_seen;
6886   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6887   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6888
6889   if (path == NULL) return NULL;
6890   rslt_len = VMS_MAXRSS-1;
6891   if (buf) rslt = buf;
6892   else if (ts) Newx(rslt, VMS_MAXRSS, char);
6893   else rslt = __tovmsspec_retbuf;
6894
6895   /* '.' and '..' are "[]" and "[-]" for a quick check */
6896   if (path[0] == '.') {
6897     if (path[1] == '\0') {
6898       strcpy(rslt,"[]");
6899       if (utf8_flag != NULL)
6900         *utf8_flag = 0;
6901       return rslt;
6902     }
6903     else {
6904       if (path[1] == '.' && path[2] == '\0') {
6905         strcpy(rslt,"[-]");
6906         if (utf8_flag != NULL)
6907            *utf8_flag = 0;
6908         return rslt;
6909       }
6910     }
6911   }
6912
6913    /* Posix specifications are now a native VMS format */
6914   /*--------------------------------------------------*/
6915 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6916   if (decc_posix_compliant_pathnames) {
6917     if (strncmp(path,"\"^UP^",5) == 0) {
6918       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
6919       return rslt;
6920     }
6921   }
6922 #endif
6923
6924   /* This is really the only way to see if this is already in VMS format */
6925   sts = vms_split_path
6926        (path,
6927         &v_spec,
6928         &v_len,
6929         &r_spec,
6930         &r_len,
6931         &d_spec,
6932         &d_len,
6933         &n_spec,
6934         &n_len,
6935         &e_spec,
6936         &e_len,
6937         &vs_spec,
6938         &vs_len);
6939   if (sts == 0) {
6940     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
6941        replacement, because the above parse just took care of most of
6942        what is needed to do vmspath when the specification is already
6943        in VMS format.
6944
6945        And if it is not already, it is easier to do the conversion as
6946        part of this routine than to call this routine and then work on
6947        the result.
6948      */
6949
6950     /* If VMS punctuation was found, it is already VMS format */
6951     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
6952       if (utf8_flag != NULL)
6953         *utf8_flag = 0;
6954       strcpy(rslt, path);
6955       return rslt;
6956     }
6957     /* Now, what to do with trailing "." cases where there is no
6958        extension?  If this is a UNIX specification, and EFS characters
6959        are enabled, then the trailing "." should be converted to a "^.".
6960        But if this was already a VMS specification, then it should be
6961        left alone.
6962
6963        So in the case of ambiguity, leave the specification alone.
6964      */
6965
6966
6967     /* If there is a possibility of UTF8, then if any UTF8 characters
6968         are present, then they must be converted to VTF-7
6969      */
6970     if (utf8_flag != NULL)
6971       *utf8_flag = 0;
6972     strcpy(rslt, path);
6973     return rslt;
6974   }
6975
6976   dirend = strrchr(path,'/');
6977
6978   if (dirend == NULL) {
6979      /* If we get here with no UNIX directory delimiters, then this is
6980         not a complete file specification, either garbage a UNIX glob
6981         specification that can not be converted to a VMS wildcard, or
6982         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
6983         so apparently other programs expect this also.
6984
6985         utf8 flag setting needs to be preserved.
6986       */
6987       strcpy(rslt, path);
6988       return rslt;
6989   }
6990
6991 /* If POSIX mode active, handle the conversion */
6992 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6993   if (decc_efs_charset) {
6994     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
6995     return rslt;
6996   }
6997 #endif
6998
6999   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7000     if (!*(dirend+2)) dirend +=2;
7001     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7002     if (decc_efs_charset == 0) {
7003       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7004     }
7005   }
7006
7007   cp1 = rslt;
7008   cp2 = path;
7009   lastdot = strrchr(cp2,'.');
7010   if (*cp2 == '/') {
7011     char *trndev;
7012     int islnm, rooted;
7013     STRLEN trnend;
7014
7015     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7016     if (!*(cp2+1)) {
7017       if (decc_disable_posix_root) {
7018         strcpy(rslt,"sys$disk:[000000]");
7019       }
7020       else {
7021         strcpy(rslt,"sys$posix_root:[000000]");
7022       }
7023       if (utf8_flag != NULL)
7024         *utf8_flag = 0;
7025       return rslt;
7026     }
7027     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7028     *cp1 = '\0';
7029     trndev = PerlMem_malloc(VMS_MAXRSS);
7030     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7031     islnm =  my_trnlnm(rslt,trndev,0);
7032
7033      /* DECC special handling */
7034     if (!islnm) {
7035       if (strcmp(rslt,"bin") == 0) {
7036         strcpy(rslt,"sys$system");
7037         cp1 = rslt + 10;
7038         *cp1 = 0;
7039         islnm =  my_trnlnm(rslt,trndev,0);
7040       }
7041       else if (strcmp(rslt,"tmp") == 0) {
7042         strcpy(rslt,"sys$scratch");
7043         cp1 = rslt + 11;
7044         *cp1 = 0;
7045         islnm =  my_trnlnm(rslt,trndev,0);
7046       }
7047       else if (!decc_disable_posix_root) {
7048         strcpy(rslt, "sys$posix_root");
7049         cp1 = rslt + 13;
7050         *cp1 = 0;
7051         cp2 = path;
7052         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7053         islnm =  my_trnlnm(rslt,trndev,0);
7054       }
7055       else if (strcmp(rslt,"dev") == 0) {
7056         if (strncmp(cp2,"/null", 5) == 0) {
7057           if ((cp2[5] == 0) || (cp2[5] == '/')) {
7058             strcpy(rslt,"NLA0");
7059             cp1 = rslt + 4;
7060             *cp1 = 0;
7061             cp2 = cp2 + 5;
7062             islnm =  my_trnlnm(rslt,trndev,0);
7063           }
7064         }
7065       }
7066     }
7067
7068     trnend = islnm ? strlen(trndev) - 1 : 0;
7069     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7070     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7071     /* If the first element of the path is a logical name, determine
7072      * whether it has to be translated so we can add more directories. */
7073     if (!islnm || rooted) {
7074       *(cp1++) = ':';
7075       *(cp1++) = '[';
7076       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7077       else cp2++;
7078     }
7079     else {
7080       if (cp2 != dirend) {
7081         strcpy(rslt,trndev);
7082         cp1 = rslt + trnend;
7083         if (*cp2 != 0) {
7084           *(cp1++) = '.';
7085           cp2++;
7086         }
7087       }
7088       else {
7089         if (decc_disable_posix_root) {
7090           *(cp1++) = ':';
7091           hasdir = 0;
7092         }
7093       }
7094     }
7095     PerlMem_free(trndev);
7096   }
7097   else {
7098     *(cp1++) = '[';
7099     if (*cp2 == '.') {
7100       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7101         cp2 += 2;         /* skip over "./" - it's redundant */
7102         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
7103       }
7104       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7105         *(cp1++) = '-';                                 /* "../" --> "-" */
7106         cp2 += 3;
7107       }
7108       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7109                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7110         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7111         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7112         cp2 += 4;
7113       }
7114       else if ((cp2 != lastdot) || (lastdot < dirend)) {
7115         /* Escape the extra dots in EFS file specifications */
7116         *(cp1++) = '^';
7117       }
7118       if (cp2 > dirend) cp2 = dirend;
7119     }
7120     else *(cp1++) = '.';
7121   }
7122   for (; cp2 < dirend; cp2++) {
7123     if (*cp2 == '/') {
7124       if (*(cp2-1) == '/') continue;
7125       if (*(cp1-1) != '.') *(cp1++) = '.';
7126       infront = 0;
7127     }
7128     else if (!infront && *cp2 == '.') {
7129       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7130       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
7131       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7132         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7133         else if (*(cp1-2) == '[') *(cp1-1) = '-';
7134         else {  /* back up over previous directory name */
7135           cp1--;
7136           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7137           if (*(cp1-1) == '[') {
7138             memcpy(cp1,"000000.",7);
7139             cp1 += 7;
7140           }
7141         }
7142         cp2 += 2;
7143         if (cp2 == dirend) break;
7144       }
7145       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7146                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7147         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7148         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7149         if (!*(cp2+3)) {
7150           *(cp1++) = '.';  /* Simulate trailing '/' */
7151           cp2 += 2;  /* for loop will incr this to == dirend */
7152         }
7153         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
7154       }
7155       else {
7156         if (decc_efs_charset == 0)
7157           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
7158         else {
7159           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
7160           *(cp1++) = '.';
7161         }
7162       }
7163     }
7164     else {
7165       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
7166       if (*cp2 == '.') {
7167         if (decc_efs_charset == 0)
7168           *(cp1++) = '_';
7169         else {
7170           *(cp1++) = '^';
7171           *(cp1++) = '.';
7172         }
7173       }
7174       else                  *(cp1++) =  *cp2;
7175       infront = 1;
7176     }
7177   }
7178   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7179   if (hasdir) *(cp1++) = ']';
7180   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
7181   /* fixme for ODS5 */
7182   no_type_seen = 0;
7183   if (cp2 > lastdot)
7184     no_type_seen = 1;
7185   while (*cp2) {
7186     switch(*cp2) {
7187     case '?':
7188         if (decc_efs_charset == 0)
7189           *(cp1++) = '%';
7190         else
7191           *(cp1++) = '?';
7192         cp2++;
7193     case ' ':
7194         *(cp1)++ = '^';
7195         *(cp1)++ = '_';
7196         cp2++;
7197         break;
7198     case '.':
7199         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7200             decc_readdir_dropdotnotype) {
7201           *(cp1)++ = '^';
7202           *(cp1)++ = '.';
7203           cp2++;
7204
7205           /* trailing dot ==> '^..' on VMS */
7206           if (*cp2 == '\0') {
7207             *(cp1++) = '.';
7208             no_type_seen = 0;
7209           }
7210         }
7211         else {
7212           *(cp1++) = *(cp2++);
7213           no_type_seen = 0;
7214         }
7215         break;
7216     case '$':
7217          /* This could be a macro to be passed through */
7218         *(cp1++) = *(cp2++);
7219         if (*cp2 == '(') {
7220         const char * save_cp2;
7221         char * save_cp1;
7222         int is_macro;
7223
7224             /* paranoid check */
7225             save_cp2 = cp2;
7226             save_cp1 = cp1;
7227             is_macro = 0;
7228
7229             /* Test through */
7230             *(cp1++) = *(cp2++);
7231             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7232                 *(cp1++) = *(cp2++);
7233                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7234                     *(cp1++) = *(cp2++);
7235                 }
7236                 if (*cp2 == ')') {
7237                     *(cp1++) = *(cp2++);
7238                     is_macro = 1;
7239                 }
7240             }
7241             if (is_macro == 0) {
7242                 /* Not really a macro - never mind */
7243                 cp2 = save_cp2;
7244                 cp1 = save_cp1;
7245             }
7246         }
7247         break;
7248     case '\"':
7249     case '~':
7250     case '`':
7251     case '!':
7252     case '#':
7253     case '%':
7254     case '^':
7255     case '&':
7256     case '(':
7257     case ')':
7258     case '=':
7259     case '+':
7260     case '\'':
7261     case '@':
7262     case '[':
7263     case ']':
7264     case '{':
7265     case '}':
7266     case ':':
7267     case '\\':
7268     case '|':
7269     case '<':
7270     case '>':
7271         *(cp1++) = '^';
7272         *(cp1++) = *(cp2++);
7273         break;
7274     case ';':
7275         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7276          * which is wrong.  UNIX notation should be ".dir." unless
7277          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7278          * changing this behavior could break more things at this time.
7279          * efs character set effectively does not allow "." to be a version
7280          * delimiter as a further complication about changing this.
7281          */
7282         if (decc_filename_unix_report != 0) {
7283           *(cp1++) = '^';
7284         }
7285         *(cp1++) = *(cp2++);
7286         break;
7287     default:
7288         *(cp1++) = *(cp2++);
7289     }
7290   }
7291   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7292   char *lcp1;
7293     lcp1 = cp1;
7294     lcp1--;
7295      /* Fix me for "^]", but that requires making sure that you do
7296       * not back up past the start of the filename
7297       */
7298     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7299       *cp1++ = '.';
7300   }
7301   *cp1 = '\0';
7302
7303   if (utf8_flag != NULL)
7304     *utf8_flag = 0;
7305   return rslt;
7306
7307 }  /* end of do_tovmsspec() */
7308 /*}}}*/
7309 /* External entry points */
7310 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7311   { return do_tovmsspec(path,buf,0,NULL); }
7312 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7313   { return do_tovmsspec(path,buf,1,NULL); }
7314 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7315   { return do_tovmsspec(path,buf,0,utf8_fl); }
7316 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7317   { return do_tovmsspec(path,buf,1,utf8_fl); }
7318
7319 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7320 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7321   static char __tovmspath_retbuf[VMS_MAXRSS];
7322   int vmslen;
7323   char *pathified, *vmsified, *cp;
7324
7325   if (path == NULL) return NULL;
7326   pathified = PerlMem_malloc(VMS_MAXRSS);
7327   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7328   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7329     PerlMem_free(pathified);
7330     return NULL;
7331   }
7332
7333   vmsified = NULL;
7334   if (buf == NULL)
7335      Newx(vmsified, VMS_MAXRSS, char);
7336   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7337     PerlMem_free(pathified);
7338     if (vmsified) Safefree(vmsified);
7339     return NULL;
7340   }
7341   PerlMem_free(pathified);
7342   if (buf) {
7343     return buf;
7344   }
7345   else if (ts) {
7346     vmslen = strlen(vmsified);
7347     Newx(cp,vmslen+1,char);
7348     memcpy(cp,vmsified,vmslen);
7349     cp[vmslen] = '\0';
7350     Safefree(vmsified);
7351     return cp;
7352   }
7353   else {
7354     strcpy(__tovmspath_retbuf,vmsified);
7355     Safefree(vmsified);
7356     return __tovmspath_retbuf;
7357   }
7358
7359 }  /* end of do_tovmspath() */
7360 /*}}}*/
7361 /* External entry points */
7362 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7363   { return do_tovmspath(path,buf,0, NULL); }
7364 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7365   { return do_tovmspath(path,buf,1, NULL); }
7366 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7367   { return do_tovmspath(path,buf,0,utf8_fl); }
7368 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7369   { return do_tovmspath(path,buf,1,utf8_fl); }
7370
7371
7372 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7373 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7374   static char __tounixpath_retbuf[VMS_MAXRSS];
7375   int unixlen;
7376   char *pathified, *unixified, *cp;
7377
7378   if (path == NULL) return NULL;
7379   pathified = PerlMem_malloc(VMS_MAXRSS);
7380   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7381   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7382     PerlMem_free(pathified);
7383     return NULL;
7384   }
7385
7386   unixified = NULL;
7387   if (buf == NULL) {
7388       Newx(unixified, VMS_MAXRSS, char);
7389   }
7390   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7391     PerlMem_free(pathified);
7392     if (unixified) Safefree(unixified);
7393     return NULL;
7394   }
7395   PerlMem_free(pathified);
7396   if (buf) {
7397     return buf;
7398   }
7399   else if (ts) {
7400     unixlen = strlen(unixified);
7401     Newx(cp,unixlen+1,char);
7402     memcpy(cp,unixified,unixlen);
7403     cp[unixlen] = '\0';
7404     Safefree(unixified);
7405     return cp;
7406   }
7407   else {
7408     strcpy(__tounixpath_retbuf,unixified);
7409     Safefree(unixified);
7410     return __tounixpath_retbuf;
7411   }
7412
7413 }  /* end of do_tounixpath() */
7414 /*}}}*/
7415 /* External entry points */
7416 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7417   { return do_tounixpath(path,buf,0,NULL); }
7418 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7419   { return do_tounixpath(path,buf,1,NULL); }
7420 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7421   { return do_tounixpath(path,buf,0,utf8_fl); }
7422 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7423   { return do_tounixpath(path,buf,1,utf8_fl); }
7424
7425 /*
7426  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
7427  *
7428  *****************************************************************************
7429  *                                                                           *
7430  *  Copyright (C) 1989-1994 by                                               *
7431  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
7432  *                                                                           *
7433  *  Permission is hereby  granted for the reproduction of this software,     *
7434  *  on condition that this copyright notice is included in the reproduction, *
7435  *  and that such reproduction is not for purposes of profit or material     *
7436  *  gain.                                                                    *
7437  *                                                                           *
7438  *  27-Aug-1994 Modified for inclusion in perl5                              *
7439  *              by Charles Bailey  bailey@newman.upenn.edu                   *
7440  *****************************************************************************
7441  */
7442
7443 /*
7444  * getredirection() is intended to aid in porting C programs
7445  * to VMS (Vax-11 C).  The native VMS environment does not support
7446  * '>' and '<' I/O redirection, or command line wild card expansion,
7447  * or a command line pipe mechanism using the '|' AND background
7448  * command execution '&'.  All of these capabilities are provided to any
7449  * C program which calls this procedure as the first thing in the
7450  * main program.
7451  * The piping mechanism will probably work with almost any 'filter' type
7452  * of program.  With suitable modification, it may useful for other
7453  * portability problems as well.
7454  *
7455  * Author:  Mark Pizzolato      mark@infocomm.com
7456  */
7457 struct list_item
7458     {
7459     struct list_item *next;
7460     char *value;
7461     };
7462
7463 static void add_item(struct list_item **head,
7464                      struct list_item **tail,
7465                      char *value,
7466                      int *count);
7467
7468 static void mp_expand_wild_cards(pTHX_ char *item,
7469                                 struct list_item **head,
7470                                 struct list_item **tail,
7471                                 int *count);
7472
7473 static int background_process(pTHX_ int argc, char **argv);
7474
7475 static void pipe_and_fork(pTHX_ char **cmargv);
7476
7477 /*{{{ void getredirection(int *ac, char ***av)*/
7478 static void
7479 mp_getredirection(pTHX_ int *ac, char ***av)
7480 /*
7481  * Process vms redirection arg's.  Exit if any error is seen.
7482  * If getredirection() processes an argument, it is erased
7483  * from the vector.  getredirection() returns a new argc and argv value.
7484  * In the event that a background command is requested (by a trailing "&"),
7485  * this routine creates a background subprocess, and simply exits the program.
7486  *
7487  * Warning: do not try to simplify the code for vms.  The code
7488  * presupposes that getredirection() is called before any data is
7489  * read from stdin or written to stdout.
7490  *
7491  * Normal usage is as follows:
7492  *
7493  *      main(argc, argv)
7494  *      int             argc;
7495  *      char            *argv[];
7496  *      {
7497  *              getredirection(&argc, &argv);
7498  *      }
7499  */
7500 {
7501     int                 argc = *ac;     /* Argument Count         */
7502     char                **argv = *av;   /* Argument Vector        */
7503     char                *ap;            /* Argument pointer       */
7504     int                 j;              /* argv[] index           */
7505     int                 item_count = 0; /* Count of Items in List */
7506     struct list_item    *list_head = 0; /* First Item in List       */
7507     struct list_item    *list_tail;     /* Last Item in List        */
7508     char                *in = NULL;     /* Input File Name          */
7509     char                *out = NULL;    /* Output File Name         */
7510     char                *outmode = "w"; /* Mode to Open Output File */
7511     char                *err = NULL;    /* Error File Name          */
7512     char                *errmode = "w"; /* Mode to Open Error File  */
7513     int                 cmargc = 0;     /* Piped Command Arg Count  */
7514     char                **cmargv = NULL;/* Piped Command Arg Vector */
7515
7516     /*
7517      * First handle the case where the last thing on the line ends with
7518      * a '&'.  This indicates the desire for the command to be run in a
7519      * subprocess, so we satisfy that desire.
7520      */
7521     ap = argv[argc-1];
7522     if (0 == strcmp("&", ap))
7523        exit(background_process(aTHX_ --argc, argv));
7524     if (*ap && '&' == ap[strlen(ap)-1])
7525         {
7526         ap[strlen(ap)-1] = '\0';
7527        exit(background_process(aTHX_ argc, argv));
7528         }
7529     /*
7530      * Now we handle the general redirection cases that involve '>', '>>',
7531      * '<', and pipes '|'.
7532      */
7533     for (j = 0; j < argc; ++j)
7534         {
7535         if (0 == strcmp("<", argv[j]))
7536             {
7537             if (j+1 >= argc)
7538                 {
7539                 fprintf(stderr,"No input file after < on command line");
7540                 exit(LIB$_WRONUMARG);
7541                 }
7542             in = argv[++j];
7543             continue;
7544             }
7545         if ('<' == *(ap = argv[j]))
7546             {
7547             in = 1 + ap;
7548             continue;
7549             }
7550         if (0 == strcmp(">", ap))
7551             {
7552             if (j+1 >= argc)
7553                 {
7554                 fprintf(stderr,"No output file after > on command line");
7555                 exit(LIB$_WRONUMARG);
7556                 }
7557             out = argv[++j];
7558             continue;
7559             }
7560         if ('>' == *ap)
7561             {
7562             if ('>' == ap[1])
7563                 {
7564                 outmode = "a";
7565                 if ('\0' == ap[2])
7566                     out = argv[++j];
7567                 else
7568                     out = 2 + ap;
7569                 }
7570             else
7571                 out = 1 + ap;
7572             if (j >= argc)
7573                 {
7574                 fprintf(stderr,"No output file after > or >> on command line");
7575                 exit(LIB$_WRONUMARG);
7576                 }
7577             continue;
7578             }
7579         if (('2' == *ap) && ('>' == ap[1]))
7580             {
7581             if ('>' == ap[2])
7582                 {
7583                 errmode = "a";
7584                 if ('\0' == ap[3])
7585                     err = argv[++j];
7586                 else
7587                     err = 3 + ap;
7588                 }
7589             else
7590                 if ('\0' == ap[2])
7591                     err = argv[++j];
7592                 else
7593                     err = 2 + ap;
7594             if (j >= argc)
7595                 {
7596                 fprintf(stderr,"No output file after 2> or 2>> on command line");
7597                 exit(LIB$_WRONUMARG);
7598                 }
7599             continue;
7600             }
7601         if (0 == strcmp("|", argv[j]))
7602             {
7603             if (j+1 >= argc)
7604                 {
7605                 fprintf(stderr,"No command into which to pipe on command line");
7606                 exit(LIB$_WRONUMARG);
7607                 }
7608             cmargc = argc-(j+1);
7609             cmargv = &argv[j+1];
7610             argc = j;
7611             continue;
7612             }
7613         if ('|' == *(ap = argv[j]))
7614             {
7615             ++argv[j];
7616             cmargc = argc-j;
7617             cmargv = &argv[j];
7618             argc = j;
7619             continue;
7620             }
7621         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7622         }
7623     /*
7624      * Allocate and fill in the new argument vector, Some Unix's terminate
7625      * the list with an extra null pointer.
7626      */
7627     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7628     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7629     *av = argv;
7630     for (j = 0; j < item_count; ++j, list_head = list_head->next)
7631         argv[j] = list_head->value;
7632     *ac = item_count;
7633     if (cmargv != NULL)
7634         {
7635         if (out != NULL)
7636             {
7637             fprintf(stderr,"'|' and '>' may not both be specified on command line");
7638             exit(LIB$_INVARGORD);
7639             }
7640         pipe_and_fork(aTHX_ cmargv);
7641         }
7642
7643     /* Check for input from a pipe (mailbox) */
7644
7645     if (in == NULL && 1 == isapipe(0))
7646         {
7647         char mbxname[L_tmpnam];
7648         long int bufsize;
7649         long int dvi_item = DVI$_DEVBUFSIZ;
7650         $DESCRIPTOR(mbxnam, "");
7651         $DESCRIPTOR(mbxdevnam, "");
7652
7653         /* Input from a pipe, reopen it in binary mode to disable       */
7654         /* carriage control processing.                                 */
7655
7656         fgetname(stdin, mbxname);
7657         mbxnam.dsc$a_pointer = mbxname;
7658         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7659         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7660         mbxdevnam.dsc$a_pointer = mbxname;
7661         mbxdevnam.dsc$w_length = sizeof(mbxname);
7662         dvi_item = DVI$_DEVNAM;
7663         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7664         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7665         set_errno(0);
7666         set_vaxc_errno(1);
7667         freopen(mbxname, "rb", stdin);
7668         if (errno != 0)
7669             {
7670             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7671             exit(vaxc$errno);
7672             }
7673         }
7674     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7675         {
7676         fprintf(stderr,"Can't open input file %s as stdin",in);
7677         exit(vaxc$errno);
7678         }
7679     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7680         {
7681         fprintf(stderr,"Can't open output file %s as stdout",out);
7682         exit(vaxc$errno);
7683         }
7684         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7685
7686     if (err != NULL) {
7687         if (strcmp(err,"&1") == 0) {
7688             dup2(fileno(stdout), fileno(stderr));
7689             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7690         } else {
7691         FILE *tmperr;
7692         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7693             {
7694             fprintf(stderr,"Can't open error file %s as stderr",err);
7695             exit(vaxc$errno);
7696             }
7697             fclose(tmperr);
7698            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7699                 {
7700                 exit(vaxc$errno);
7701                 }
7702             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7703         }
7704         }
7705 #ifdef ARGPROC_DEBUG
7706     PerlIO_printf(Perl_debug_log, "Arglist:\n");
7707     for (j = 0; j < *ac;  ++j)
7708         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7709 #endif
7710    /* Clear errors we may have hit expanding wildcards, so they don't
7711       show up in Perl's $! later */
7712    set_errno(0); set_vaxc_errno(1);
7713 }  /* end of getredirection() */
7714 /*}}}*/
7715
7716 static void add_item(struct list_item **head,
7717                      struct list_item **tail,
7718                      char *value,
7719                      int *count)
7720 {
7721     if (*head == 0)
7722         {
7723         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7724         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7725         *tail = *head;
7726         }
7727     else {
7728         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7729         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7730         *tail = (*tail)->next;
7731         }
7732     (*tail)->value = value;
7733     ++(*count);
7734 }
7735
7736 static void mp_expand_wild_cards(pTHX_ char *item,
7737                               struct list_item **head,
7738                               struct list_item **tail,
7739                               int *count)
7740 {
7741 int expcount = 0;
7742 unsigned long int context = 0;
7743 int isunix = 0;
7744 int item_len = 0;
7745 char *had_version;
7746 char *had_device;
7747 int had_directory;
7748 char *devdir,*cp;
7749 char *vmsspec;
7750 $DESCRIPTOR(filespec, "");
7751 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
7752 $DESCRIPTOR(resultspec, "");
7753 unsigned long int lff_flags = 0;
7754 int sts;
7755 int rms_sts;
7756
7757 #ifdef VMS_LONGNAME_SUPPORT
7758     lff_flags = LIB$M_FIL_LONG_NAMES;
7759 #endif
7760
7761     for (cp = item; *cp; cp++) {
7762         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
7763         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
7764     }
7765     if (!*cp || isspace(*cp))
7766         {
7767         add_item(head, tail, item, count);
7768         return;
7769         }
7770     else
7771         {
7772      /* "double quoted" wild card expressions pass as is */
7773      /* From DCL that means using e.g.:                  */
7774      /* perl program """perl.*"""                        */
7775      item_len = strlen(item);
7776      if ( '"' == *item && '"' == item[item_len-1] )
7777        {
7778        item++;
7779        item[item_len-2] = '\0';
7780        add_item(head, tail, item, count);
7781        return;
7782        }
7783      }
7784     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
7785     resultspec.dsc$b_class = DSC$K_CLASS_D;
7786     resultspec.dsc$a_pointer = NULL;
7787     vmsspec = PerlMem_malloc(VMS_MAXRSS);
7788     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7789     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
7790       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
7791     if (!isunix || !filespec.dsc$a_pointer)
7792       filespec.dsc$a_pointer = item;
7793     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
7794     /*
7795      * Only return version specs, if the caller specified a version
7796      */
7797     had_version = strchr(item, ';');
7798     /*
7799      * Only return device and directory specs, if the caller specifed either.
7800      */
7801     had_device = strchr(item, ':');
7802     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
7803
7804     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
7805                                  (&filespec, &resultspec, &context,
7806                                   &defaultspec, 0, &rms_sts, &lff_flags)))
7807         {
7808         char *string;
7809         char *c;
7810
7811         string = PerlMem_malloc(resultspec.dsc$w_length+1);
7812         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7813         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
7814         string[resultspec.dsc$w_length] = '\0';
7815         if (NULL == had_version)
7816             *(strrchr(string, ';')) = '\0';
7817         if ((!had_directory) && (had_device == NULL))
7818             {
7819             if (NULL == (devdir = strrchr(string, ']')))
7820                 devdir = strrchr(string, '>');
7821             strcpy(string, devdir + 1);
7822             }
7823         /*
7824          * Be consistent with what the C RTL has already done to the rest of
7825          * the argv items and lowercase all of these names.
7826          */
7827         if (!decc_efs_case_preserve) {
7828             for (c = string; *c; ++c)
7829             if (isupper(*c))
7830                 *c = tolower(*c);
7831         }
7832         if (isunix) trim_unixpath(string,item,1);
7833         add_item(head, tail, string, count);
7834         ++expcount;
7835     }
7836     PerlMem_free(vmsspec);
7837     if (sts != RMS$_NMF)
7838         {
7839         set_vaxc_errno(sts);
7840         switch (sts)
7841             {
7842             case RMS$_FNF: case RMS$_DNF:
7843                 set_errno(ENOENT); break;
7844             case RMS$_DIR:
7845                 set_errno(ENOTDIR); break;
7846             case RMS$_DEV:
7847                 set_errno(ENODEV); break;
7848             case RMS$_FNM: case RMS$_SYN:
7849                 set_errno(EINVAL); break;
7850             case RMS$_PRV:
7851                 set_errno(EACCES); break;
7852             default:
7853                 _ckvmssts_noperl(sts);
7854             }
7855         }
7856     if (expcount == 0)
7857         add_item(head, tail, item, count);
7858     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
7859     _ckvmssts_noperl(lib$find_file_end(&context));
7860 }
7861
7862 static int child_st[2];/* Event Flag set when child process completes   */
7863
7864 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
7865
7866 static unsigned long int exit_handler(int *status)
7867 {
7868 short iosb[4];
7869
7870     if (0 == child_st[0])
7871         {
7872 #ifdef ARGPROC_DEBUG
7873         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
7874 #endif
7875         fflush(stdout);     /* Have to flush pipe for binary data to    */
7876                             /* terminate properly -- <tp@mccall.com>    */
7877         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
7878         sys$dassgn(child_chan);
7879         fclose(stdout);
7880         sys$synch(0, child_st);
7881         }
7882     return(1);
7883 }
7884
7885 static void sig_child(int chan)
7886 {
7887 #ifdef ARGPROC_DEBUG
7888     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
7889 #endif
7890     if (child_st[0] == 0)
7891         child_st[0] = 1;
7892 }
7893
7894 static struct exit_control_block exit_block =
7895     {
7896     0,
7897     exit_handler,
7898     1,
7899     &exit_block.exit_status,
7900     0
7901     };
7902
7903 static void
7904 pipe_and_fork(pTHX_ char **cmargv)
7905 {
7906     PerlIO *fp;
7907     struct dsc$descriptor_s *vmscmd;
7908     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
7909     int sts, j, l, ismcr, quote, tquote = 0;
7910
7911     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
7912     vms_execfree(vmscmd);
7913
7914     j = l = 0;
7915     p = subcmd;
7916     q = cmargv[0];
7917     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
7918               && toupper(*(q+2)) == 'R' && !*(q+3);
7919
7920     while (q && l < MAX_DCL_LINE_LENGTH) {
7921         if (!*q) {
7922             if (j > 0 && quote) {
7923                 *p++ = '"';
7924                 l++;
7925             }
7926             q = cmargv[++j];
7927             if (q) {
7928                 if (ismcr && j > 1) quote = 1;
7929                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
7930                 *p++ = ' ';
7931                 l++;
7932                 if (quote || tquote) {
7933                     *p++ = '"';
7934                     l++;
7935                 }
7936             }
7937         } else {
7938             if ((quote||tquote) && *q == '"') {
7939                 *p++ = '"';
7940                 l++;
7941             }
7942             *p++ = *q++;
7943             l++;
7944         }
7945     }
7946     *p = '\0';
7947
7948     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7949     if (fp == Nullfp) {
7950         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7951     }
7952 }
7953
7954 static int background_process(pTHX_ int argc, char **argv)
7955 {
7956 char command[MAX_DCL_SYMBOL + 1] = "$";
7957 $DESCRIPTOR(value, "");
7958 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7959 static $DESCRIPTOR(null, "NLA0:");
7960 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7961 char pidstring[80];
7962 $DESCRIPTOR(pidstr, "");
7963 int pid;
7964 unsigned long int flags = 17, one = 1, retsts;
7965 int len;
7966
7967     strcat(command, argv[0]);
7968     len = strlen(command);
7969     while (--argc && (len < MAX_DCL_SYMBOL))
7970         {
7971         strcat(command, " \"");
7972         strcat(command, *(++argv));
7973         strcat(command, "\"");
7974         len = strlen(command);
7975         }
7976     value.dsc$a_pointer = command;
7977     value.dsc$w_length = strlen(value.dsc$a_pointer);
7978     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7979     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7980     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7981         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
7982     }
7983     else {
7984         _ckvmssts_noperl(retsts);
7985     }
7986 #ifdef ARGPROC_DEBUG
7987     PerlIO_printf(Perl_debug_log, "%s\n", command);
7988 #endif
7989     sprintf(pidstring, "%08X", pid);
7990     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
7991     pidstr.dsc$a_pointer = pidstring;
7992     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7993     lib$set_symbol(&pidsymbol, &pidstr);
7994     return(SS$_NORMAL);
7995 }
7996 /*}}}*/
7997 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
7998
7999
8000 /* OS-specific initialization at image activation (not thread startup) */
8001 /* Older VAXC header files lack these constants */
8002 #ifndef JPI$_RIGHTS_SIZE
8003 #  define JPI$_RIGHTS_SIZE 817
8004 #endif
8005 #ifndef KGB$M_SUBSYSTEM
8006 #  define KGB$M_SUBSYSTEM 0x8
8007 #endif
8008
8009 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8010
8011 /*{{{void vms_image_init(int *, char ***)*/
8012 void
8013 vms_image_init(int *argcp, char ***argvp)
8014 {
8015   char eqv[LNM$C_NAMLENGTH+1] = "";
8016   unsigned int len, tabct = 8, tabidx = 0;
8017   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8018   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8019   unsigned short int dummy, rlen;
8020   struct dsc$descriptor_s **tabvec;
8021 #if defined(PERL_IMPLICIT_CONTEXT)
8022   pTHX = NULL;
8023 #endif
8024   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8025                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8026                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8027                                  {          0,                0,    0,      0} };
8028
8029 #ifdef KILL_BY_SIGPRC
8030     Perl_csighandler_init();
8031 #endif
8032
8033   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8034   _ckvmssts_noperl(iosb[0]);
8035   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8036     if (iprv[i]) {           /* Running image installed with privs? */
8037       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8038       will_taint = TRUE;
8039       break;
8040     }
8041   }
8042   /* Rights identifiers might trigger tainting as well. */
8043   if (!will_taint && (rlen || rsz)) {
8044     while (rlen < rsz) {
8045       /* We didn't get all the identifiers on the first pass.  Allocate a
8046        * buffer much larger than $GETJPI wants (rsz is size in bytes that
8047        * were needed to hold all identifiers at time of last call; we'll
8048        * allocate that many unsigned long ints), and go back and get 'em.
8049        * If it gave us less than it wanted to despite ample buffer space,
8050        * something's broken.  Is your system missing a system identifier?
8051        */
8052       if (rsz <= jpilist[1].buflen) {
8053          /* Perl_croak accvios when used this early in startup. */
8054          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8055                          rsz, (unsigned long) jpilist[1].buflen,
8056                          "Check your rights database for corruption.\n");
8057          exit(SS$_ABORT);
8058       }
8059       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8060       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8061       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8062       jpilist[1].buflen = rsz * sizeof(unsigned long int);
8063       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8064       _ckvmssts_noperl(iosb[0]);
8065     }
8066     mask = jpilist[1].bufadr;
8067     /* Check attribute flags for each identifier (2nd longword); protected
8068      * subsystem identifiers trigger tainting.
8069      */
8070     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8071       if (mask[i] & KGB$M_SUBSYSTEM) {
8072         will_taint = TRUE;
8073         break;
8074       }
8075     }
8076     if (mask != rlst) PerlMem_free(mask);
8077   }
8078
8079   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8080    * logical, some versions of the CRTL will add a phanthom /000000/
8081    * directory.  This needs to be removed.
8082    */
8083   if (decc_filename_unix_report) {
8084   char * zeros;
8085   int ulen;
8086     ulen = strlen(argvp[0][0]);
8087     if (ulen > 7) {
8088       zeros = strstr(argvp[0][0], "/000000/");
8089       if (zeros != NULL) {
8090         int mlen;
8091         mlen = ulen - (zeros - argvp[0][0]) - 7;
8092         memmove(zeros, &zeros[7], mlen);
8093         ulen = ulen - 7;
8094         argvp[0][0][ulen] = '\0';
8095       }
8096     }
8097     /* It also may have a trailing dot that needs to be removed otherwise
8098      * it will be converted to VMS mode incorrectly.
8099      */
8100     ulen--;
8101     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8102       argvp[0][0][ulen] = '\0';
8103   }
8104
8105   /* We need to use this hack to tell Perl it should run with tainting,
8106    * since its tainting flag may be part of the PL_curinterp struct, which
8107    * hasn't been allocated when vms_image_init() is called.
8108    */
8109   if (will_taint) {
8110     char **newargv, **oldargv;
8111     oldargv = *argvp;
8112     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8113     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8114     newargv[0] = oldargv[0];
8115     newargv[1] = PerlMem_malloc(3 * sizeof(char));
8116     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8117     strcpy(newargv[1], "-T");
8118     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8119     (*argcp)++;
8120     newargv[*argcp] = NULL;
8121     /* We orphan the old argv, since we don't know where it's come from,
8122      * so we don't know how to free it.
8123      */
8124     *argvp = newargv;
8125   }
8126   else {  /* Did user explicitly request tainting? */
8127     int i;
8128     char *cp, **av = *argvp;
8129     for (i = 1; i < *argcp; i++) {
8130       if (*av[i] != '-') break;
8131       for (cp = av[i]+1; *cp; cp++) {
8132         if (*cp == 'T') { will_taint = 1; break; }
8133         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8134                   strchr("DFIiMmx",*cp)) break;
8135       }
8136       if (will_taint) break;
8137     }
8138   }
8139
8140   for (tabidx = 0;
8141        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8142        tabidx++) {
8143     if (!tabidx) {
8144       tabvec = (struct dsc$descriptor_s **)
8145             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8146       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8147     }
8148     else if (tabidx >= tabct) {
8149       tabct += 8;
8150       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8151       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8152     }
8153     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8154     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8155     tabvec[tabidx]->dsc$w_length  = 0;
8156     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
8157     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
8158     tabvec[tabidx]->dsc$a_pointer = NULL;
8159     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8160   }
8161   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8162
8163   getredirection(argcp,argvp);
8164 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8165   {
8166 # include <reentrancy.h>
8167   decc$set_reentrancy(C$C_MULTITHREAD);
8168   }
8169 #endif
8170   return;
8171 }
8172 /*}}}*/
8173
8174
8175 /* trim_unixpath()
8176  * Trim Unix-style prefix off filespec, so it looks like what a shell
8177  * glob expansion would return (i.e. from specified prefix on, not
8178  * full path).  Note that returned filespec is Unix-style, regardless
8179  * of whether input filespec was VMS-style or Unix-style.
8180  *
8181  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8182  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
8183  * vector of options; at present, only bit 0 is used, and if set tells
8184  * trim unixpath to try the current default directory as a prefix when
8185  * presented with a possibly ambiguous ... wildcard.
8186  *
8187  * Returns !=0 on success, with trimmed filespec replacing contents of
8188  * fspec, and 0 on failure, with contents of fpsec unchanged.
8189  */
8190 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8191 int
8192 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8193 {
8194   char *unixified, *unixwild,
8195        *template, *base, *end, *cp1, *cp2;
8196   register int tmplen, reslen = 0, dirs = 0;
8197
8198   unixwild = PerlMem_malloc(VMS_MAXRSS);
8199   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8200   if (!wildspec || !fspec) return 0;
8201   template = unixwild;
8202   if (strpbrk(wildspec,"]>:") != NULL) {
8203     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8204         PerlMem_free(unixwild);
8205         return 0;
8206     }
8207   }
8208   else {
8209     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8210     unixwild[VMS_MAXRSS-1] = 0;
8211   }
8212   unixified = PerlMem_malloc(VMS_MAXRSS);
8213   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8214   if (strpbrk(fspec,"]>:") != NULL) {
8215     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8216         PerlMem_free(unixwild);
8217         PerlMem_free(unixified);
8218         return 0;
8219     }
8220     else base = unixified;
8221     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8222      * check to see that final result fits into (isn't longer than) fspec */
8223     reslen = strlen(fspec);
8224   }
8225   else base = fspec;
8226
8227   /* No prefix or absolute path on wildcard, so nothing to remove */
8228   if (!*template || *template == '/') {
8229     PerlMem_free(unixwild);
8230     if (base == fspec) {
8231         PerlMem_free(unixified);
8232         return 1;
8233     }
8234     tmplen = strlen(unixified);
8235     if (tmplen > reslen) {
8236         PerlMem_free(unixified);
8237         return 0;  /* not enough space */
8238     }
8239     /* Copy unixified resultant, including trailing NUL */
8240     memmove(fspec,unixified,tmplen+1);
8241     PerlMem_free(unixified);
8242     return 1;
8243   }
8244
8245   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
8246   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8247     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8248     for (cp1 = end ;cp1 >= base; cp1--)
8249       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8250         { cp1++; break; }
8251     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8252     PerlMem_free(unixified);
8253     PerlMem_free(unixwild);
8254     return 1;
8255   }
8256   else {
8257     char *tpl, *lcres;
8258     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8259     int ells = 1, totells, segdirs, match;
8260     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8261                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8262
8263     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8264     totells = ells;
8265     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8266     tpl = PerlMem_malloc(VMS_MAXRSS);
8267     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8268     if (ellipsis == template && opts & 1) {
8269       /* Template begins with an ellipsis.  Since we can't tell how many
8270        * directory names at the front of the resultant to keep for an
8271        * arbitrary starting point, we arbitrarily choose the current
8272        * default directory as a starting point.  If it's there as a prefix,
8273        * clip it off.  If not, fall through and act as if the leading
8274        * ellipsis weren't there (i.e. return shortest possible path that
8275        * could match template).
8276        */
8277       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8278           PerlMem_free(tpl);
8279           PerlMem_free(unixified);
8280           PerlMem_free(unixwild);
8281           return 0;
8282       }
8283       if (!decc_efs_case_preserve) {
8284         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8285           if (_tolower(*cp1) != _tolower(*cp2)) break;
8286       }
8287       segdirs = dirs - totells;  /* Min # of dirs we must have left */
8288       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8289       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8290         memmove(fspec,cp2+1,end - cp2);
8291         PerlMem_free(tpl);
8292         PerlMem_free(unixified);
8293         PerlMem_free(unixwild);
8294         return 1;
8295       }
8296     }
8297     /* First off, back up over constant elements at end of path */
8298     if (dirs) {
8299       for (front = end ; front >= base; front--)
8300          if (*front == '/' && !dirs--) { front++; break; }
8301     }
8302     lcres = PerlMem_malloc(VMS_MAXRSS);
8303     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8304     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8305          cp1++,cp2++) {
8306             if (!decc_efs_case_preserve) {
8307                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
8308             }
8309             else {
8310                 *cp2 = *cp1;
8311             }
8312     }
8313     if (cp1 != '\0') {
8314         PerlMem_free(tpl);
8315         PerlMem_free(unixified);
8316         PerlMem_free(unixwild);
8317         PerlMem_free(lcres);
8318         return 0;  /* Path too long. */
8319     }
8320     lcend = cp2;
8321     *cp2 = '\0';  /* Pick up with memcpy later */
8322     lcfront = lcres + (front - base);
8323     /* Now skip over each ellipsis and try to match the path in front of it. */
8324     while (ells--) {
8325       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8326         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
8327             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
8328       if (cp1 < template) break; /* template started with an ellipsis */
8329       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8330         ellipsis = cp1; continue;
8331       }
8332       wilddsc.dsc$a_pointer = tpl;
8333       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8334       nextell = cp1;
8335       for (segdirs = 0, cp2 = tpl;
8336            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8337            cp1++, cp2++) {
8338          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8339          else {
8340             if (!decc_efs_case_preserve) {
8341               *cp2 = _tolower(*cp1);  /* else lowercase for match */
8342             }
8343             else {
8344               *cp2 = *cp1;  /* else preserve case for match */
8345             }
8346          }
8347          if (*cp2 == '/') segdirs++;
8348       }
8349       if (cp1 != ellipsis - 1) {
8350           PerlMem_free(tpl);
8351           PerlMem_free(unixified);
8352           PerlMem_free(unixwild);
8353           PerlMem_free(lcres);
8354           return 0; /* Path too long */
8355       }
8356       /* Back up at least as many dirs as in template before matching */
8357       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8358         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8359       for (match = 0; cp1 > lcres;) {
8360         resdsc.dsc$a_pointer = cp1;
8361         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8362           match++;
8363           if (match == 1) lcfront = cp1;
8364         }
8365         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8366       }
8367       if (!match) {
8368         PerlMem_free(tpl);
8369         PerlMem_free(unixified);
8370         PerlMem_free(unixwild);
8371         PerlMem_free(lcres);
8372         return 0;  /* Can't find prefix ??? */
8373       }
8374       if (match > 1 && opts & 1) {
8375         /* This ... wildcard could cover more than one set of dirs (i.e.
8376          * a set of similar dir names is repeated).  If the template
8377          * contains more than 1 ..., upstream elements could resolve the
8378          * ambiguity, but it's not worth a full backtracking setup here.
8379          * As a quick heuristic, clip off the current default directory
8380          * if it's present to find the trimmed spec, else use the
8381          * shortest string that this ... could cover.
8382          */
8383         char def[NAM$C_MAXRSS+1], *st;
8384
8385         if (getcwd(def, sizeof def,0) == NULL) {
8386             Safefree(unixified);
8387             Safefree(unixwild);
8388             Safefree(lcres);
8389             Safefree(tpl);
8390             return 0;
8391         }
8392         if (!decc_efs_case_preserve) {
8393           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8394             if (_tolower(*cp1) != _tolower(*cp2)) break;
8395         }
8396         segdirs = dirs - totells;  /* Min # of dirs we must have left */
8397         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8398         if (*cp1 == '\0' && *cp2 == '/') {
8399           memmove(fspec,cp2+1,end - cp2);
8400           PerlMem_free(tpl);
8401           PerlMem_free(unixified);
8402           PerlMem_free(unixwild);
8403           PerlMem_free(lcres);
8404           return 1;
8405         }
8406         /* Nope -- stick with lcfront from above and keep going. */
8407       }
8408     }
8409     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8410     PerlMem_free(tpl);
8411     PerlMem_free(unixified);
8412     PerlMem_free(unixwild);
8413     PerlMem_free(lcres);
8414     return 1;
8415     ellipsis = nextell;
8416   }
8417
8418 }  /* end of trim_unixpath() */
8419 /*}}}*/
8420
8421
8422 /*
8423  *  VMS readdir() routines.
8424  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8425  *
8426  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
8427  *  Minor modifications to original routines.
8428  */
8429
8430 /* readdir may have been redefined by reentr.h, so make sure we get
8431  * the local version for what we do here.
8432  */
8433 #ifdef readdir
8434 # undef readdir
8435 #endif
8436 #if !defined(PERL_IMPLICIT_CONTEXT)
8437 # define readdir Perl_readdir
8438 #else
8439 # define readdir(a) Perl_readdir(aTHX_ a)
8440 #endif
8441
8442     /* Number of elements in vms_versions array */
8443 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
8444
8445 /*
8446  *  Open a directory, return a handle for later use.
8447  */
8448 /*{{{ DIR *opendir(char*name) */
8449 DIR *
8450 Perl_opendir(pTHX_ const char *name)
8451 {
8452     DIR *dd;
8453     char *dir;
8454     Stat_t sb;
8455     int unix_flag;
8456
8457     unix_flag = 0;
8458     if (decc_efs_charset) {
8459         unix_flag = is_unix_filespec(name);
8460     }
8461
8462     Newx(dir, VMS_MAXRSS, char);
8463     if (do_tovmspath(name,dir,0,NULL) == NULL) {
8464       Safefree(dir);
8465       return NULL;
8466     }
8467     /* Check access before stat; otherwise stat does not
8468      * accurately report whether it's a directory.
8469      */
8470     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8471       /* cando_by_name has already set errno */
8472       Safefree(dir);
8473       return NULL;
8474     }
8475     if (flex_stat(dir,&sb) == -1) return NULL;
8476     if (!S_ISDIR(sb.st_mode)) {
8477       Safefree(dir);
8478       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
8479       return NULL;
8480     }
8481     /* Get memory for the handle, and the pattern. */
8482     Newx(dd,1,DIR);
8483     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8484
8485     /* Fill in the fields; mainly playing with the descriptor. */
8486     sprintf(dd->pattern, "%s*.*",dir);
8487     Safefree(dir);
8488     dd->context = 0;
8489     dd->count = 0;
8490     dd->flags = 0;
8491     if (unix_flag)
8492         dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8493     dd->pat.dsc$a_pointer = dd->pattern;
8494     dd->pat.dsc$w_length = strlen(dd->pattern);
8495     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8496     dd->pat.dsc$b_class = DSC$K_CLASS_S;
8497 #if defined(USE_ITHREADS)
8498     Newx(dd->mutex,1,perl_mutex);
8499     MUTEX_INIT( (perl_mutex *) dd->mutex );
8500 #else
8501     dd->mutex = NULL;
8502 #endif
8503
8504     return dd;
8505 }  /* end of opendir() */
8506 /*}}}*/
8507
8508 /*
8509  *  Set the flag to indicate we want versions or not.
8510  */
8511 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8512 void
8513 vmsreaddirversions(DIR *dd, int flag)
8514 {
8515     if (flag)
8516         dd->flags |= PERL_VMSDIR_M_VERSIONS;
8517     else
8518         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8519 }
8520 /*}}}*/
8521
8522 /*
8523  *  Free up an opened directory.
8524  */
8525 /*{{{ void closedir(DIR *dd)*/
8526 void
8527 Perl_closedir(DIR *dd)
8528 {
8529     int sts;
8530
8531     sts = lib$find_file_end(&dd->context);
8532     Safefree(dd->pattern);
8533 #if defined(USE_ITHREADS)
8534     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8535     Safefree(dd->mutex);
8536 #endif
8537     Safefree(dd);
8538 }
8539 /*}}}*/
8540
8541 /*
8542  *  Collect all the version numbers for the current file.
8543  */
8544 static void
8545 collectversions(pTHX_ DIR *dd)
8546 {
8547     struct dsc$descriptor_s     pat;
8548     struct dsc$descriptor_s     res;
8549     struct dirent *e;
8550     char *p, *text, *buff;
8551     int i;
8552     unsigned long context, tmpsts;
8553
8554     /* Convenient shorthand. */
8555     e = &dd->entry;
8556
8557     /* Add the version wildcard, ignoring the "*.*" put on before */
8558     i = strlen(dd->pattern);
8559     Newx(text,i + e->d_namlen + 3,char);
8560     strcpy(text, dd->pattern);
8561     sprintf(&text[i - 3], "%s;*", e->d_name);
8562
8563     /* Set up the pattern descriptor. */
8564     pat.dsc$a_pointer = text;
8565     pat.dsc$w_length = i + e->d_namlen - 1;
8566     pat.dsc$b_dtype = DSC$K_DTYPE_T;
8567     pat.dsc$b_class = DSC$K_CLASS_S;
8568
8569     /* Set up result descriptor. */
8570     Newx(buff, VMS_MAXRSS, char);
8571     res.dsc$a_pointer = buff;
8572     res.dsc$w_length = VMS_MAXRSS - 1;
8573     res.dsc$b_dtype = DSC$K_DTYPE_T;
8574     res.dsc$b_class = DSC$K_CLASS_S;
8575
8576     /* Read files, collecting versions. */
8577     for (context = 0, e->vms_verscount = 0;
8578          e->vms_verscount < VERSIZE(e);
8579          e->vms_verscount++) {
8580         unsigned long rsts;
8581         unsigned long flags = 0;
8582
8583 #ifdef VMS_LONGNAME_SUPPORT
8584         flags = LIB$M_FIL_LONG_NAMES;
8585 #endif
8586         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8587         if (tmpsts == RMS$_NMF || context == 0) break;
8588         _ckvmssts(tmpsts);
8589         buff[VMS_MAXRSS - 1] = '\0';
8590         if ((p = strchr(buff, ';')))
8591             e->vms_versions[e->vms_verscount] = atoi(p + 1);
8592         else
8593             e->vms_versions[e->vms_verscount] = -1;
8594     }
8595
8596     _ckvmssts(lib$find_file_end(&context));
8597     Safefree(text);
8598     Safefree(buff);
8599
8600 }  /* end of collectversions() */
8601
8602 /*
8603  *  Read the next entry from the directory.
8604  */
8605 /*{{{ struct dirent *readdir(DIR *dd)*/
8606 struct dirent *
8607 Perl_readdir(pTHX_ DIR *dd)
8608 {
8609     struct dsc$descriptor_s     res;
8610     char *p, *buff;
8611     unsigned long int tmpsts;
8612     unsigned long rsts;
8613     unsigned long flags = 0;
8614     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8615     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8616
8617     /* Set up result descriptor, and get next file. */
8618     Newx(buff, VMS_MAXRSS, char);
8619     res.dsc$a_pointer = buff;
8620     res.dsc$w_length = VMS_MAXRSS - 1;
8621     res.dsc$b_dtype = DSC$K_DTYPE_T;
8622     res.dsc$b_class = DSC$K_CLASS_S;
8623
8624 #ifdef VMS_LONGNAME_SUPPORT
8625     flags = LIB$M_FIL_LONG_NAMES;
8626 #endif
8627
8628     tmpsts = lib$find_file
8629         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8630     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
8631     if (!(tmpsts & 1)) {
8632       set_vaxc_errno(tmpsts);
8633       switch (tmpsts) {
8634         case RMS$_PRV:
8635           set_errno(EACCES); break;
8636         case RMS$_DEV:
8637           set_errno(ENODEV); break;
8638         case RMS$_DIR:
8639           set_errno(ENOTDIR); break;
8640         case RMS$_FNF: case RMS$_DNF:
8641           set_errno(ENOENT); break;
8642         default:
8643           set_errno(EVMSERR);
8644       }
8645       Safefree(buff);
8646       return NULL;
8647     }
8648     dd->count++;
8649     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8650     if (!decc_efs_case_preserve) {
8651       buff[VMS_MAXRSS - 1] = '\0';
8652       for (p = buff; *p; p++) *p = _tolower(*p);
8653     }
8654     else {
8655       /* we don't want to force to lowercase, just null terminate */
8656       buff[res.dsc$w_length] = '\0';
8657     }
8658     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
8659     *p = '\0';
8660
8661     /* Skip any directory component and just copy the name. */
8662     sts = vms_split_path
8663        (buff,
8664         &v_spec,
8665         &v_len,
8666         &r_spec,
8667         &r_len,
8668         &d_spec,
8669         &d_len,
8670         &n_spec,
8671         &n_len,
8672         &e_spec,
8673         &e_len,
8674         &vs_spec,
8675         &vs_len);
8676
8677     /* Drop NULL extensions on UNIX file specification */
8678     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8679         (e_len == 1) && decc_readdir_dropdotnotype)) {
8680         e_len = 0;
8681         e_spec[0] = '\0';
8682     }
8683
8684     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8685     dd->entry.d_name[n_len + e_len] = '\0';
8686     dd->entry.d_namlen = strlen(dd->entry.d_name);
8687
8688     /* Convert the filename to UNIX format if needed */
8689     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8690
8691         /* Translate the encoded characters. */
8692         /* Fixme: unicode handling could result in embedded 0 characters */
8693         if (strchr(dd->entry.d_name, '^') != NULL) {
8694             char new_name[256];
8695             char * q;
8696             int cnt;
8697             p = dd->entry.d_name;
8698             q = new_name;
8699             while (*p != 0) {
8700                 int x, y;
8701                 x = copy_expand_vms_filename_escape(q, p, &y);
8702                 p += x;
8703                 q += y;
8704                 /* fix-me */
8705                 /* if y > 1, then this is a wide file specification */
8706                 /* Wide file specifications need to be passed in Perl */
8707                 /* counted strings apparently with a unicode flag */
8708             }
8709             *q = 0;
8710             strcpy(dd->entry.d_name, new_name);
8711         }
8712     }
8713
8714     dd->entry.vms_verscount = 0;
8715     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8716     Safefree(buff);
8717     return &dd->entry;
8718
8719 }  /* end of readdir() */
8720 /*}}}*/
8721
8722 /*
8723  *  Read the next entry from the directory -- thread-safe version.
8724  */
8725 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
8726 int
8727 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
8728 {
8729     int retval;
8730
8731     MUTEX_LOCK( (perl_mutex *) dd->mutex );
8732
8733     entry = readdir(dd);
8734     *result = entry;
8735     retval = ( *result == NULL ? errno : 0 );
8736
8737     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
8738
8739     return retval;
8740
8741 }  /* end of readdir_r() */
8742 /*}}}*/
8743
8744 /*
8745  *  Return something that can be used in a seekdir later.
8746  */
8747 /*{{{ long telldir(DIR *dd)*/
8748 long
8749 Perl_telldir(DIR *dd)
8750 {
8751     return dd->count;
8752 }
8753 /*}}}*/
8754
8755 /*
8756  *  Return to a spot where we used to be.  Brute force.
8757  */
8758 /*{{{ void seekdir(DIR *dd,long count)*/
8759 void
8760 Perl_seekdir(pTHX_ DIR *dd, long count)
8761 {
8762     int old_flags;
8763
8764     /* If we haven't done anything yet... */
8765     if (dd->count == 0)
8766         return;
8767
8768     /* Remember some state, and clear it. */
8769     old_flags = dd->flags;
8770     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8771     _ckvmssts(lib$find_file_end(&dd->context));
8772     dd->context = 0;
8773
8774     /* The increment is in readdir(). */
8775     for (dd->count = 0; dd->count < count; )
8776         readdir(dd);
8777
8778     dd->flags = old_flags;
8779
8780 }  /* end of seekdir() */
8781 /*}}}*/
8782
8783 /* VMS subprocess management
8784  *
8785  * my_vfork() - just a vfork(), after setting a flag to record that
8786  * the current script is trying a Unix-style fork/exec.
8787  *
8788  * vms_do_aexec() and vms_do_exec() are called in response to the
8789  * perl 'exec' function.  If this follows a vfork call, then they
8790  * call out the regular perl routines in doio.c which do an
8791  * execvp (for those who really want to try this under VMS).
8792  * Otherwise, they do exactly what the perl docs say exec should
8793  * do - terminate the current script and invoke a new command
8794  * (See below for notes on command syntax.)
8795  *
8796  * do_aspawn() and do_spawn() implement the VMS side of the perl
8797  * 'system' function.
8798  *
8799  * Note on command arguments to perl 'exec' and 'system': When handled
8800  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
8801  * are concatenated to form a DCL command string.  If the first arg
8802  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
8803  * the command string is handed off to DCL directly.  Otherwise,
8804  * the first token of the command is taken as the filespec of an image
8805  * to run.  The filespec is expanded using a default type of '.EXE' and
8806  * the process defaults for device, directory, etc., and if found, the resultant
8807  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
8808  * the command string as parameters.  This is perhaps a bit complicated,
8809  * but I hope it will form a happy medium between what VMS folks expect
8810  * from lib$spawn and what Unix folks expect from exec.
8811  */
8812
8813 static int vfork_called;
8814
8815 /*{{{int my_vfork()*/
8816 int
8817 my_vfork()
8818 {
8819   vfork_called++;
8820   return vfork();
8821 }
8822 /*}}}*/
8823
8824
8825 static void
8826 vms_execfree(struct dsc$descriptor_s *vmscmd)
8827 {
8828   if (vmscmd) {
8829       if (vmscmd->dsc$a_pointer) {
8830           PerlMem_free(vmscmd->dsc$a_pointer);
8831       }
8832       PerlMem_free(vmscmd);
8833   }
8834 }
8835
8836 static char *
8837 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
8838 {
8839   char *junk, *tmps = Nullch;
8840   register size_t cmdlen = 0;
8841   size_t rlen;
8842   register SV **idx;
8843   STRLEN n_a;
8844
8845   idx = mark;
8846   if (really) {
8847     tmps = SvPV(really,rlen);
8848     if (*tmps) {
8849       cmdlen += rlen + 1;
8850       idx++;
8851     }
8852   }
8853
8854   for (idx++; idx <= sp; idx++) {
8855     if (*idx) {
8856       junk = SvPVx(*idx,rlen);
8857       cmdlen += rlen ? rlen + 1 : 0;
8858     }
8859   }
8860   Newx(PL_Cmd, cmdlen+1, char);
8861
8862   if (tmps && *tmps) {
8863     strcpy(PL_Cmd,tmps);
8864     mark++;
8865   }
8866   else *PL_Cmd = '\0';
8867   while (++mark <= sp) {
8868     if (*mark) {
8869       char *s = SvPVx(*mark,n_a);
8870       if (!*s) continue;
8871       if (*PL_Cmd) strcat(PL_Cmd," ");
8872       strcat(PL_Cmd,s);
8873     }
8874   }
8875   return PL_Cmd;
8876
8877 }  /* end of setup_argstr() */
8878
8879
8880 static unsigned long int
8881 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
8882                    struct dsc$descriptor_s **pvmscmd)
8883 {
8884   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
8885   char image_name[NAM$C_MAXRSS+1];
8886   char image_argv[NAM$C_MAXRSS+1];
8887   $DESCRIPTOR(defdsc,".EXE");
8888   $DESCRIPTOR(defdsc2,".");
8889   $DESCRIPTOR(resdsc,resspec);
8890   struct dsc$descriptor_s *vmscmd;
8891   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8892   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
8893   register char *s, *rest, *cp, *wordbreak;
8894   char * cmd;
8895   int cmdlen;
8896   register int isdcl;
8897
8898   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8899   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
8900
8901   /* Make a copy for modification */
8902   cmdlen = strlen(incmd);
8903   cmd = PerlMem_malloc(cmdlen+1);
8904   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
8905   strncpy(cmd, incmd, cmdlen);
8906   cmd[cmdlen] = 0;
8907   image_name[0] = 0;
8908   image_argv[0] = 0;
8909
8910   vmscmd->dsc$a_pointer = NULL;
8911   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
8912   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
8913   vmscmd->dsc$w_length = 0;
8914   if (pvmscmd) *pvmscmd = vmscmd;
8915
8916   if (suggest_quote) *suggest_quote = 0;
8917
8918   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
8919     PerlMem_free(cmd);
8920     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
8921   }
8922
8923   s = cmd;
8924
8925   while (*s && isspace(*s)) s++;
8926
8927   if (*s == '@' || *s == '$') {
8928     vmsspec[0] = *s;  rest = s + 1;
8929     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
8930   }
8931   else { cp = vmsspec; rest = s; }
8932   if (*rest == '.' || *rest == '/') {
8933     char *cp2;
8934     for (cp2 = resspec;
8935          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
8936          rest++, cp2++) *cp2 = *rest;
8937     *cp2 = '\0';
8938     if (do_tovmsspec(resspec,cp,0,NULL)) {
8939       s = vmsspec;
8940       if (*rest) {
8941         for (cp2 = vmsspec + strlen(vmsspec);
8942              *rest && cp2 - vmsspec < sizeof vmsspec;
8943              rest++, cp2++) *cp2 = *rest;
8944         *cp2 = '\0';
8945       }
8946     }
8947   }
8948   /* Intuit whether verb (first word of cmd) is a DCL command:
8949    *   - if first nonspace char is '@', it's a DCL indirection
8950    * otherwise
8951    *   - if verb contains a filespec separator, it's not a DCL command
8952    *   - if it doesn't, caller tells us whether to default to a DCL
8953    *     command, or to a local image unless told it's DCL (by leading '$')
8954    */
8955   if (*s == '@') {
8956       isdcl = 1;
8957       if (suggest_quote) *suggest_quote = 1;
8958   } else {
8959     register char *filespec = strpbrk(s,":<[.;");
8960     rest = wordbreak = strpbrk(s," \"\t/");
8961     if (!wordbreak) wordbreak = s + strlen(s);
8962     if (*s == '$') check_img = 0;
8963     if (filespec && (filespec < wordbreak)) isdcl = 0;
8964     else isdcl = !check_img;
8965   }
8966
8967   if (!isdcl) {
8968     int rsts;
8969     imgdsc.dsc$a_pointer = s;
8970     imgdsc.dsc$w_length = wordbreak - s;
8971     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8972     if (!(retsts&1)) {
8973         _ckvmssts(lib$find_file_end(&cxt));
8974         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8975       if (!(retsts & 1) && *s == '$') {
8976         _ckvmssts(lib$find_file_end(&cxt));
8977         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
8978         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8979         if (!(retsts&1)) {
8980           _ckvmssts(lib$find_file_end(&cxt));
8981           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8982         }
8983       }
8984     }
8985     _ckvmssts(lib$find_file_end(&cxt));
8986
8987     if (retsts & 1) {
8988       FILE *fp;
8989       s = resspec;
8990       while (*s && !isspace(*s)) s++;
8991       *s = '\0';
8992
8993       /* check that it's really not DCL with no file extension */
8994       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8995       if (fp) {
8996         char b[256] = {0,0,0,0};
8997         read(fileno(fp), b, 256);
8998         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
8999         if (isdcl) {
9000           int shebang_len;
9001
9002           /* Check for script */
9003           shebang_len = 0;
9004           if ((b[0] == '#') && (b[1] == '!'))
9005              shebang_len = 2;
9006 #ifdef ALTERNATE_SHEBANG
9007           else {
9008             shebang_len = strlen(ALTERNATE_SHEBANG);
9009             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9010               char * perlstr;
9011                 perlstr = strstr("perl",b);
9012                 if (perlstr == NULL)
9013                   shebang_len = 0;
9014             }
9015             else
9016               shebang_len = 0;
9017           }
9018 #endif
9019
9020           if (shebang_len > 0) {
9021           int i;
9022           int j;
9023           char tmpspec[NAM$C_MAXRSS + 1];
9024
9025             i = shebang_len;
9026              /* Image is following after white space */
9027             /*--------------------------------------*/
9028             while (isprint(b[i]) && isspace(b[i]))
9029                 i++;
9030
9031             j = 0;
9032             while (isprint(b[i]) && !isspace(b[i])) {
9033                 tmpspec[j++] = b[i++];
9034                 if (j >= NAM$C_MAXRSS)
9035                    break;
9036             }
9037             tmpspec[j] = '\0';
9038
9039              /* There may be some default parameters to the image */
9040             /*---------------------------------------------------*/
9041             j = 0;
9042             while (isprint(b[i])) {
9043                 image_argv[j++] = b[i++];
9044                 if (j >= NAM$C_MAXRSS)
9045                    break;
9046             }
9047             while ((j > 0) && !isprint(image_argv[j-1]))
9048                 j--;
9049             image_argv[j] = 0;
9050
9051             /* It will need to be converted to VMS format and validated */
9052             if (tmpspec[0] != '\0') {
9053               char * iname;
9054
9055                /* Try to find the exact program requested to be run */
9056               /*---------------------------------------------------*/
9057               iname = do_rmsexpand
9058                  (tmpspec, image_name, 0, ".exe",
9059                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
9060               if (iname != NULL) {
9061                 if (cando_by_name_int
9062                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9063                   /* MCR prefix needed */
9064                   isdcl = 0;
9065                 }
9066                 else {
9067                    /* Try again with a null type */
9068                   /*----------------------------*/
9069                   iname = do_rmsexpand
9070                     (tmpspec, image_name, 0, ".",
9071                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
9072                   if (iname != NULL) {
9073                     if (cando_by_name_int
9074                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9075                       /* MCR prefix needed */
9076                       isdcl = 0;
9077                     }
9078                   }
9079                 }
9080
9081                  /* Did we find the image to run the script? */
9082                 /*------------------------------------------*/
9083                 if (isdcl) {
9084                   char *tchr;
9085
9086                    /* Assume DCL or foreign command exists */
9087                   /*--------------------------------------*/
9088                   tchr = strrchr(tmpspec, '/');
9089                   if (tchr != NULL) {
9090                     tchr++;
9091                   }
9092                   else {
9093                     tchr = tmpspec;
9094                   }
9095                   strcpy(image_name, tchr);
9096                 }
9097               }
9098             }
9099           }
9100         }
9101         fclose(fp);
9102       }
9103       if (check_img && isdcl) return RMS$_FNF;
9104
9105       if (cando_by_name(S_IXUSR,0,resspec)) {
9106         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9107         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9108         if (!isdcl) {
9109             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9110             if (image_name[0] != 0) {
9111                 strcat(vmscmd->dsc$a_pointer, image_name);
9112                 strcat(vmscmd->dsc$a_pointer, " ");
9113             }
9114         } else if (image_name[0] != 0) {
9115             strcpy(vmscmd->dsc$a_pointer, image_name);
9116             strcat(vmscmd->dsc$a_pointer, " ");
9117         } else {
9118             strcpy(vmscmd->dsc$a_pointer,"@");
9119         }
9120         if (suggest_quote) *suggest_quote = 1;
9121
9122         /* If there is an image name, use original command */
9123         if (image_name[0] == 0)
9124             strcat(vmscmd->dsc$a_pointer,resspec);
9125         else {
9126             rest = cmd;
9127             while (*rest && isspace(*rest)) rest++;
9128         }
9129
9130         if (image_argv[0] != 0) {
9131           strcat(vmscmd->dsc$a_pointer,image_argv);
9132           strcat(vmscmd->dsc$a_pointer, " ");
9133         }
9134         if (rest) {
9135            int rest_len;
9136            int vmscmd_len;
9137
9138            rest_len = strlen(rest);
9139            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9140            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9141               strcat(vmscmd->dsc$a_pointer,rest);
9142            else
9143              retsts = CLI$_BUFOVF;
9144         }
9145         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9146         PerlMem_free(cmd);
9147         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9148       }
9149       else
9150         retsts = RMS$_PRV;
9151     }
9152   }
9153   /* It's either a DCL command or we couldn't find a suitable image */
9154   vmscmd->dsc$w_length = strlen(cmd);
9155
9156   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9157   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9158   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9159
9160   PerlMem_free(cmd);
9161
9162   /* check if it's a symbol (for quoting purposes) */
9163   if (suggest_quote && !*suggest_quote) {
9164     int iss;
9165     char equiv[LNM$C_NAMLENGTH];
9166     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9167     eqvdsc.dsc$a_pointer = equiv;
9168
9169     iss = lib$get_symbol(vmscmd,&eqvdsc);
9170     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9171   }
9172   if (!(retsts & 1)) {
9173     /* just hand off status values likely to be due to user error */
9174     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9175         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9176        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9177     else { _ckvmssts(retsts); }
9178   }
9179
9180   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9181
9182 }  /* end of setup_cmddsc() */
9183
9184
9185 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9186 bool
9187 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9188 {
9189 bool exec_sts;
9190 char * cmd;
9191
9192   if (sp > mark) {
9193     if (vfork_called) {           /* this follows a vfork - act Unixish */
9194       vfork_called--;
9195       if (vfork_called < 0) {
9196         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9197         vfork_called = 0;
9198       }
9199       else return do_aexec(really,mark,sp);
9200     }
9201                                            /* no vfork - act VMSish */
9202     cmd = setup_argstr(aTHX_ really,mark,sp);
9203     exec_sts = vms_do_exec(cmd);
9204     Safefree(cmd);  /* Clean up from setup_argstr() */
9205     return exec_sts;
9206   }
9207
9208   return FALSE;
9209 }  /* end of vms_do_aexec() */
9210 /*}}}*/
9211
9212 /* {{{bool vms_do_exec(char *cmd) */
9213 bool
9214 Perl_vms_do_exec(pTHX_ const char *cmd)
9215 {
9216   struct dsc$descriptor_s *vmscmd;
9217
9218   if (vfork_called) {             /* this follows a vfork - act Unixish */
9219     vfork_called--;
9220     if (vfork_called < 0) {
9221       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9222       vfork_called = 0;
9223     }
9224     else return do_exec(cmd);
9225   }
9226
9227   {                               /* no vfork - act VMSish */
9228     unsigned long int retsts;
9229
9230     TAINT_ENV();
9231     TAINT_PROPER("exec");
9232     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9233       retsts = lib$do_command(vmscmd);
9234
9235     switch (retsts) {
9236       case RMS$_FNF: case RMS$_DNF:
9237         set_errno(ENOENT); break;
9238       case RMS$_DIR:
9239         set_errno(ENOTDIR); break;
9240       case RMS$_DEV:
9241         set_errno(ENODEV); break;
9242       case RMS$_PRV:
9243         set_errno(EACCES); break;
9244       case RMS$_SYN:
9245         set_errno(EINVAL); break;
9246       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9247         set_errno(E2BIG); break;
9248       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9249         _ckvmssts(retsts); /* fall through */
9250       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9251         set_errno(EVMSERR);
9252     }
9253     set_vaxc_errno(retsts);
9254     if (ckWARN(WARN_EXEC)) {
9255       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9256              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9257     }
9258     vms_execfree(vmscmd);
9259   }
9260
9261   return FALSE;
9262
9263 }  /* end of vms_do_exec() */
9264 /*}}}*/
9265
9266 unsigned long int Perl_do_spawn(pTHX_ const char *);
9267
9268 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9269 unsigned long int
9270 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9271 {
9272 unsigned long int sts;
9273 char * cmd;
9274
9275   if (sp > mark) {
9276     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9277     sts = do_spawn(cmd);
9278     /* pp_sys will clean up cmd */
9279     return sts;
9280   }
9281   return SS$_ABORT;
9282 }  /* end of do_aspawn() */
9283 /*}}}*/
9284
9285 /* {{{unsigned long int do_spawn(char *cmd) */
9286 unsigned long int
9287 Perl_do_spawn(pTHX_ const char *cmd)
9288 {
9289   unsigned long int sts, substs;
9290
9291   /* The caller of this routine expects to Safefree(PL_Cmd) */
9292   Newx(PL_Cmd,10,char);
9293
9294   TAINT_ENV();
9295   TAINT_PROPER("spawn");
9296   if (!cmd || !*cmd) {
9297     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9298     if (!(sts & 1)) {
9299       switch (sts) {
9300         case RMS$_FNF:  case RMS$_DNF:
9301           set_errno(ENOENT); break;
9302         case RMS$_DIR:
9303           set_errno(ENOTDIR); break;
9304         case RMS$_DEV:
9305           set_errno(ENODEV); break;
9306         case RMS$_PRV:
9307           set_errno(EACCES); break;
9308         case RMS$_SYN:
9309           set_errno(EINVAL); break;
9310         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9311           set_errno(E2BIG); break;
9312         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9313           _ckvmssts(sts); /* fall through */
9314         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9315           set_errno(EVMSERR);
9316       }
9317       set_vaxc_errno(sts);
9318       if (ckWARN(WARN_EXEC)) {
9319         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9320                     Strerror(errno));
9321       }
9322     }
9323     sts = substs;
9324   }
9325   else {
9326     PerlIO * fp;
9327     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9328     if (fp != NULL)
9329       my_pclose(fp);
9330   }
9331   return sts;
9332 }  /* end of do_spawn() */
9333 /*}}}*/
9334
9335
9336 static unsigned int *sockflags, sockflagsize;
9337
9338 /*
9339  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9340  * routines found in some versions of the CRTL can't deal with sockets.
9341  * We don't shim the other file open routines since a socket isn't
9342  * likely to be opened by a name.
9343  */
9344 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9345 FILE *my_fdopen(int fd, const char *mode)
9346 {
9347   FILE *fp = fdopen(fd, mode);
9348
9349   if (fp) {
9350     unsigned int fdoff = fd / sizeof(unsigned int);
9351     Stat_t sbuf; /* native stat; we don't need flex_stat */
9352     if (!sockflagsize || fdoff > sockflagsize) {
9353       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
9354       else           Newx  (sockflags,fdoff+2,unsigned int);
9355       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9356       sockflagsize = fdoff + 2;
9357     }
9358     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9359       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9360   }
9361   return fp;
9362
9363 }
9364 /*}}}*/
9365
9366
9367 /*
9368  * Clear the corresponding bit when the (possibly) socket stream is closed.
9369  * There still a small hole: we miss an implicit close which might occur
9370  * via freopen().  >> Todo
9371  */
9372 /*{{{ int my_fclose(FILE *fp)*/
9373 int my_fclose(FILE *fp) {
9374   if (fp) {
9375     unsigned int fd = fileno(fp);
9376     unsigned int fdoff = fd / sizeof(unsigned int);
9377
9378     if (sockflagsize && fdoff <= sockflagsize)
9379       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9380   }
9381   return fclose(fp);
9382 }
9383 /*}}}*/
9384
9385
9386 /*
9387  * A simple fwrite replacement which outputs itmsz*nitm chars without
9388  * introducing record boundaries every itmsz chars.
9389  * We are using fputs, which depends on a terminating null.  We may
9390  * well be writing binary data, so we need to accommodate not only
9391  * data with nulls sprinkled in the middle but also data with no null
9392  * byte at the end.
9393  */
9394 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9395 int
9396 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9397 {
9398   register char *cp, *end, *cpd, *data;
9399   register unsigned int fd = fileno(dest);
9400   register unsigned int fdoff = fd / sizeof(unsigned int);
9401   int retval;
9402   int bufsize = itmsz * nitm + 1;
9403
9404   if (fdoff < sockflagsize &&
9405       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9406     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9407     return nitm;
9408   }
9409
9410   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9411   memcpy( data, src, itmsz*nitm );
9412   data[itmsz*nitm] = '\0';
9413
9414   end = data + itmsz * nitm;
9415   retval = (int) nitm; /* on success return # items written */
9416
9417   cpd = data;
9418   while (cpd <= end) {
9419     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9420     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9421     if (cp < end)
9422       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9423     cpd = cp + 1;
9424   }
9425
9426   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9427   return retval;
9428
9429 }  /* end of my_fwrite() */
9430 /*}}}*/
9431
9432 /*{{{ int my_flush(FILE *fp)*/
9433 int
9434 Perl_my_flush(pTHX_ FILE *fp)
9435 {
9436     int res;
9437     if ((res = fflush(fp)) == 0 && fp) {
9438 #ifdef VMS_DO_SOCKETS
9439         Stat_t s;
9440         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9441 #endif
9442             res = fsync(fileno(fp));
9443     }
9444 /*
9445  * If the flush succeeded but set end-of-file, we need to clear
9446  * the error because our caller may check ferror().  BTW, this
9447  * probably means we just flushed an empty file.
9448  */
9449     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9450
9451     return res;
9452 }
9453 /*}}}*/
9454
9455 /*
9456  * Here are replacements for the following Unix routines in the VMS environment:
9457  *      getpwuid    Get information for a particular UIC or UID
9458  *      getpwnam    Get information for a named user
9459  *      getpwent    Get information for each user in the rights database
9460  *      setpwent    Reset search to the start of the rights database
9461  *      endpwent    Finish searching for users in the rights database
9462  *
9463  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9464  * (defined in pwd.h), which contains the following fields:-
9465  *      struct passwd {
9466  *              char        *pw_name;    Username (in lower case)
9467  *              char        *pw_passwd;  Hashed password
9468  *              unsigned int pw_uid;     UIC
9469  *              unsigned int pw_gid;     UIC group  number
9470  *              char        *pw_unixdir; Default device/directory (VMS-style)
9471  *              char        *pw_gecos;   Owner name
9472  *              char        *pw_dir;     Default device/directory (Unix-style)
9473  *              char        *pw_shell;   Default CLI name (eg. DCL)
9474  *      };
9475  * If the specified user does not exist, getpwuid and getpwnam return NULL.
9476  *
9477  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9478  * not the UIC member number (eg. what's returned by getuid()),
9479  * getpwuid() can accept either as input (if uid is specified, the caller's
9480  * UIC group is used), though it won't recognise gid=0.
9481  *
9482  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9483  * information about other users in your group or in other groups, respectively.
9484  * If the required privilege is not available, then these routines fill only
9485  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9486  * string).
9487  *
9488  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9489  */
9490
9491 /* sizes of various UAF record fields */
9492 #define UAI$S_USERNAME 12
9493 #define UAI$S_IDENT    31
9494 #define UAI$S_OWNER    31
9495 #define UAI$S_DEFDEV   31
9496 #define UAI$S_DEFDIR   63
9497 #define UAI$S_DEFCLI   31
9498 #define UAI$S_PWD       8
9499
9500 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
9501                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9502                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
9503
9504 static char __empty[]= "";
9505 static struct passwd __passwd_empty=
9506     {(char *) __empty, (char *) __empty, 0, 0,
9507      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9508 static int contxt= 0;
9509 static struct passwd __pwdcache;
9510 static char __pw_namecache[UAI$S_IDENT+1];
9511
9512 /*
9513  * This routine does most of the work extracting the user information.
9514  */
9515 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9516 {
9517     static struct {
9518         unsigned char length;
9519         char pw_gecos[UAI$S_OWNER+1];
9520     } owner;
9521     static union uicdef uic;
9522     static struct {
9523         unsigned char length;
9524         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9525     } defdev;
9526     static struct {
9527         unsigned char length;
9528         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9529     } defdir;
9530     static struct {
9531         unsigned char length;
9532         char pw_shell[UAI$S_DEFCLI+1];
9533     } defcli;
9534     static char pw_passwd[UAI$S_PWD+1];
9535
9536     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9537     struct dsc$descriptor_s name_desc;
9538     unsigned long int sts;
9539
9540     static struct itmlst_3 itmlst[]= {
9541         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
9542         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
9543         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
9544         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
9545         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
9546         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
9547         {0,                0,           NULL,    NULL}};
9548
9549     name_desc.dsc$w_length=  strlen(name);
9550     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9551     name_desc.dsc$b_class=   DSC$K_CLASS_S;
9552     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9553
9554 /*  Note that sys$getuai returns many fields as counted strings. */
9555     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9556     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9557       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9558     }
9559     else { _ckvmssts(sts); }
9560     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
9561
9562     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
9563     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9564     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9565     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9566     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9567     owner.pw_gecos[lowner]=            '\0';
9568     defdev.pw_dir[ldefdev+ldefdir]= '\0';
9569     defcli.pw_shell[ldefcli]=          '\0';
9570     if (valid_uic(uic)) {
9571         pwd->pw_uid= uic.uic$l_uic;
9572         pwd->pw_gid= uic.uic$v_group;
9573     }
9574     else
9575       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9576     pwd->pw_passwd=  pw_passwd;
9577     pwd->pw_gecos=   owner.pw_gecos;
9578     pwd->pw_dir=     defdev.pw_dir;
9579     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9580     pwd->pw_shell=   defcli.pw_shell;
9581     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9582         int ldir;
9583         ldir= strlen(pwd->pw_unixdir) - 1;
9584         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9585     }
9586     else
9587         strcpy(pwd->pw_unixdir, pwd->pw_dir);
9588     if (!decc_efs_case_preserve)
9589         __mystrtolower(pwd->pw_unixdir);
9590     return 1;
9591 }
9592
9593 /*
9594  * Get information for a named user.
9595 */
9596 /*{{{struct passwd *getpwnam(char *name)*/
9597 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9598 {
9599     struct dsc$descriptor_s name_desc;
9600     union uicdef uic;
9601     unsigned long int status, sts;
9602
9603     __pwdcache = __passwd_empty;
9604     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9605       /* We still may be able to determine pw_uid and pw_gid */
9606       name_desc.dsc$w_length=  strlen(name);
9607       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9608       name_desc.dsc$b_class=   DSC$K_CLASS_S;
9609       name_desc.dsc$a_pointer= (char *) name;
9610       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9611         __pwdcache.pw_uid= uic.uic$l_uic;
9612         __pwdcache.pw_gid= uic.uic$v_group;
9613       }
9614       else {
9615         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9616           set_vaxc_errno(sts);
9617           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9618           return NULL;
9619         }
9620         else { _ckvmssts(sts); }
9621       }
9622     }
9623     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9624     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9625     __pwdcache.pw_name= __pw_namecache;
9626     return &__pwdcache;
9627 }  /* end of my_getpwnam() */
9628 /*}}}*/
9629
9630 /*
9631  * Get information for a particular UIC or UID.
9632  * Called by my_getpwent with uid=-1 to list all users.
9633 */
9634 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9635 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9636 {
9637     const $DESCRIPTOR(name_desc,__pw_namecache);
9638     unsigned short lname;
9639     union uicdef uic;
9640     unsigned long int status;
9641
9642     if (uid == (unsigned int) -1) {
9643       do {
9644         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9645         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9646           set_vaxc_errno(status);
9647           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9648           my_endpwent();
9649           return NULL;
9650         }
9651         else { _ckvmssts(status); }
9652       } while (!valid_uic (uic));
9653     }
9654     else {
9655       uic.uic$l_uic= uid;
9656       if (!uic.uic$v_group)
9657         uic.uic$v_group= PerlProc_getgid();
9658       if (valid_uic(uic))
9659         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9660       else status = SS$_IVIDENT;
9661       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9662           status == RMS$_PRV) {
9663         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9664         return NULL;
9665       }
9666       else { _ckvmssts(status); }
9667     }
9668     __pw_namecache[lname]= '\0';
9669     __mystrtolower(__pw_namecache);
9670
9671     __pwdcache = __passwd_empty;
9672     __pwdcache.pw_name = __pw_namecache;
9673
9674 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9675     The identifier's value is usually the UIC, but it doesn't have to be,
9676     so if we can, we let fillpasswd update this. */
9677     __pwdcache.pw_uid =  uic.uic$l_uic;
9678     __pwdcache.pw_gid =  uic.uic$v_group;
9679
9680     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9681     return &__pwdcache;
9682
9683 }  /* end of my_getpwuid() */
9684 /*}}}*/
9685
9686 /*
9687  * Get information for next user.
9688 */
9689 /*{{{struct passwd *my_getpwent()*/
9690 struct passwd *Perl_my_getpwent(pTHX)
9691 {
9692     return (my_getpwuid((unsigned int) -1));
9693 }
9694 /*}}}*/
9695
9696 /*
9697  * Finish searching rights database for users.
9698 */
9699 /*{{{void my_endpwent()*/
9700 void Perl_my_endpwent(pTHX)
9701 {
9702     if (contxt) {
9703       _ckvmssts(sys$finish_rdb(&contxt));
9704       contxt= 0;
9705     }
9706 }
9707 /*}}}*/
9708
9709 #ifdef HOMEGROWN_POSIX_SIGNALS
9710   /* Signal handling routines, pulled into the core from POSIX.xs.
9711    *
9712    * We need these for threads, so they've been rolled into the core,
9713    * rather than left in POSIX.xs.
9714    *
9715    * (DRS, Oct 23, 1997)
9716    */
9717
9718   /* sigset_t is atomic under VMS, so these routines are easy */
9719 /*{{{int my_sigemptyset(sigset_t *) */
9720 int my_sigemptyset(sigset_t *set) {
9721     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9722     *set = 0; return 0;
9723 }
9724 /*}}}*/
9725
9726
9727 /*{{{int my_sigfillset(sigset_t *)*/
9728 int my_sigfillset(sigset_t *set) {
9729     int i;
9730     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9731     for (i = 0; i < NSIG; i++) *set |= (1 << i);
9732     return 0;
9733 }
9734 /*}}}*/
9735
9736
9737 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
9738 int my_sigaddset(sigset_t *set, int sig) {
9739     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9740     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9741     *set |= (1 << (sig - 1));
9742     return 0;
9743 }
9744 /*}}}*/
9745
9746
9747 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
9748 int my_sigdelset(sigset_t *set, int sig) {
9749     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9750     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9751     *set &= ~(1 << (sig - 1));
9752     return 0;
9753 }
9754 /*}}}*/
9755
9756
9757 /*{{{int my_sigismember(sigset_t *set, int sig)*/
9758 int my_sigismember(sigset_t *set, int sig) {
9759     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9760     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9761     return *set & (1 << (sig - 1));
9762 }
9763 /*}}}*/
9764
9765
9766 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
9767 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
9768     sigset_t tempmask;
9769
9770     /* If set and oset are both null, then things are badly wrong. Bail out. */
9771     if ((oset == NULL) && (set == NULL)) {
9772       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
9773       return -1;
9774     }
9775
9776     /* If set's null, then we're just handling a fetch. */
9777     if (set == NULL) {
9778         tempmask = sigblock(0);
9779     }
9780     else {
9781       switch (how) {
9782       case SIG_SETMASK:
9783         tempmask = sigsetmask(*set);
9784         break;
9785       case SIG_BLOCK:
9786         tempmask = sigblock(*set);
9787         break;
9788       case SIG_UNBLOCK:
9789         tempmask = sigblock(0);
9790         sigsetmask(*oset & ~tempmask);
9791         break;
9792       default:
9793         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9794         return -1;
9795       }
9796     }
9797
9798     /* Did they pass us an oset? If so, stick our holding mask into it */
9799     if (oset)
9800       *oset = tempmask;
9801
9802     return 0;
9803 }
9804 /*}}}*/
9805 #endif  /* HOMEGROWN_POSIX_SIGNALS */
9806
9807
9808 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
9809  * my_utime(), and flex_stat(), all of which operate on UTC unless
9810  * VMSISH_TIMES is true.
9811  */
9812 /* method used to handle UTC conversions:
9813  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
9814  */
9815 static int gmtime_emulation_type;
9816 /* number of secs to add to UTC POSIX-style time to get local time */
9817 static long int utc_offset_secs;
9818
9819 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
9820  * in vmsish.h.  #undef them here so we can call the CRTL routines
9821  * directly.
9822  */
9823 #undef gmtime
9824 #undef localtime
9825 #undef time
9826
9827
9828 /*
9829  * DEC C previous to 6.0 corrupts the behavior of the /prefix
9830  * qualifier with the extern prefix pragma.  This provisional
9831  * hack circumvents this prefix pragma problem in previous
9832  * precompilers.
9833  */
9834 #if defined(__VMS_VER) && __VMS_VER >= 70000000
9835 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
9836 #    pragma __extern_prefix save
9837 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
9838 #    define gmtime decc$__utctz_gmtime
9839 #    define localtime decc$__utctz_localtime
9840 #    define time decc$__utc_time
9841 #    pragma __extern_prefix restore
9842
9843      struct tm *gmtime(), *localtime();
9844
9845 #  endif
9846 #endif
9847
9848
9849 static time_t toutc_dst(time_t loc) {
9850   struct tm *rsltmp;
9851
9852   if ((rsltmp = localtime(&loc)) == NULL) return -1;
9853   loc -= utc_offset_secs;
9854   if (rsltmp->tm_isdst) loc -= 3600;
9855   return loc;
9856 }
9857 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9858        ((gmtime_emulation_type || my_time(NULL)), \
9859        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
9860        ((secs) - utc_offset_secs))))
9861
9862 static time_t toloc_dst(time_t utc) {
9863   struct tm *rsltmp;
9864
9865   utc += utc_offset_secs;
9866   if ((rsltmp = localtime(&utc)) == NULL) return -1;
9867   if (rsltmp->tm_isdst) utc += 3600;
9868   return utc;
9869 }
9870 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9871        ((gmtime_emulation_type || my_time(NULL)), \
9872        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
9873        ((secs) + utc_offset_secs))))
9874
9875 #ifndef RTL_USES_UTC
9876 /*
9877
9878     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
9879         DST starts on 1st sun of april      at 02:00  std time
9880             ends on last sun of october     at 02:00  dst time
9881     see the UCX management command reference, SET CONFIG TIMEZONE
9882     for formatting info.
9883
9884     No, it's not as general as it should be, but then again, NOTHING
9885     will handle UK times in a sensible way.
9886 */
9887
9888
9889 /*
9890     parse the DST start/end info:
9891     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
9892 */
9893
9894 static char *
9895 tz_parse_startend(char *s, struct tm *w, int *past)
9896 {
9897     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
9898     int ly, dozjd, d, m, n, hour, min, sec, j, k;
9899     time_t g;
9900
9901     if (!s)    return 0;
9902     if (!w) return 0;
9903     if (!past) return 0;
9904
9905     ly = 0;
9906     if (w->tm_year % 4        == 0) ly = 1;
9907     if (w->tm_year % 100      == 0) ly = 0;
9908     if (w->tm_year+1900 % 400 == 0) ly = 1;
9909     if (ly) dinm[1]++;
9910
9911     dozjd = isdigit(*s);
9912     if (*s == 'J' || *s == 'j' || dozjd) {
9913         if (!dozjd && !isdigit(*++s)) return 0;
9914         d = *s++ - '0';
9915         if (isdigit(*s)) {
9916             d = d*10 + *s++ - '0';
9917             if (isdigit(*s)) {
9918                 d = d*10 + *s++ - '0';
9919             }
9920         }
9921         if (d == 0) return 0;
9922         if (d > 366) return 0;
9923         d--;
9924         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
9925         g = d * 86400;
9926         dozjd = 1;
9927     } else if (*s == 'M' || *s == 'm') {
9928         if (!isdigit(*++s)) return 0;
9929         m = *s++ - '0';
9930         if (isdigit(*s)) m = 10*m + *s++ - '0';
9931         if (*s != '.') return 0;
9932         if (!isdigit(*++s)) return 0;
9933         n = *s++ - '0';
9934         if (n < 1 || n > 5) return 0;
9935         if (*s != '.') return 0;
9936         if (!isdigit(*++s)) return 0;
9937         d = *s++ - '0';
9938         if (d > 6) return 0;
9939     }
9940
9941     if (*s == '/') {
9942         if (!isdigit(*++s)) return 0;
9943         hour = *s++ - '0';
9944         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
9945         if (*s == ':') {
9946             if (!isdigit(*++s)) return 0;
9947             min = *s++ - '0';
9948             if (isdigit(*s)) min = 10*min + *s++ - '0';
9949             if (*s == ':') {
9950                 if (!isdigit(*++s)) return 0;
9951                 sec = *s++ - '0';
9952                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
9953             }
9954         }
9955     } else {
9956         hour = 2;
9957         min = 0;
9958         sec = 0;
9959     }
9960
9961     if (dozjd) {
9962         if (w->tm_yday < d) goto before;
9963         if (w->tm_yday > d) goto after;
9964     } else {
9965         if (w->tm_mon+1 < m) goto before;
9966         if (w->tm_mon+1 > m) goto after;
9967
9968         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
9969         k = d - j; /* mday of first d */
9970         if (k <= 0) k += 7;
9971         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
9972         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
9973         if (w->tm_mday < k) goto before;
9974         if (w->tm_mday > k) goto after;
9975     }
9976
9977     if (w->tm_hour < hour) goto before;
9978     if (w->tm_hour > hour) goto after;
9979     if (w->tm_min  < min)  goto before;
9980     if (w->tm_min  > min)  goto after;
9981     if (w->tm_sec  < sec)  goto before;
9982     goto after;
9983
9984 before:
9985     *past = 0;
9986     return s;
9987 after:
9988     *past = 1;
9989     return s;
9990 }
9991
9992
9993
9994
9995 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
9996
9997 static char *
9998 tz_parse_offset(char *s, int *offset)
9999 {
10000     int hour = 0, min = 0, sec = 0;
10001     int neg = 0;
10002     if (!s) return 0;
10003     if (!offset) return 0;
10004
10005     if (*s == '-') {neg++; s++;}
10006     if (*s == '+') s++;
10007     if (!isdigit(*s)) return 0;
10008     hour = *s++ - '0';
10009     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10010     if (hour > 24) return 0;
10011     if (*s == ':') {
10012         if (!isdigit(*++s)) return 0;
10013         min = *s++ - '0';
10014         if (isdigit(*s)) min = min*10 + (*s++ - '0');
10015         if (min > 59) return 0;
10016         if (*s == ':') {
10017             if (!isdigit(*++s)) return 0;
10018             sec = *s++ - '0';
10019             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10020             if (sec > 59) return 0;
10021         }
10022     }
10023
10024     *offset = (hour*60+min)*60 + sec;
10025     if (neg) *offset = -*offset;
10026     return s;
10027 }
10028
10029 /*
10030     input time is w, whatever type of time the CRTL localtime() uses.
10031     sets dst, the zone, and the gmtoff (seconds)
10032
10033     caches the value of TZ and UCX$TZ env variables; note that
10034     my_setenv looks for these and sets a flag if they're changed
10035     for efficiency.
10036
10037     We have to watch out for the "australian" case (dst starts in
10038     october, ends in april)...flagged by "reverse" and checked by
10039     scanning through the months of the previous year.
10040
10041 */
10042
10043 static int
10044 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10045 {
10046     time_t when;
10047     struct tm *w2;
10048     char *s,*s2;
10049     char *dstzone, *tz, *s_start, *s_end;
10050     int std_off, dst_off, isdst;
10051     int y, dststart, dstend;
10052     static char envtz[1025];  /* longer than any logical, symbol, ... */
10053     static char ucxtz[1025];
10054     static char reversed = 0;
10055
10056     if (!w) return 0;
10057
10058     if (tz_updated) {
10059         tz_updated = 0;
10060         reversed = -1;  /* flag need to check  */
10061         envtz[0] = ucxtz[0] = '\0';
10062         tz = my_getenv("TZ",0);
10063         if (tz) strcpy(envtz, tz);
10064         tz = my_getenv("UCX$TZ",0);
10065         if (tz) strcpy(ucxtz, tz);
10066         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
10067     }
10068     tz = envtz;
10069     if (!*tz) tz = ucxtz;
10070
10071     s = tz;
10072     while (isalpha(*s)) s++;
10073     s = tz_parse_offset(s, &std_off);
10074     if (!s) return 0;
10075     if (!*s) {                  /* no DST, hurray we're done! */
10076         isdst = 0;
10077         goto done;
10078     }
10079
10080     dstzone = s;
10081     while (isalpha(*s)) s++;
10082     s2 = tz_parse_offset(s, &dst_off);
10083     if (s2) {
10084         s = s2;
10085     } else {
10086         dst_off = std_off - 3600;
10087     }
10088
10089     if (!*s) {      /* default dst start/end?? */
10090         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
10091             s = strchr(ucxtz,',');
10092         }
10093         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
10094     }
10095     if (*s != ',') return 0;
10096
10097     when = *w;
10098     when = _toutc(when);      /* convert to utc */
10099     when = when - std_off;    /* convert to pseudolocal time*/
10100
10101     w2 = localtime(&when);
10102     y = w2->tm_year;
10103     s_start = s+1;
10104     s = tz_parse_startend(s_start,w2,&dststart);
10105     if (!s) return 0;
10106     if (*s != ',') return 0;
10107
10108     when = *w;
10109     when = _toutc(when);      /* convert to utc */
10110     when = when - dst_off;    /* convert to pseudolocal time*/
10111     w2 = localtime(&when);
10112     if (w2->tm_year != y) {   /* spans a year, just check one time */
10113         when += dst_off - std_off;
10114         w2 = localtime(&when);
10115     }
10116     s_end = s+1;
10117     s = tz_parse_startend(s_end,w2,&dstend);
10118     if (!s) return 0;
10119
10120     if (reversed == -1) {  /* need to check if start later than end */
10121         int j, ds, de;
10122
10123         when = *w;
10124         if (when < 2*365*86400) {
10125             when += 2*365*86400;
10126         } else {
10127             when -= 365*86400;
10128         }
10129         w2 =localtime(&when);
10130         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
10131
10132         for (j = 0; j < 12; j++) {
10133             w2 =localtime(&when);
10134             tz_parse_startend(s_start,w2,&ds);
10135             tz_parse_startend(s_end,w2,&de);
10136             if (ds != de) break;
10137             when += 30*86400;
10138         }
10139         reversed = 0;
10140         if (de && !ds) reversed = 1;
10141     }
10142
10143     isdst = dststart && !dstend;
10144     if (reversed) isdst = dststart  || !dstend;
10145
10146 done:
10147     if (dst)    *dst = isdst;
10148     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10149     if (isdst)  tz = dstzone;
10150     if (zone) {
10151         while(isalpha(*tz))  *zone++ = *tz++;
10152         *zone = '\0';
10153     }
10154     return 1;
10155 }
10156
10157 #endif /* !RTL_USES_UTC */
10158
10159 /* my_time(), my_localtime(), my_gmtime()
10160  * By default traffic in UTC time values, using CRTL gmtime() or
10161  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10162  * Note: We need to use these functions even when the CRTL has working
10163  * UTC support, since they also handle C<use vmsish qw(times);>
10164  *
10165  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
10166  * Modified by Charles Bailey <bailey@newman.upenn.edu>
10167  */
10168
10169 /*{{{time_t my_time(time_t *timep)*/
10170 time_t Perl_my_time(pTHX_ time_t *timep)
10171 {
10172   time_t when;
10173   struct tm *tm_p;
10174
10175   if (gmtime_emulation_type == 0) {
10176     int dstnow;
10177     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
10178                               /* results of calls to gmtime() and localtime() */
10179                               /* for same &base */
10180
10181     gmtime_emulation_type++;
10182     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10183       char off[LNM$C_NAMLENGTH+1];;
10184
10185       gmtime_emulation_type++;
10186       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10187         gmtime_emulation_type++;
10188         utc_offset_secs = 0;
10189         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10190       }
10191       else { utc_offset_secs = atol(off); }
10192     }
10193     else { /* We've got a working gmtime() */
10194       struct tm gmt, local;
10195
10196       gmt = *tm_p;
10197       tm_p = localtime(&base);
10198       local = *tm_p;
10199       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
10200       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10201       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
10202       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
10203     }
10204   }
10205
10206   when = time(NULL);
10207 # ifdef VMSISH_TIME
10208 # ifdef RTL_USES_UTC
10209   if (VMSISH_TIME) when = _toloc(when);
10210 # else
10211   if (!VMSISH_TIME) when = _toutc(when);
10212 # endif
10213 # endif
10214   if (timep != NULL) *timep = when;
10215   return when;
10216
10217 }  /* end of my_time() */
10218 /*}}}*/
10219
10220
10221 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10222 struct tm *
10223 Perl_my_gmtime(pTHX_ const time_t *timep)
10224 {
10225   char *p;
10226   time_t when;
10227   struct tm *rsltmp;
10228
10229   if (timep == NULL) {
10230     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10231     return NULL;
10232   }
10233   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10234
10235   when = *timep;
10236 # ifdef VMSISH_TIME
10237   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10238 #  endif
10239 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
10240   return gmtime(&when);
10241 # else
10242   /* CRTL localtime() wants local time as input, so does no tz correction */
10243   rsltmp = localtime(&when);
10244   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
10245   return rsltmp;
10246 #endif
10247 }  /* end of my_gmtime() */
10248 /*}}}*/
10249
10250
10251 /*{{{struct tm *my_localtime(const time_t *timep)*/
10252 struct tm *
10253 Perl_my_localtime(pTHX_ const time_t *timep)
10254 {
10255   time_t when, whenutc;
10256   struct tm *rsltmp;
10257   int dst, offset;
10258
10259   if (timep == NULL) {
10260     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10261     return NULL;
10262   }
10263   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10264   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10265
10266   when = *timep;
10267 # ifdef RTL_USES_UTC
10268 # ifdef VMSISH_TIME
10269   if (VMSISH_TIME) when = _toutc(when);
10270 # endif
10271   /* CRTL localtime() wants UTC as input, does tz correction itself */
10272   return localtime(&when);
10273
10274 # else /* !RTL_USES_UTC */
10275   whenutc = when;
10276 # ifdef VMSISH_TIME
10277   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
10278   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
10279 # endif
10280   dst = -1;
10281 #ifndef RTL_USES_UTC
10282   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
10283       when = whenutc - offset;                   /* pseudolocal time*/
10284   }
10285 # endif
10286   /* CRTL localtime() wants local time as input, so does no tz correction */
10287   rsltmp = localtime(&when);
10288   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10289   return rsltmp;
10290 # endif
10291
10292 } /*  end of my_localtime() */
10293 /*}}}*/
10294
10295 /* Reset definitions for later calls */
10296 #define gmtime(t)    my_gmtime(t)
10297 #define localtime(t) my_localtime(t)
10298 #define time(t)      my_time(t)
10299
10300
10301 /* my_utime - update modification/access time of a file
10302  *
10303  * VMS 7.3 and later implementation
10304  * Only the UTC translation is home-grown. The rest is handled by the
10305  * CRTL utime(), which will take into account the relevant feature
10306  * logicals and ODS-5 volume characteristics for true access times.
10307  *
10308  * pre VMS 7.3 implementation:
10309  * The calling sequence is identical to POSIX utime(), but under
10310  * VMS with ODS-2, only the modification time is changed; ODS-2 does
10311  * not maintain access times.  Restrictions differ from the POSIX
10312  * definition in that the time can be changed as long as the
10313  * caller has permission to execute the necessary IO$_MODIFY $QIO;
10314  * no separate checks are made to insure that the caller is the
10315  * owner of the file or has special privs enabled.
10316  * Code here is based on Joe Meadows' FILE utility.
10317  *
10318  */
10319
10320 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10321  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
10322  * in 100 ns intervals.
10323  */
10324 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10325
10326 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10327 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10328 {
10329 #if __CRTL_VER >= 70300000
10330   struct utimbuf utc_utimes, *utc_utimesp;
10331
10332   if (utimes != NULL) {
10333     utc_utimes.actime = utimes->actime;
10334     utc_utimes.modtime = utimes->modtime;
10335 # ifdef VMSISH_TIME
10336     /* If input was local; convert to UTC for sys svc */
10337     if (VMSISH_TIME) {
10338       utc_utimes.actime = _toutc(utimes->actime);
10339       utc_utimes.modtime = _toutc(utimes->modtime);
10340     }
10341 # endif
10342     utc_utimesp = &utc_utimes;
10343   }
10344   else {
10345     utc_utimesp = NULL;
10346   }
10347
10348   return utime(file, utc_utimesp);
10349
10350 #else /* __CRTL_VER < 70300000 */
10351
10352   register int i;
10353   int sts;
10354   long int bintime[2], len = 2, lowbit, unixtime,
10355            secscale = 10000000; /* seconds --> 100 ns intervals */
10356   unsigned long int chan, iosb[2], retsts;
10357   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10358   struct FAB myfab = cc$rms_fab;
10359   struct NAM mynam = cc$rms_nam;
10360 #if defined (__DECC) && defined (__VAX)
10361   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10362    * at least through VMS V6.1, which causes a type-conversion warning.
10363    */
10364 #  pragma message save
10365 #  pragma message disable cvtdiftypes
10366 #endif
10367   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10368   struct fibdef myfib;
10369 #if defined (__DECC) && defined (__VAX)
10370   /* This should be right after the declaration of myatr, but due
10371    * to a bug in VAX DEC C, this takes effect a statement early.
10372    */
10373 #  pragma message restore
10374 #endif
10375   /* cast ok for read only parameter */
10376   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10377                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10378                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10379
10380   if (file == NULL || *file == '\0') {
10381     SETERRNO(ENOENT, LIB$_INVARG);
10382     return -1;
10383   }
10384
10385   /* Convert to VMS format ensuring that it will fit in 255 characters */
10386   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10387       SETERRNO(ENOENT, LIB$_INVARG);
10388       return -1;
10389   }
10390   if (utimes != NULL) {
10391     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
10392      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10393      * Since time_t is unsigned long int, and lib$emul takes a signed long int
10394      * as input, we force the sign bit to be clear by shifting unixtime right
10395      * one bit, then multiplying by an extra factor of 2 in lib$emul().
10396      */
10397     lowbit = (utimes->modtime & 1) ? secscale : 0;
10398     unixtime = (long int) utimes->modtime;
10399 #   ifdef VMSISH_TIME
10400     /* If input was UTC; convert to local for sys svc */
10401     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10402 #   endif
10403     unixtime >>= 1;  secscale <<= 1;
10404     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10405     if (!(retsts & 1)) {
10406       SETERRNO(EVMSERR, retsts);
10407       return -1;
10408     }
10409     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10410     if (!(retsts & 1)) {
10411       SETERRNO(EVMSERR, retsts);
10412       return -1;
10413     }
10414   }
10415   else {
10416     /* Just get the current time in VMS format directly */
10417     retsts = sys$gettim(bintime);
10418     if (!(retsts & 1)) {
10419       SETERRNO(EVMSERR, retsts);
10420       return -1;
10421     }
10422   }
10423
10424   myfab.fab$l_fna = vmsspec;
10425   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10426   myfab.fab$l_nam = &mynam;
10427   mynam.nam$l_esa = esa;
10428   mynam.nam$b_ess = (unsigned char) sizeof esa;
10429   mynam.nam$l_rsa = rsa;
10430   mynam.nam$b_rss = (unsigned char) sizeof rsa;
10431   if (decc_efs_case_preserve)
10432       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10433
10434   /* Look for the file to be affected, letting RMS parse the file
10435    * specification for us as well.  I have set errno using only
10436    * values documented in the utime() man page for VMS POSIX.
10437    */
10438   retsts = sys$parse(&myfab,0,0);
10439   if (!(retsts & 1)) {
10440     set_vaxc_errno(retsts);
10441     if      (retsts == RMS$_PRV) set_errno(EACCES);
10442     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10443     else                         set_errno(EVMSERR);
10444     return -1;
10445   }
10446   retsts = sys$search(&myfab,0,0);
10447   if (!(retsts & 1)) {
10448     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10449     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10450     set_vaxc_errno(retsts);
10451     if      (retsts == RMS$_PRV) set_errno(EACCES);
10452     else if (retsts == RMS$_FNF) set_errno(ENOENT);
10453     else                         set_errno(EVMSERR);
10454     return -1;
10455   }
10456
10457   devdsc.dsc$w_length = mynam.nam$b_dev;
10458   /* cast ok for read only parameter */
10459   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10460
10461   retsts = sys$assign(&devdsc,&chan,0,0);
10462   if (!(retsts & 1)) {
10463     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10464     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10465     set_vaxc_errno(retsts);
10466     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
10467     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
10468     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
10469     else                               set_errno(EVMSERR);
10470     return -1;
10471   }
10472
10473   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10474   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10475
10476   memset((void *) &myfib, 0, sizeof myfib);
10477 #if defined(__DECC) || defined(__DECCXX)
10478   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10479   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10480   /* This prevents the revision time of the file being reset to the current
10481    * time as a result of our IO$_MODIFY $QIO. */
10482   myfib.fib$l_acctl = FIB$M_NORECORD;
10483 #else
10484   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10485   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10486   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10487 #endif
10488   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10489   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10490   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10491   _ckvmssts(sys$dassgn(chan));
10492   if (retsts & 1) retsts = iosb[0];
10493   if (!(retsts & 1)) {
10494     set_vaxc_errno(retsts);
10495     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10496     else                      set_errno(EVMSERR);
10497     return -1;
10498   }
10499
10500   return 0;
10501
10502 #endif /* #if __CRTL_VER >= 70300000 */
10503
10504 }  /* end of my_utime() */
10505 /*}}}*/
10506
10507 /*
10508  * flex_stat, flex_lstat, flex_fstat
10509  * basic stat, but gets it right when asked to stat
10510  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10511  */
10512
10513 #ifndef _USE_STD_STAT
10514 /* encode_dev packs a VMS device name string into an integer to allow
10515  * simple comparisons. This can be used, for example, to check whether two
10516  * files are located on the same device, by comparing their encoded device
10517  * names. Even a string comparison would not do, because stat() reuses the
10518  * device name buffer for each call; so without encode_dev, it would be
10519  * necessary to save the buffer and use strcmp (this would mean a number of
10520  * changes to the standard Perl code, to say nothing of what a Perl script
10521  * would have to do.
10522  *
10523  * The device lock id, if it exists, should be unique (unless perhaps compared
10524  * with lock ids transferred from other nodes). We have a lock id if the disk is
10525  * mounted cluster-wide, which is when we tend to get long (host-qualified)
10526  * device names. Thus we use the lock id in preference, and only if that isn't
10527  * available, do we try to pack the device name into an integer (flagged by
10528  * the sign bit (LOCKID_MASK) being set).
10529  *
10530  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10531  * name and its encoded form, but it seems very unlikely that we will find
10532  * two files on different disks that share the same encoded device names,
10533  * and even more remote that they will share the same file id (if the test
10534  * is to check for the same file).
10535  *
10536  * A better method might be to use sys$device_scan on the first call, and to
10537  * search for the device, returning an index into the cached array.
10538  * The number returned would be more intelligible.
10539  * This is probably not worth it, and anyway would take quite a bit longer
10540  * on the first call.
10541  */
10542 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
10543 static mydev_t encode_dev (pTHX_ const char *dev)
10544 {
10545   int i;
10546   unsigned long int f;
10547   mydev_t enc;
10548   char c;
10549   const char *q;
10550
10551   if (!dev || !dev[0]) return 0;
10552
10553 #if LOCKID_MASK
10554   {
10555     struct dsc$descriptor_s dev_desc;
10556     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10557
10558     /* For cluster-mounted disks, the disk lock identifier is unique, so we
10559        can try that first. */
10560     dev_desc.dsc$w_length =  strlen (dev);
10561     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
10562     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
10563     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
10564     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10565     if (!$VMS_STATUS_SUCCESS(status)) {
10566       switch (status) {
10567         case SS$_NOSUCHDEV:
10568           SETERRNO(ENODEV, status);
10569           return 0;
10570         default:
10571           _ckvmssts(status);
10572       }
10573     }
10574     if (lockid) return (lockid & ~LOCKID_MASK);
10575   }
10576 #endif
10577
10578   /* Otherwise we try to encode the device name */
10579   enc = 0;
10580   f = 1;
10581   i = 0;
10582   for (q = dev + strlen(dev); q--; q >= dev) {
10583     if (*q == ':')
10584         break;
10585     if (isdigit (*q))
10586       c= (*q) - '0';
10587     else if (isalpha (toupper (*q)))
10588       c= toupper (*q) - 'A' + (char)10;
10589     else
10590       continue; /* Skip '$'s */
10591     i++;
10592     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
10593     if (i>1) f *= 36;
10594     enc += f * (unsigned long int) c;
10595   }
10596   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
10597
10598 }  /* end of encode_dev() */
10599 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10600         device_no = encode_dev(aTHX_ devname)
10601 #else
10602 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10603         device_no = new_dev_no
10604 #endif
10605
10606 static int
10607 is_null_device(name)
10608     const char *name;
10609 {
10610   if (decc_bug_devnull != 0) {
10611     if (strncmp("/dev/null", name, 9) == 0)
10612       return 1;
10613   }
10614     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10615        The underscore prefix, controller letter, and unit number are
10616        independently optional; for our purposes, the colon punctuation
10617        is not.  The colon can be trailed by optional directory and/or
10618        filename, but two consecutive colons indicates a nodename rather
10619        than a device.  [pr]  */
10620   if (*name == '_') ++name;
10621   if (tolower(*name++) != 'n') return 0;
10622   if (tolower(*name++) != 'l') return 0;
10623   if (tolower(*name) == 'a') ++name;
10624   if (*name == '0') ++name;
10625   return (*name++ == ':') && (*name != ':');
10626 }
10627
10628
10629 static I32
10630 Perl_cando_by_name_int
10631    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10632 {
10633   static char usrname[L_cuserid];
10634   static struct dsc$descriptor_s usrdsc =
10635          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10636   char vmsname[NAM$C_MAXRSS+1];
10637   char *fileified;
10638   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10639   unsigned short int retlen, trnlnm_iter_count;
10640   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10641   union prvdef curprv;
10642   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10643          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10644          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10645   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10646          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10647          {0,0,0,0}};
10648   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10649          {0,0,0,0}};
10650   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10651
10652   if (!fname || !*fname) return FALSE;
10653   /* Make sure we expand logical names, since sys$check_access doesn't */
10654
10655   fileified = NULL;
10656   if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
10657     fileified = PerlMem_malloc(VMS_MAXRSS);
10658     if (!strpbrk(fname,"/]>:")) {
10659       strcpy(fileified,fname);
10660       trnlnm_iter_count = 0;
10661       while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10662         trnlnm_iter_count++;
10663         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10664       }
10665       fname = fileified;
10666     }
10667     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10668       PerlMem_free(fileified);
10669       return FALSE;
10670     }
10671     retlen = namdsc.dsc$w_length = strlen(vmsname);
10672     namdsc.dsc$a_pointer = vmsname;
10673     if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10674       vmsname[retlen-1] == ':') {
10675       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) return FALSE;
10676       namdsc.dsc$w_length = strlen(fileified);
10677       namdsc.dsc$a_pointer = fileified;
10678     }
10679   }
10680   else {
10681     retlen = namdsc.dsc$w_length = strlen(fname);
10682     namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
10683   }
10684
10685   switch (bit) {
10686     case S_IXUSR: case S_IXGRP: case S_IXOTH:
10687       access = ARM$M_EXECUTE;
10688       flags = CHP$M_READ;
10689       break;
10690     case S_IRUSR: case S_IRGRP: case S_IROTH:
10691       access = ARM$M_READ;
10692       flags = CHP$M_READ | CHP$M_USEREADALL;
10693       break;
10694     case S_IWUSR: case S_IWGRP: case S_IWOTH:
10695       access = ARM$M_WRITE;
10696       flags = CHP$M_READ | CHP$M_WRITE;
10697       break;
10698     case S_IDUSR: case S_IDGRP: case S_IDOTH:
10699       access = ARM$M_DELETE;
10700       flags = CHP$M_READ | CHP$M_WRITE;
10701       break;
10702     default:
10703       if (fileified != NULL)
10704         PerlMem_free(fileified);
10705       return FALSE;
10706   }
10707
10708   /* Before we call $check_access, create a user profile with the current
10709    * process privs since otherwise it just uses the default privs from the
10710    * UAF and might give false positives or negatives.  This only works on
10711    * VMS versions v6.0 and later since that's when sys$create_user_profile
10712    * became available.
10713    */
10714
10715   /* get current process privs and username */
10716   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
10717   _ckvmssts(iosb[0]);
10718
10719 #if defined(__VMS_VER) && __VMS_VER >= 60000000
10720
10721   /* find out the space required for the profile */
10722   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
10723                                     &usrprodsc.dsc$w_length,0));
10724
10725   /* allocate space for the profile and get it filled in */
10726   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
10727   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10728   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
10729                                     &usrprodsc.dsc$w_length,0));
10730
10731   /* use the profile to check access to the file; free profile & analyze results */
10732   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
10733   PerlMem_free(usrprodsc.dsc$a_pointer);
10734   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
10735
10736 #else
10737
10738   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
10739
10740 #endif
10741
10742   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
10743       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
10744       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
10745     set_vaxc_errno(retsts);
10746     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10747     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
10748     else set_errno(ENOENT);
10749     if (fileified != NULL)
10750       PerlMem_free(fileified);
10751     return FALSE;
10752   }
10753   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
10754     if (fileified != NULL)
10755       PerlMem_free(fileified);
10756     return TRUE;
10757   }
10758   _ckvmssts(retsts);
10759
10760   if (fileified != NULL)
10761     PerlMem_free(fileified);
10762   return FALSE;  /* Should never get here */
10763
10764 }
10765
10766 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
10767 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
10768  * subset of the applicable information.
10769  */
10770 bool
10771 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
10772 {
10773   return cando_by_name_int
10774         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
10775 }  /* end of cando() */
10776 /*}}}*/
10777
10778
10779 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
10780 I32
10781 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
10782 {
10783    return cando_by_name_int(bit, effective, fname, 0);
10784
10785 }  /* end of cando_by_name() */
10786 /*}}}*/
10787
10788
10789 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
10790 int
10791 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
10792 {
10793   if (!fstat(fd,(stat_t *) statbufp)) {
10794     char *cptr;
10795     char *vms_filename;
10796     vms_filename = PerlMem_malloc(VMS_MAXRSS);
10797     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
10798
10799     /* Save name for cando by name in VMS format */
10800     cptr = getname(fd, vms_filename, 1);
10801
10802     /* This should not happen, but just in case */
10803     if (cptr == NULL) {
10804         statbufp->st_devnam[0] = 0;
10805     }
10806     else {
10807         /* Make sure that the saved name fits in 255 characters */
10808         cptr = do_rmsexpand
10809                        (vms_filename,
10810                         statbufp->st_devnam,
10811                         0,
10812                         NULL,
10813                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
10814                         NULL,
10815                         NULL);
10816         if (cptr == NULL)
10817             statbufp->st_devnam[0] = 0;
10818     }
10819     PerlMem_free(vms_filename);
10820
10821     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10822     VMS_DEVICE_ENCODE
10823         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10824
10825 #   ifdef RTL_USES_UTC
10826 #   ifdef VMSISH_TIME
10827     if (VMSISH_TIME) {
10828       statbufp->st_mtime = _toloc(statbufp->st_mtime);
10829       statbufp->st_atime = _toloc(statbufp->st_atime);
10830       statbufp->st_ctime = _toloc(statbufp->st_ctime);
10831     }
10832 #   endif
10833 #   else
10834 #   ifdef VMSISH_TIME
10835     if (!VMSISH_TIME) { /* Return UTC instead of local time */
10836 #   else
10837     if (1) {
10838 #   endif
10839       statbufp->st_mtime = _toutc(statbufp->st_mtime);
10840       statbufp->st_atime = _toutc(statbufp->st_atime);
10841       statbufp->st_ctime = _toutc(statbufp->st_ctime);
10842     }
10843 #endif
10844     return 0;
10845   }
10846   return -1;
10847
10848 }  /* end of flex_fstat() */
10849 /*}}}*/
10850
10851 #if !defined(__VAX) && __CRTL_VER >= 80200000
10852 #ifdef lstat
10853 #undef lstat
10854 #endif
10855 #else
10856 #ifdef lstat
10857 #undef lstat
10858 #endif
10859 #define lstat(_x, _y) stat(_x, _y)
10860 #endif
10861
10862 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
10863
10864 static int
10865 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
10866 {
10867     char fileified[VMS_MAXRSS];
10868     char temp_fspec[VMS_MAXRSS];
10869     char *save_spec;
10870     int retval = -1;
10871     int saved_errno, saved_vaxc_errno;
10872
10873     if (!fspec) return retval;
10874     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
10875     strcpy(temp_fspec, fspec);
10876
10877     if (decc_bug_devnull != 0) {
10878       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
10879         memset(statbufp,0,sizeof *statbufp);
10880         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
10881         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
10882         statbufp->st_uid = 0x00010001;
10883         statbufp->st_gid = 0x0001;
10884         time((time_t *)&statbufp->st_mtime);
10885         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
10886         return 0;
10887       }
10888     }
10889
10890     /* Try for a directory name first.  If fspec contains a filename without
10891      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
10892      * and sea:[wine.dark]water. exist, we prefer the directory here.
10893      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
10894      * not sea:[wine.dark]., if the latter exists.  If the intended target is
10895      * the file with null type, specify this by calling flex_stat() with
10896      * a '.' at the end of fspec.
10897      *
10898      * If we are in Posix filespec mode, accept the filename as is.
10899      */
10900 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10901   if (decc_posix_compliant_pathnames == 0) {
10902 #endif
10903     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
10904       if (lstat_flag == 0)
10905         retval = stat(fileified,(stat_t *) statbufp);
10906       else
10907         retval = lstat(fileified,(stat_t *) statbufp);
10908       save_spec = fileified;
10909     }
10910     if (retval) {
10911       if (lstat_flag == 0)
10912         retval = stat(temp_fspec,(stat_t *) statbufp);
10913       else
10914         retval = lstat(temp_fspec,(stat_t *) statbufp);
10915       save_spec = temp_fspec;
10916     }
10917 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10918   } else {
10919     if (lstat_flag == 0)
10920       retval = stat(temp_fspec,(stat_t *) statbufp);
10921     else
10922       retval = lstat(temp_fspec,(stat_t *) statbufp);
10923       save_spec = temp_fspec;
10924   }
10925 #endif
10926     if (!retval) {
10927     char * cptr;
10928       cptr = do_rmsexpand
10929        (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
10930       if (cptr == NULL)
10931         statbufp->st_devnam[0] = 0;
10932
10933       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10934       VMS_DEVICE_ENCODE
10935         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10936 #     ifdef RTL_USES_UTC
10937 #     ifdef VMSISH_TIME
10938       if (VMSISH_TIME) {
10939         statbufp->st_mtime = _toloc(statbufp->st_mtime);
10940         statbufp->st_atime = _toloc(statbufp->st_atime);
10941         statbufp->st_ctime = _toloc(statbufp->st_ctime);
10942       }
10943 #     endif
10944 #     else
10945 #     ifdef VMSISH_TIME
10946       if (!VMSISH_TIME) { /* Return UTC instead of local time */
10947 #     else
10948       if (1) {
10949 #     endif
10950         statbufp->st_mtime = _toutc(statbufp->st_mtime);
10951         statbufp->st_atime = _toutc(statbufp->st_atime);
10952         statbufp->st_ctime = _toutc(statbufp->st_ctime);
10953       }
10954 #     endif
10955     }
10956     /* If we were successful, leave errno where we found it */
10957     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
10958     return retval;
10959
10960 }  /* end of flex_stat_int() */
10961
10962
10963 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
10964 int
10965 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
10966 {
10967    return flex_stat_int(fspec, statbufp, 0);
10968 }
10969 /*}}}*/
10970
10971 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
10972 int
10973 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
10974 {
10975    return flex_stat_int(fspec, statbufp, 1);
10976 }
10977 /*}}}*/
10978
10979
10980 /*{{{char *my_getlogin()*/
10981 /* VMS cuserid == Unix getlogin, except calling sequence */
10982 char *
10983 my_getlogin(void)
10984 {
10985     static char user[L_cuserid];
10986     return cuserid(user);
10987 }
10988 /*}}}*/
10989
10990
10991 /*  rmscopy - copy a file using VMS RMS routines
10992  *
10993  *  Copies contents and attributes of spec_in to spec_out, except owner
10994  *  and protection information.  Name and type of spec_in are used as
10995  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
10996  *  should try to propagate timestamps from the input file to the output file.
10997  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
10998  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
10999  *  propagated to the output file at creation iff the output file specification
11000  *  did not contain an explicit name or type, and the revision date is always
11001  *  updated at the end of the copy operation.  If it is greater than 0, then
11002  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11003  *  other than the revision date should be propagated, and bit 1 indicates
11004  *  that the revision date should be propagated.
11005  *
11006  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11007  *
11008  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11009  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
11010  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
11011  * as part of the Perl standard distribution under the terms of the
11012  * GNU General Public License or the Perl Artistic License.  Copies
11013  * of each may be found in the Perl standard distribution.
11014  */ /* FIXME */
11015 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11016 int
11017 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11018 {
11019     char *vmsin, * vmsout, *esa, *esa_out,
11020          *rsa, *ubf;
11021     unsigned long int i, sts, sts2;
11022     int dna_len;
11023     struct FAB fab_in, fab_out;
11024     struct RAB rab_in, rab_out;
11025     rms_setup_nam(nam);
11026     rms_setup_nam(nam_out);
11027     struct XABDAT xabdat;
11028     struct XABFHC xabfhc;
11029     struct XABRDT xabrdt;
11030     struct XABSUM xabsum;
11031
11032     vmsin = PerlMem_malloc(VMS_MAXRSS);
11033     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11034     vmsout = PerlMem_malloc(VMS_MAXRSS);
11035     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11036     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11037         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11038       PerlMem_free(vmsin);
11039       PerlMem_free(vmsout);
11040       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11041       return 0;
11042     }
11043
11044     esa = PerlMem_malloc(VMS_MAXRSS);
11045     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11046     fab_in = cc$rms_fab;
11047     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11048     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11049     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11050     fab_in.fab$l_fop = FAB$M_SQO;
11051     rms_bind_fab_nam(fab_in, nam);
11052     fab_in.fab$l_xab = (void *) &xabdat;
11053
11054     rsa = PerlMem_malloc(VMS_MAXRSS);
11055     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11056     rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11057     rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11058     rms_nam_esl(nam) = 0;
11059     rms_nam_rsl(nam) = 0;
11060     rms_nam_esll(nam) = 0;
11061     rms_nam_rsll(nam) = 0;
11062 #ifdef NAM$M_NO_SHORT_UPCASE
11063     if (decc_efs_case_preserve)
11064         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11065 #endif
11066
11067     xabdat = cc$rms_xabdat;        /* To get creation date */
11068     xabdat.xab$l_nxt = (void *) &xabfhc;
11069
11070     xabfhc = cc$rms_xabfhc;        /* To get record length */
11071     xabfhc.xab$l_nxt = (void *) &xabsum;
11072
11073     xabsum = cc$rms_xabsum;        /* To get key and area information */
11074
11075     if (!((sts = sys$open(&fab_in)) & 1)) {
11076       PerlMem_free(vmsin);
11077       PerlMem_free(vmsout);
11078       PerlMem_free(esa);
11079       PerlMem_free(rsa);
11080       set_vaxc_errno(sts);
11081       switch (sts) {
11082         case RMS$_FNF: case RMS$_DNF:
11083           set_errno(ENOENT); break;
11084         case RMS$_DIR:
11085           set_errno(ENOTDIR); break;
11086         case RMS$_DEV:
11087           set_errno(ENODEV); break;
11088         case RMS$_SYN:
11089           set_errno(EINVAL); break;
11090         case RMS$_PRV:
11091           set_errno(EACCES); break;
11092         default:
11093           set_errno(EVMSERR);
11094       }
11095       return 0;
11096     }
11097
11098     nam_out = nam;
11099     fab_out = fab_in;
11100     fab_out.fab$w_ifi = 0;
11101     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11102     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11103     fab_out.fab$l_fop = FAB$M_SQO;
11104     rms_bind_fab_nam(fab_out, nam_out);
11105     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11106     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11107     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11108     esa_out = PerlMem_malloc(VMS_MAXRSS);
11109     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11110     rms_set_rsa(nam_out, NULL, 0);
11111     rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11112
11113     if (preserve_dates == 0) {  /* Act like DCL COPY */
11114       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11115       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
11116       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11117         PerlMem_free(vmsin);
11118         PerlMem_free(vmsout);
11119         PerlMem_free(esa);
11120         PerlMem_free(rsa);
11121         PerlMem_free(esa_out);
11122         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11123         set_vaxc_errno(sts);
11124         return 0;
11125       }
11126       fab_out.fab$l_xab = (void *) &xabdat;
11127       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11128         preserve_dates = 1;
11129     }
11130     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
11131       preserve_dates =0;      /* bitmask from this point forward   */
11132
11133     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11134     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11135       PerlMem_free(vmsin);
11136       PerlMem_free(vmsout);
11137       PerlMem_free(esa);
11138       PerlMem_free(rsa);
11139       PerlMem_free(esa_out);
11140       set_vaxc_errno(sts);
11141       switch (sts) {
11142         case RMS$_DNF:
11143           set_errno(ENOENT); break;
11144         case RMS$_DIR:
11145           set_errno(ENOTDIR); break;
11146         case RMS$_DEV:
11147           set_errno(ENODEV); break;
11148         case RMS$_SYN:
11149           set_errno(EINVAL); break;
11150         case RMS$_PRV:
11151           set_errno(EACCES); break;
11152         default:
11153           set_errno(EVMSERR);
11154       }
11155       return 0;
11156     }
11157     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
11158     if (preserve_dates & 2) {
11159       /* sys$close() will process xabrdt, not xabdat */
11160       xabrdt = cc$rms_xabrdt;
11161 #ifndef __GNUC__
11162       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11163 #else
11164       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11165        * is unsigned long[2], while DECC & VAXC use a struct */
11166       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11167 #endif
11168       fab_out.fab$l_xab = (void *) &xabrdt;
11169     }
11170
11171     ubf = PerlMem_malloc(32256);
11172     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11173     rab_in = cc$rms_rab;
11174     rab_in.rab$l_fab = &fab_in;
11175     rab_in.rab$l_rop = RAB$M_BIO;
11176     rab_in.rab$l_ubf = ubf;
11177     rab_in.rab$w_usz = 32256;
11178     if (!((sts = sys$connect(&rab_in)) & 1)) {
11179       sys$close(&fab_in); sys$close(&fab_out);
11180       PerlMem_free(vmsin);
11181       PerlMem_free(vmsout);
11182       PerlMem_free(esa);
11183       PerlMem_free(ubf);
11184       PerlMem_free(rsa);
11185       PerlMem_free(esa_out);
11186       set_errno(EVMSERR); set_vaxc_errno(sts);
11187       return 0;
11188     }
11189
11190     rab_out = cc$rms_rab;
11191     rab_out.rab$l_fab = &fab_out;
11192     rab_out.rab$l_rbf = ubf;
11193     if (!((sts = sys$connect(&rab_out)) & 1)) {
11194       sys$close(&fab_in); sys$close(&fab_out);
11195       PerlMem_free(vmsin);
11196       PerlMem_free(vmsout);
11197       PerlMem_free(esa);
11198       PerlMem_free(ubf);
11199       PerlMem_free(rsa);
11200       PerlMem_free(esa_out);
11201       set_errno(EVMSERR); set_vaxc_errno(sts);
11202       return 0;
11203     }
11204
11205     while ((sts = sys$read(&rab_in))) {  /* always true  */
11206       if (sts == RMS$_EOF) break;
11207       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11208       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11209         sys$close(&fab_in); sys$close(&fab_out);
11210         PerlMem_free(vmsin);
11211         PerlMem_free(vmsout);
11212         PerlMem_free(esa);
11213         PerlMem_free(ubf);
11214         PerlMem_free(rsa);
11215         PerlMem_free(esa_out);
11216         set_errno(EVMSERR); set_vaxc_errno(sts);
11217         return 0;
11218       }
11219     }
11220
11221
11222     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
11223     sys$close(&fab_in);  sys$close(&fab_out);
11224     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11225     if (!(sts & 1)) {
11226       PerlMem_free(vmsin);
11227       PerlMem_free(vmsout);
11228       PerlMem_free(esa);
11229       PerlMem_free(ubf);
11230       PerlMem_free(rsa);
11231       PerlMem_free(esa_out);
11232       set_errno(EVMSERR); set_vaxc_errno(sts);
11233       return 0;
11234     }
11235
11236     PerlMem_free(vmsin);
11237     PerlMem_free(vmsout);
11238     PerlMem_free(esa);
11239     PerlMem_free(ubf);
11240     PerlMem_free(rsa);
11241     PerlMem_free(esa_out);
11242     return 1;
11243
11244 }  /* end of rmscopy() */
11245 /*}}}*/
11246
11247
11248 /***  The following glue provides 'hooks' to make some of the routines
11249  * from this file available from Perl.  These routines are sufficiently
11250  * basic, and are required sufficiently early in the build process,
11251  * that's it's nice to have them available to miniperl as well as the
11252  * full Perl, so they're set up here instead of in an extension.  The
11253  * Perl code which handles importation of these names into a given
11254  * package lives in [.VMS]Filespec.pm in @INC.
11255  */
11256
11257 void
11258 rmsexpand_fromperl(pTHX_ CV *cv)
11259 {
11260   dXSARGS;
11261   char *fspec, *defspec = NULL, *rslt;
11262   STRLEN n_a;
11263   int fs_utf8, dfs_utf8;
11264
11265   fs_utf8 = 0;
11266   dfs_utf8 = 0;
11267   if (!items || items > 2)
11268     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11269   fspec = SvPV(ST(0),n_a);
11270   fs_utf8 = SvUTF8(ST(0));
11271   if (!fspec || !*fspec) XSRETURN_UNDEF;
11272   if (items == 2) {
11273     defspec = SvPV(ST(1),n_a);
11274     dfs_utf8 = SvUTF8(ST(1));
11275   }
11276   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11277   ST(0) = sv_newmortal();
11278   if (rslt != NULL) {
11279     sv_usepvn(ST(0),rslt,strlen(rslt));
11280     if (fs_utf8) {
11281         SvUTF8_on(ST(0));
11282     }
11283   }
11284   XSRETURN(1);
11285 }
11286
11287 void
11288 vmsify_fromperl(pTHX_ CV *cv)
11289 {
11290   dXSARGS;
11291   char *vmsified;
11292   STRLEN n_a;
11293   int utf8_fl;
11294
11295   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11296   utf8_fl = SvUTF8(ST(0));
11297   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11298   ST(0) = sv_newmortal();
11299   if (vmsified != NULL) {
11300     sv_usepvn(ST(0),vmsified,strlen(vmsified));
11301     if (utf8_fl) {
11302         SvUTF8_on(ST(0));
11303     }
11304   }
11305   XSRETURN(1);
11306 }
11307
11308 void
11309 unixify_fromperl(pTHX_ CV *cv)
11310 {
11311   dXSARGS;
11312   char *unixified;
11313   STRLEN n_a;
11314   int utf8_fl;
11315
11316   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11317   utf8_fl = SvUTF8(ST(0));
11318   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11319   ST(0) = sv_newmortal();
11320   if (unixified != NULL) {
11321     sv_usepvn(ST(0),unixified,strlen(unixified));
11322     if (utf8_fl) {
11323         SvUTF8_on(ST(0));
11324     }
11325   }
11326   XSRETURN(1);
11327 }
11328
11329 void
11330 fileify_fromperl(pTHX_ CV *cv)
11331 {
11332   dXSARGS;
11333   char *fileified;
11334   STRLEN n_a;
11335   int utf8_fl;
11336
11337   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11338   utf8_fl = SvUTF8(ST(0));
11339   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11340   ST(0) = sv_newmortal();
11341   if (fileified != NULL) {
11342     sv_usepvn(ST(0),fileified,strlen(fileified));
11343     if (utf8_fl) {
11344         SvUTF8_on(ST(0));
11345     }
11346   }
11347   XSRETURN(1);
11348 }
11349
11350 void
11351 pathify_fromperl(pTHX_ CV *cv)
11352 {
11353   dXSARGS;
11354   char *pathified;
11355   STRLEN n_a;
11356   int utf8_fl;
11357
11358   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11359   utf8_fl = SvUTF8(ST(0));
11360   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11361   ST(0) = sv_newmortal();
11362   if (pathified != NULL) {
11363     sv_usepvn(ST(0),pathified,strlen(pathified));
11364     if (utf8_fl) {
11365         SvUTF8_on(ST(0));
11366     }
11367   }
11368   XSRETURN(1);
11369 }
11370
11371 void
11372 vmspath_fromperl(pTHX_ CV *cv)
11373 {
11374   dXSARGS;
11375   char *vmspath;
11376   STRLEN n_a;
11377   int utf8_fl;
11378
11379   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11380   utf8_fl = SvUTF8(ST(0));
11381   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11382   ST(0) = sv_newmortal();
11383   if (vmspath != NULL) {
11384     sv_usepvn(ST(0),vmspath,strlen(vmspath));
11385     if (utf8_fl) {
11386         SvUTF8_on(ST(0));
11387     }
11388   }
11389   XSRETURN(1);
11390 }
11391
11392 void
11393 unixpath_fromperl(pTHX_ CV *cv)
11394 {
11395   dXSARGS;
11396   char *unixpath;
11397   STRLEN n_a;
11398   int utf8_fl;
11399
11400   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11401   utf8_fl = SvUTF8(ST(0));
11402   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11403   ST(0) = sv_newmortal();
11404   if (unixpath != NULL) {
11405     sv_usepvn(ST(0),unixpath,strlen(unixpath));
11406     if (utf8_fl) {
11407         SvUTF8_on(ST(0));
11408     }
11409   }
11410   XSRETURN(1);
11411 }
11412
11413 void
11414 candelete_fromperl(pTHX_ CV *cv)
11415 {
11416   dXSARGS;
11417   char *fspec, *fsp;
11418   SV *mysv;
11419   IO *io;
11420   STRLEN n_a;
11421
11422   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11423
11424   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11425   Newx(fspec, VMS_MAXRSS, char);
11426   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11427   if (SvTYPE(mysv) == SVt_PVGV) {
11428     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11429       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11430       ST(0) = &PL_sv_no;
11431       Safefree(fspec);
11432       XSRETURN(1);
11433     }
11434     fsp = fspec;
11435   }
11436   else {
11437     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11438       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11439       ST(0) = &PL_sv_no;
11440       Safefree(fspec);
11441       XSRETURN(1);
11442     }
11443   }
11444
11445   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11446   Safefree(fspec);
11447   XSRETURN(1);
11448 }
11449
11450 void
11451 rmscopy_fromperl(pTHX_ CV *cv)
11452 {
11453   dXSARGS;
11454   char *inspec, *outspec, *inp, *outp;
11455   int date_flag;
11456   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11457                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11458   unsigned long int sts;
11459   SV *mysv;
11460   IO *io;
11461   STRLEN n_a;
11462
11463   if (items < 2 || items > 3)
11464     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11465
11466   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11467   Newx(inspec, VMS_MAXRSS, char);
11468   if (SvTYPE(mysv) == SVt_PVGV) {
11469     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11470       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11471       ST(0) = &PL_sv_no;
11472       Safefree(inspec);
11473       XSRETURN(1);
11474     }
11475     inp = inspec;
11476   }
11477   else {
11478     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11479       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11480       ST(0) = &PL_sv_no;
11481       Safefree(inspec);
11482       XSRETURN(1);
11483     }
11484   }
11485   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11486   Newx(outspec, VMS_MAXRSS, char);
11487   if (SvTYPE(mysv) == SVt_PVGV) {
11488     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11489       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11490       ST(0) = &PL_sv_no;
11491       Safefree(inspec);
11492       Safefree(outspec);
11493       XSRETURN(1);
11494     }
11495     outp = outspec;
11496   }
11497   else {
11498     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11499       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11500       ST(0) = &PL_sv_no;
11501       Safefree(inspec);
11502       Safefree(outspec);
11503       XSRETURN(1);
11504     }
11505   }
11506   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11507
11508   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11509   Safefree(inspec);
11510   Safefree(outspec);
11511   XSRETURN(1);
11512 }
11513
11514 /* The mod2fname is limited to shorter filenames by design, so it should
11515  * not be modified to support longer EFS pathnames
11516  */
11517 void
11518 mod2fname(pTHX_ CV *cv)
11519 {
11520   dXSARGS;
11521   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11522        workbuff[NAM$C_MAXRSS*1 + 1];
11523   int total_namelen = 3, counter, num_entries;
11524   /* ODS-5 ups this, but we want to be consistent, so... */
11525   int max_name_len = 39;
11526   AV *in_array = (AV *)SvRV(ST(0));
11527
11528   num_entries = av_len(in_array);
11529
11530   /* All the names start with PL_. */
11531   strcpy(ultimate_name, "PL_");
11532
11533   /* Clean up our working buffer */
11534   Zero(work_name, sizeof(work_name), char);
11535
11536   /* Run through the entries and build up a working name */
11537   for(counter = 0; counter <= num_entries; counter++) {
11538     /* If it's not the first name then tack on a __ */
11539     if (counter) {
11540       strcat(work_name, "__");
11541     }
11542     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11543                            PL_na));
11544   }
11545
11546   /* Check to see if we actually have to bother...*/
11547   if (strlen(work_name) + 3 <= max_name_len) {
11548     strcat(ultimate_name, work_name);
11549   } else {
11550     /* It's too darned big, so we need to go strip. We use the same */
11551     /* algorithm as xsubpp does. First, strip out doubled __ */
11552     char *source, *dest, last;
11553     dest = workbuff;
11554     last = 0;
11555     for (source = work_name; *source; source++) {
11556       if (last == *source && last == '_') {
11557         continue;
11558       }
11559       *dest++ = *source;
11560       last = *source;
11561     }
11562     /* Go put it back */
11563     strcpy(work_name, workbuff);
11564     /* Is it still too big? */
11565     if (strlen(work_name) + 3 > max_name_len) {
11566       /* Strip duplicate letters */
11567       last = 0;
11568       dest = workbuff;
11569       for (source = work_name; *source; source++) {
11570         if (last == toupper(*source)) {
11571         continue;
11572         }
11573         *dest++ = *source;
11574         last = toupper(*source);
11575       }
11576       strcpy(work_name, workbuff);
11577     }
11578
11579     /* Is it *still* too big? */
11580     if (strlen(work_name) + 3 > max_name_len) {
11581       /* Too bad, we truncate */
11582       work_name[max_name_len - 2] = 0;
11583     }
11584     strcat(ultimate_name, work_name);
11585   }
11586
11587   /* Okay, return it */
11588   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11589   XSRETURN(1);
11590 }
11591
11592 void
11593 hushexit_fromperl(pTHX_ CV *cv)
11594 {
11595     dXSARGS;
11596
11597     if (items > 0) {
11598         VMSISH_HUSHED = SvTRUE(ST(0));
11599     }
11600     ST(0) = boolSV(VMSISH_HUSHED);
11601     XSRETURN(1);
11602 }
11603
11604
11605 PerlIO *
11606 Perl_vms_start_glob
11607    (pTHX_ SV *tmpglob,
11608     IO *io)
11609 {
11610     PerlIO *fp;
11611     struct vs_str_st *rslt;
11612     char *vmsspec;
11613     char *rstr;
11614     char *begin, *cp;
11615     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11616     PerlIO *tmpfp;
11617     STRLEN i;
11618     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11619     struct dsc$descriptor_vs rsdsc;
11620     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11621     unsigned long hasver = 0, isunix = 0;
11622     unsigned long int lff_flags = 0;
11623     int rms_sts;
11624
11625 #ifdef VMS_LONGNAME_SUPPORT
11626     lff_flags = LIB$M_FIL_LONG_NAMES;
11627 #endif
11628     /* The Newx macro will not allow me to assign a smaller array
11629      * to the rslt pointer, so we will assign it to the begin char pointer
11630      * and then copy the value into the rslt pointer.
11631      */
11632     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11633     rslt = (struct vs_str_st *)begin;
11634     rslt->length = 0;
11635     rstr = &rslt->str[0];
11636     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11637     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11638     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11639     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11640
11641     Newx(vmsspec, VMS_MAXRSS, char);
11642
11643         /* We could find out if there's an explicit dev/dir or version
11644            by peeking into lib$find_file's internal context at
11645            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11646            but that's unsupported, so I don't want to do it now and
11647            have it bite someone in the future. */
11648         /* Fix-me: vms_split_path() is the only way to do this, the
11649            existing method will fail with many legal EFS or UNIX specifications
11650          */
11651
11652     cp = SvPV(tmpglob,i);
11653
11654     for (; i; i--) {
11655         if (cp[i] == ';') hasver = 1;
11656         if (cp[i] == '.') {
11657             if (sts) hasver = 1;
11658             else sts = 1;
11659         }
11660         if (cp[i] == '/') {
11661             hasdir = isunix = 1;
11662             break;
11663         }
11664         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11665             hasdir = 1;
11666             break;
11667         }
11668     }
11669     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11670         Stat_t st;
11671         int stat_sts;
11672         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11673         if (!stat_sts && S_ISDIR(st.st_mode)) {
11674             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
11675             ok = (wilddsc.dsc$a_pointer != NULL);
11676         }
11677         else {
11678             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
11679             ok = (wilddsc.dsc$a_pointer != NULL);
11680         }
11681         if (ok)
11682             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11683
11684         /* If not extended character set, replace ? with % */
11685         /* With extended character set, ? is a wildcard single character */
11686         if (!decc_efs_case_preserve) {
11687             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11688                 if (*cp == '?') *cp = '%';
11689         }
11690         sts = SS$_NORMAL;
11691         while (ok && $VMS_STATUS_SUCCESS(sts)) {
11692          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11693          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11694
11695             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11696                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
11697             if (!$VMS_STATUS_SUCCESS(sts))
11698                 break;
11699
11700             /* with varying string, 1st word of buffer contains result length */
11701             rstr[rslt->length] = '\0';
11702
11703              /* Find where all the components are */
11704              v_sts = vms_split_path
11705                        (rstr,
11706                         &v_spec,
11707                         &v_len,
11708                         &r_spec,
11709                         &r_len,
11710                         &d_spec,
11711                         &d_len,
11712                         &n_spec,
11713                         &n_len,
11714                         &e_spec,
11715                         &e_len,
11716                         &vs_spec,
11717                         &vs_len);
11718
11719             /* If no version on input, truncate the version on output */
11720             if (!hasver && (vs_len > 0)) {
11721                 *vs_spec = '\0';
11722                 vs_len = 0;
11723
11724                 /* No version & a null extension on UNIX handling */
11725                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
11726                     e_len = 0;
11727                     *e_spec = '\0';
11728                 }
11729             }
11730
11731             if (!decc_efs_case_preserve) {
11732                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
11733             }
11734
11735             if (hasdir) {
11736                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
11737                 begin = rstr;
11738             }
11739             else {
11740                 /* Start with the name */
11741                 begin = n_spec;
11742             }
11743             strcat(begin,"\n");
11744             ok = (PerlIO_puts(tmpfp,begin) != EOF);
11745         }
11746         if (cxt) (void)lib$find_file_end(&cxt);
11747         if (ok && sts != RMS$_NMF &&
11748             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
11749         if (!ok) {
11750             if (!(sts & 1)) {
11751                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
11752             }
11753             PerlIO_close(tmpfp);
11754             fp = NULL;
11755         }
11756         else {
11757             PerlIO_rewind(tmpfp);
11758             IoTYPE(io) = IoTYPE_RDONLY;
11759             IoIFP(io) = fp = tmpfp;
11760             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
11761         }
11762     }
11763     Safefree(vmsspec);
11764     Safefree(rslt);
11765     return fp;
11766 }
11767
11768 #ifdef HAS_SYMLINK
11769 static char *
11770 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
11771
11772 void
11773 vms_realpath_fromperl(pTHX_ CV *cv)
11774 {
11775   dXSARGS;
11776   char *fspec, *rslt_spec, *rslt;
11777   STRLEN n_a;
11778
11779   if (!items || items != 1)
11780     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
11781
11782   fspec = SvPV(ST(0),n_a);
11783   if (!fspec || !*fspec) XSRETURN_UNDEF;
11784
11785   Newx(rslt_spec, VMS_MAXRSS + 1, char);
11786   rslt = do_vms_realpath(fspec, rslt_spec, NULL);
11787   ST(0) = sv_newmortal();
11788   if (rslt != NULL)
11789     sv_usepvn(ST(0),rslt,strlen(rslt));
11790   else
11791     Safefree(rslt_spec);
11792   XSRETURN(1);
11793 }
11794 #endif
11795
11796 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11797 int do_vms_case_tolerant(void);
11798
11799 void
11800 vms_case_tolerant_fromperl(pTHX_ CV *cv)
11801 {
11802   dXSARGS;
11803   ST(0) = boolSV(do_vms_case_tolerant());
11804   XSRETURN(1);
11805 }
11806 #endif
11807
11808 void
11809 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
11810                           struct interp_intern *dst)
11811 {
11812     memcpy(dst,src,sizeof(struct interp_intern));
11813 }
11814
11815 void
11816 Perl_sys_intern_clear(pTHX)
11817 {
11818 }
11819
11820 void
11821 Perl_sys_intern_init(pTHX)
11822 {
11823     unsigned int ix = RAND_MAX;
11824     double x;
11825
11826     VMSISH_HUSHED = 0;
11827
11828     /* fix me later to track running under GNV */
11829     /* this allows some limited testing */
11830     MY_POSIX_EXIT = decc_filename_unix_report;
11831
11832     x = (float)ix;
11833     MY_INV_RAND_MAX = 1./x;
11834 }
11835
11836 void
11837 init_os_extras(void)
11838 {
11839   dTHX;
11840   char* file = __FILE__;
11841   if (decc_disable_to_vms_logname_translation) {
11842     no_translate_barewords = TRUE;
11843   } else {
11844     no_translate_barewords = FALSE;
11845   }
11846
11847   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
11848   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
11849   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
11850   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
11851   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
11852   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
11853   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
11854   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
11855   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
11856   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
11857   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
11858 #ifdef HAS_SYMLINK
11859   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
11860 #endif
11861 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11862   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
11863 #endif
11864
11865   store_pipelocs(aTHX);         /* will redo any earlier attempts */
11866
11867   return;
11868 }
11869
11870 #ifdef HAS_SYMLINK
11871
11872 #if __CRTL_VER == 80200000
11873 /* This missed getting in to the DECC SDK for 8.2 */
11874 char *realpath(const char *file_name, char * resolved_name, ...);
11875 #endif
11876
11877 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
11878 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
11879  * The perl fallback routine to provide realpath() is not as efficient
11880  * on OpenVMS.
11881  */
11882 static char *
11883 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11884 {
11885     return realpath(filespec, outbuf);
11886 }
11887
11888 /*}}}*/
11889 /* External entry points */
11890 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11891 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
11892 #else
11893 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11894 { return NULL; }
11895 #endif
11896
11897
11898 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11899 /* case_tolerant */
11900
11901 /*{{{int do_vms_case_tolerant(void)*/
11902 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
11903  * controlled by a process setting.
11904  */
11905 int do_vms_case_tolerant(void)
11906 {
11907     return vms_process_case_tolerant;
11908 }
11909 /*}}}*/
11910 /* External entry points */
11911 int Perl_vms_case_tolerant(void)
11912 { return do_vms_case_tolerant(); }
11913 #else
11914 int Perl_vms_case_tolerant(void)
11915 { return vms_process_case_tolerant; }
11916 #endif
11917
11918
11919  /* Start of DECC RTL Feature handling */
11920
11921 static int sys_trnlnm
11922    (const char * logname,
11923     char * value,
11924     int value_len)
11925 {
11926     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
11927     const unsigned long attr = LNM$M_CASE_BLIND;
11928     struct dsc$descriptor_s name_dsc;
11929     int status;
11930     unsigned short result;
11931     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
11932                                 {0, 0, 0, 0}};
11933
11934     name_dsc.dsc$w_length = strlen(logname);
11935     name_dsc.dsc$a_pointer = (char *)logname;
11936     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11937     name_dsc.dsc$b_class = DSC$K_CLASS_S;
11938
11939     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
11940
11941     if ($VMS_STATUS_SUCCESS(status)) {
11942
11943          /* Null terminate and return the string */
11944         /*--------------------------------------*/
11945         value[result] = 0;
11946     }
11947
11948     return status;
11949 }
11950
11951 static int sys_crelnm
11952    (const char * logname,
11953     const char * value)
11954 {
11955     int ret_val;
11956     const char * proc_table = "LNM$PROCESS_TABLE";
11957     struct dsc$descriptor_s proc_table_dsc;
11958     struct dsc$descriptor_s logname_dsc;
11959     struct itmlst_3 item_list[2];
11960
11961     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
11962     proc_table_dsc.dsc$w_length = strlen(proc_table);
11963     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11964     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
11965
11966     logname_dsc.dsc$a_pointer = (char *) logname;
11967     logname_dsc.dsc$w_length = strlen(logname);
11968     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11969     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
11970
11971     item_list[0].buflen = strlen(value);
11972     item_list[0].itmcode = LNM$_STRING;
11973     item_list[0].bufadr = (char *)value;
11974     item_list[0].retlen = NULL;
11975
11976     item_list[1].buflen = 0;
11977     item_list[1].itmcode = 0;
11978
11979     ret_val = sys$crelnm
11980                        (NULL,
11981                         (const struct dsc$descriptor_s *)&proc_table_dsc,
11982                         (const struct dsc$descriptor_s *)&logname_dsc,
11983                         NULL,
11984                         (const struct item_list_3 *) item_list);
11985
11986     return ret_val;
11987 }
11988
11989 /* C RTL Feature settings */
11990
11991 static int set_features
11992    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
11993     int (* cli_routine)(void),  /* Not documented */
11994     void *image_info)           /* Not documented */
11995 {
11996     int status;
11997     int s;
11998     int dflt;
11999     char* str;
12000     char val_str[10];
12001 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12002     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12003     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12004     unsigned long case_perm;
12005     unsigned long case_image;
12006 #endif
12007
12008     /* Allow an exception to bring Perl into the VMS debugger */
12009     vms_debug_on_exception = 0;
12010     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12011     if ($VMS_STATUS_SUCCESS(status)) {
12012        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12013          vms_debug_on_exception = 1;
12014        else
12015          vms_debug_on_exception = 0;
12016     }
12017
12018     /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
12019     vms_vtf7_filenames = 0;
12020     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12021     if ($VMS_STATUS_SUCCESS(status)) {
12022        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12023          vms_vtf7_filenames = 1;
12024        else
12025          vms_vtf7_filenames = 0;
12026     }
12027
12028     /* Dectect running under GNV Bash or other UNIX like shell */
12029 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12030     gnv_unix_shell = 0;
12031     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12032     if ($VMS_STATUS_SUCCESS(status)) {
12033        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12034          gnv_unix_shell = 1;
12035          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12036          set_feature_default("DECC$EFS_CHARSET", 1);
12037          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12038          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12039          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12040          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12041        }
12042        else
12043          gnv_unix_shell = 0;
12044     }
12045 #endif
12046
12047     /* hacks to see if known bugs are still present for testing */
12048
12049     /* Readdir is returning filenames in VMS syntax always */
12050     decc_bug_readdir_efs1 = 1;
12051     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12052     if ($VMS_STATUS_SUCCESS(status)) {
12053        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12054          decc_bug_readdir_efs1 = 1;
12055        else
12056          decc_bug_readdir_efs1 = 0;
12057     }
12058
12059     /* PCP mode requires creating /dev/null special device file */
12060     decc_bug_devnull = 0;
12061     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12062     if ($VMS_STATUS_SUCCESS(status)) {
12063        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12064           decc_bug_devnull = 1;
12065        else
12066           decc_bug_devnull = 0;
12067     }
12068
12069     /* fgetname returning a VMS name in UNIX mode */
12070     decc_bug_fgetname = 1;
12071     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12072     if ($VMS_STATUS_SUCCESS(status)) {
12073       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12074         decc_bug_fgetname = 1;
12075       else
12076         decc_bug_fgetname = 0;
12077     }
12078
12079     /* UNIX directory names with no paths are broken in a lot of places */
12080     decc_dir_barename = 1;
12081     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12082     if ($VMS_STATUS_SUCCESS(status)) {
12083       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12084         decc_dir_barename = 1;
12085       else
12086         decc_dir_barename = 0;
12087     }
12088
12089 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12090     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12091     if (s >= 0) {
12092         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12093         if (decc_disable_to_vms_logname_translation < 0)
12094             decc_disable_to_vms_logname_translation = 0;
12095     }
12096
12097     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12098     if (s >= 0) {
12099         decc_efs_case_preserve = decc$feature_get_value(s, 1);
12100         if (decc_efs_case_preserve < 0)
12101             decc_efs_case_preserve = 0;
12102     }
12103
12104     s = decc$feature_get_index("DECC$EFS_CHARSET");
12105     if (s >= 0) {
12106         decc_efs_charset = decc$feature_get_value(s, 1);
12107         if (decc_efs_charset < 0)
12108             decc_efs_charset = 0;
12109     }
12110
12111     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12112     if (s >= 0) {
12113         decc_filename_unix_report = decc$feature_get_value(s, 1);
12114         if (decc_filename_unix_report > 0)
12115             decc_filename_unix_report = 1;
12116         else
12117             decc_filename_unix_report = 0;
12118     }
12119
12120     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12121     if (s >= 0) {
12122         decc_filename_unix_only = decc$feature_get_value(s, 1);
12123         if (decc_filename_unix_only > 0) {
12124             decc_filename_unix_only = 1;
12125         }
12126         else {
12127             decc_filename_unix_only = 0;
12128         }
12129     }
12130
12131     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12132     if (s >= 0) {
12133         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12134         if (decc_filename_unix_no_version < 0)
12135             decc_filename_unix_no_version = 0;
12136     }
12137
12138     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12139     if (s >= 0) {
12140         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12141         if (decc_readdir_dropdotnotype < 0)
12142             decc_readdir_dropdotnotype = 0;
12143     }
12144
12145     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12146     if ($VMS_STATUS_SUCCESS(status)) {
12147         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12148         if (s >= 0) {
12149             dflt = decc$feature_get_value(s, 4);
12150             if (dflt > 0) {
12151                 decc_disable_posix_root = decc$feature_get_value(s, 1);
12152                 if (decc_disable_posix_root <= 0) {
12153                     decc$feature_set_value(s, 1, 1);
12154                     decc_disable_posix_root = 1;
12155                 }
12156             }
12157             else {
12158                 /* Traditionally Perl assumes this is off */
12159                 decc_disable_posix_root = 1;
12160                 decc$feature_set_value(s, 1, 1);
12161             }
12162         }
12163     }
12164
12165 #if __CRTL_VER >= 80200000
12166     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12167     if (s >= 0) {
12168         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12169         if (decc_posix_compliant_pathnames < 0)
12170             decc_posix_compliant_pathnames = 0;
12171         if (decc_posix_compliant_pathnames > 4)
12172             decc_posix_compliant_pathnames = 0;
12173     }
12174
12175 #endif
12176 #else
12177     status = sys_trnlnm
12178         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12179     if ($VMS_STATUS_SUCCESS(status)) {
12180         val_str[0] = _toupper(val_str[0]);
12181         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12182            decc_disable_to_vms_logname_translation = 1;
12183         }
12184     }
12185
12186 #ifndef __VAX
12187     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12188     if ($VMS_STATUS_SUCCESS(status)) {
12189         val_str[0] = _toupper(val_str[0]);
12190         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12191            decc_efs_case_preserve = 1;
12192         }
12193     }
12194 #endif
12195
12196     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12197     if ($VMS_STATUS_SUCCESS(status)) {
12198         val_str[0] = _toupper(val_str[0]);
12199         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12200            decc_filename_unix_report = 1;
12201         }
12202     }
12203     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12204     if ($VMS_STATUS_SUCCESS(status)) {
12205         val_str[0] = _toupper(val_str[0]);
12206         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12207            decc_filename_unix_only = 1;
12208            decc_filename_unix_report = 1;
12209         }
12210     }
12211     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12212     if ($VMS_STATUS_SUCCESS(status)) {
12213         val_str[0] = _toupper(val_str[0]);
12214         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12215            decc_filename_unix_no_version = 1;
12216         }
12217     }
12218     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12219     if ($VMS_STATUS_SUCCESS(status)) {
12220         val_str[0] = _toupper(val_str[0]);
12221         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12222            decc_readdir_dropdotnotype = 1;
12223         }
12224     }
12225 #endif
12226
12227 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12228
12229      /* Report true case tolerance */
12230     /*----------------------------*/
12231     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12232     if (!$VMS_STATUS_SUCCESS(status))
12233         case_perm = PPROP$K_CASE_BLIND;
12234     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12235     if (!$VMS_STATUS_SUCCESS(status))
12236         case_image = PPROP$K_CASE_BLIND;
12237     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12238         (case_image == PPROP$K_CASE_SENSITIVE))
12239         vms_process_case_tolerant = 0;
12240
12241 #endif
12242
12243
12244     /* CRTL can be initialized past this point, but not before. */
12245 /*    DECC$CRTL_INIT(); */
12246
12247     return SS$_NORMAL;
12248 }
12249
12250 #ifdef __DECC
12251 /* DECC dependent attributes */
12252 #if __DECC_VER < 60560002
12253 #define relative
12254 #define not_executable
12255 #else
12256 #define relative ,rel
12257 #define not_executable ,noexe
12258 #endif
12259 #pragma nostandard
12260 #pragma extern_model save
12261 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12262 #endif
12263         const __align (LONGWORD) int spare[8] = {0};
12264 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
12265 /*                        NOWRT, LONG */
12266 #ifdef __DECC
12267 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
12268         nowrt,noshr relative not_executable
12269 #endif
12270 const long vms_cc_features = (const long)set_features;
12271
12272 /*
12273 ** Force a reference to LIB$INITIALIZE to ensure it
12274 ** exists in the image.
12275 */
12276 int lib$initialize(void);
12277 #ifdef __DECC
12278 #pragma extern_model strict_refdef
12279 #endif
12280     int lib_init_ref = (int) lib$initialize;
12281
12282 #ifdef __DECC
12283 #pragma extern_model restore
12284 #pragma standard
12285 #endif
12286
12287 /*  End of vms.c */