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       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5152         cp1 = strchr(esa,']');
5153         if (!cp1) cp1 = strchr(esa,'>');
5154         if (cp1) {  /* Should always be true */
5155           rms_nam_esll(dirnam) -= cp1 - esa - 1;
5156           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5157         }
5158       }
5159       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5160         /* Yep; check version while we're at it, if it's there. */
5161         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5162         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5163           /* Something other than .DIR[;1].  Bzzt. */
5164           sts = rms_free_search_context(&dirfab);
5165           PerlMem_free(esa);
5166           PerlMem_free(trndir);
5167           PerlMem_free(vmsdir);
5168           set_errno(ENOTDIR);
5169           set_vaxc_errno(RMS$_DIR);
5170           return NULL;
5171         }
5172       }
5173       esa[rms_nam_esll(dirnam)] = '\0';
5174       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5175         /* They provided at least the name; we added the type, if necessary, */
5176         if (buf) retspec = buf;                            /* in sys$parse() */
5177         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5178         else retspec = __fileify_retbuf;
5179         strcpy(retspec,esa);
5180         sts = rms_free_search_context(&dirfab);
5181         PerlMem_free(trndir);
5182         PerlMem_free(esa);
5183         PerlMem_free(vmsdir);
5184         return retspec;
5185       }
5186       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5187         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5188         *cp1 = '\0';
5189         rms_nam_esll(dirnam) -= 9;
5190       }
5191       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5192       if (cp1 == NULL) { /* should never happen */
5193         sts = rms_free_search_context(&dirfab);
5194         PerlMem_free(trndir);
5195         PerlMem_free(esa);
5196         PerlMem_free(vmsdir);
5197         return NULL;
5198       }
5199       term = *cp1;
5200       *cp1 = '\0';
5201       retlen = strlen(esa);
5202       cp1 = strrchr(esa,'.');
5203       /* ODS-5 directory specifications can have extra "." in them. */
5204       /* Fix-me, can not scan EFS file specifications backwards */
5205       while (cp1 != NULL) {
5206         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5207           break;
5208         else {
5209            cp1--;
5210            while ((cp1 > esa) && (*cp1 != '.'))
5211              cp1--;
5212         }
5213         if (cp1 == esa)
5214           cp1 = NULL;
5215       }
5216
5217       if ((cp1) != NULL) {
5218         /* There's more than one directory in the path.  Just roll back. */
5219         *cp1 = term;
5220         if (buf) retspec = buf;
5221         else if (ts) Newx(retspec,retlen+7,char);
5222         else retspec = __fileify_retbuf;
5223         strcpy(retspec,esa);
5224       }
5225       else {
5226         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5227           /* Go back and expand rooted logical name */
5228           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5229 #ifdef NAM$M_NO_SHORT_UPCASE
5230           if (decc_efs_case_preserve)
5231             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5232 #endif
5233           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5234             sts = rms_free_search_context(&dirfab);
5235             PerlMem_free(esa);
5236             PerlMem_free(trndir);
5237             PerlMem_free(vmsdir);
5238             set_errno(EVMSERR);
5239             set_vaxc_errno(dirfab.fab$l_sts);
5240             return NULL;
5241           }
5242           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5243           if (buf) retspec = buf;
5244           else if (ts) Newx(retspec,retlen+16,char);
5245           else retspec = __fileify_retbuf;
5246           cp1 = strstr(esa,"][");
5247           if (!cp1) cp1 = strstr(esa,"]<");
5248           dirlen = cp1 - esa;
5249           memcpy(retspec,esa,dirlen);
5250           if (!strncmp(cp1+2,"000000]",7)) {
5251             retspec[dirlen-1] = '\0';
5252             /* fix-me Not full ODS-5, just extra dots in directories for now */
5253             cp1 = retspec + dirlen - 1;
5254             while (cp1 > retspec)
5255             {
5256               if (*cp1 == '[')
5257                 break;
5258               if (*cp1 == '.') {
5259                 if (*(cp1-1) != '^')
5260                   break;
5261               }
5262               cp1--;
5263             }
5264             if (*cp1 == '.') *cp1 = ']';
5265             else {
5266               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5267               memmove(cp1+1,"000000]",7);
5268             }
5269           }
5270           else {
5271             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5272             retspec[retlen] = '\0';
5273             /* Convert last '.' to ']' */
5274             cp1 = retspec+retlen-1;
5275             while (*cp != '[') {
5276               cp1--;
5277               if (*cp1 == '.') {
5278                 /* Do not trip on extra dots in ODS-5 directories */
5279                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5280                 break;
5281               }
5282             }
5283             if (*cp1 == '.') *cp1 = ']';
5284             else {
5285               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5286               memmove(cp1+1,"000000]",7);
5287             }
5288           }
5289         }
5290         else {  /* This is a top-level dir.  Add the MFD to the path. */
5291           if (buf) retspec = buf;
5292           else if (ts) Newx(retspec,retlen+16,char);
5293           else retspec = __fileify_retbuf;
5294           cp1 = esa;
5295           cp2 = retspec;
5296           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5297           strcpy(cp2,":[000000]");
5298           cp1 += 2;
5299           strcpy(cp2+9,cp1);
5300         }
5301       }
5302       sts = rms_free_search_context(&dirfab);
5303       /* We've set up the string up through the filename.  Add the
5304          type and version, and we're done. */
5305       strcat(retspec,".DIR;1");
5306
5307       /* $PARSE may have upcased filespec, so convert output to lower
5308        * case if input contained any lowercase characters. */
5309       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5310       PerlMem_free(trndir);
5311       PerlMem_free(esa);
5312       PerlMem_free(vmsdir);
5313       return retspec;
5314     }
5315 }  /* end of do_fileify_dirspec() */
5316 /*}}}*/
5317 /* External entry points */
5318 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5319 { return do_fileify_dirspec(dir,buf,0,NULL); }
5320 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5321 { return do_fileify_dirspec(dir,buf,1,NULL); }
5322 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5323 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5324 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5325 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5326
5327 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5328 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5329 {
5330     static char __pathify_retbuf[VMS_MAXRSS];
5331     unsigned long int retlen;
5332     char *retpath, *cp1, *cp2, *trndir;
5333     unsigned short int trnlnm_iter_count;
5334     STRLEN trnlen;
5335     int sts;
5336     if (utf8_fl != NULL)
5337         *utf8_fl = 0;
5338
5339     if (!dir || !*dir) {
5340       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5341     }
5342
5343     trndir = PerlMem_malloc(VMS_MAXRSS);
5344     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5345     if (*dir) strcpy(trndir,dir);
5346     else getcwd(trndir,VMS_MAXRSS - 1);
5347
5348     trnlnm_iter_count = 0;
5349     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5350            && my_trnlnm(trndir,trndir,0)) {
5351       trnlnm_iter_count++;
5352       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5353       trnlen = strlen(trndir);
5354
5355       /* Trap simple rooted lnms, and return lnm:[000000] */
5356       if (!strcmp(trndir+trnlen-2,".]")) {
5357         if (buf) retpath = buf;
5358         else if (ts) Newx(retpath,strlen(dir)+10,char);
5359         else retpath = __pathify_retbuf;
5360         strcpy(retpath,dir);
5361         strcat(retpath,":[000000]");
5362         PerlMem_free(trndir);
5363         return retpath;
5364       }
5365     }
5366
5367     /* At this point we do not work with *dir, but the copy in
5368      * *trndir that is modifiable.
5369      */
5370
5371     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5372       if (*trndir == '.' && (*(trndir+1) == '\0' ||
5373                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5374         retlen = 2 + (*(trndir+1) != '\0');
5375       else {
5376         if ( !(cp1 = strrchr(trndir,'/')) &&
5377              !(cp1 = strrchr(trndir,']')) &&
5378              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5379         if ((cp2 = strchr(cp1,'.')) != NULL &&
5380             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
5381              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
5382               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5383               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5384           int ver; char *cp3;
5385
5386           /* For EFS or ODS-5 look for the last dot */
5387           if (decc_efs_charset) {
5388             cp2 = strrchr(cp1,'.');
5389           }
5390           if (vms_process_case_tolerant) {
5391               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5392                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5393                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5394                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5395                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5396                             (ver || *cp3)))))) {
5397                 PerlMem_free(trndir);
5398                 set_errno(ENOTDIR);
5399                 set_vaxc_errno(RMS$_DIR);
5400                 return NULL;
5401               }
5402           }
5403           else {
5404               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5405                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5406                   !*(cp2+3) || *(cp2+3) != 'R' ||
5407                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5408                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5409                             (ver || *cp3)))))) {
5410                 PerlMem_free(trndir);
5411                 set_errno(ENOTDIR);
5412                 set_vaxc_errno(RMS$_DIR);
5413                 return NULL;
5414               }
5415           }
5416           retlen = cp2 - trndir + 1;
5417         }
5418         else {  /* No file type present.  Treat the filename as a directory. */
5419           retlen = strlen(trndir) + 1;
5420         }
5421       }
5422       if (buf) retpath = buf;
5423       else if (ts) Newx(retpath,retlen+1,char);
5424       else retpath = __pathify_retbuf;
5425       strncpy(retpath, trndir, retlen-1);
5426       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5427         retpath[retlen-1] = '/';      /* with '/', add it. */
5428         retpath[retlen] = '\0';
5429       }
5430       else retpath[retlen-1] = '\0';
5431     }
5432     else {  /* VMS-style directory spec */
5433       char *esa, *cp;
5434       unsigned long int sts, cmplen, haslower;
5435       struct FAB dirfab = cc$rms_fab;
5436       int dirlen;
5437       rms_setup_nam(savnam);
5438       rms_setup_nam(dirnam);
5439
5440       /* If we've got an explicit filename, we can just shuffle the string. */
5441       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5442              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
5443         if ((cp2 = strchr(cp1,'.')) != NULL) {
5444           int ver; char *cp3;
5445           if (vms_process_case_tolerant) {
5446               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5447                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5448                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5449                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5450                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5451                             (ver || *cp3)))))) {
5452                PerlMem_free(trndir);
5453                set_errno(ENOTDIR);
5454                set_vaxc_errno(RMS$_DIR);
5455                return NULL;
5456              }
5457           }
5458           else {
5459               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5460                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5461                   !*(cp2+3) || *(cp2+3) != 'R' ||
5462                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5463                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5464                             (ver || *cp3)))))) {
5465                PerlMem_free(trndir);
5466                set_errno(ENOTDIR);
5467                set_vaxc_errno(RMS$_DIR);
5468                return NULL;
5469              }
5470           }
5471         }
5472         else {  /* No file type, so just draw name into directory part */
5473           for (cp2 = cp1; *cp2; cp2++) ;
5474         }
5475         *cp2 = *cp1;
5476         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5477         *cp1 = '.';
5478         /* We've now got a VMS 'path'; fall through */
5479       }
5480
5481       dirlen = strlen(trndir);
5482       if (trndir[dirlen-1] == ']' ||
5483           trndir[dirlen-1] == '>' ||
5484           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5485         if (buf) retpath = buf;
5486         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5487         else retpath = __pathify_retbuf;
5488         strcpy(retpath,trndir);
5489         PerlMem_free(trndir);
5490         return retpath;
5491       }
5492       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5493       esa = PerlMem_malloc(VMS_MAXRSS);
5494       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5495       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5496       rms_bind_fab_nam(dirfab, dirnam);
5497       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5498 #ifdef NAM$M_NO_SHORT_UPCASE
5499       if (decc_efs_case_preserve)
5500           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5501 #endif
5502
5503       for (cp = trndir; *cp; cp++)
5504         if (islower(*cp)) { haslower = 1; break; }
5505
5506       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5507         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5508           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5509           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5510         }
5511         if (!sts) {
5512           PerlMem_free(trndir);
5513           PerlMem_free(esa);
5514           set_errno(EVMSERR);
5515           set_vaxc_errno(dirfab.fab$l_sts);
5516           return NULL;
5517         }
5518       }
5519       else {
5520         savnam = dirnam;
5521         /* Does the file really exist? */
5522         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5523           if (dirfab.fab$l_sts != RMS$_FNF) {
5524             int sts1;
5525             sts1 = rms_free_search_context(&dirfab);
5526             PerlMem_free(trndir);
5527             PerlMem_free(esa);
5528             set_errno(EVMSERR);
5529             set_vaxc_errno(dirfab.fab$l_sts);
5530             return NULL;
5531           }
5532           dirnam = savnam; /* No; just work with potential name */
5533         }
5534       }
5535       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5536         /* Yep; check version while we're at it, if it's there. */
5537         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5538         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5539           int sts2;
5540           /* Something other than .DIR[;1].  Bzzt. */
5541           sts2 = rms_free_search_context(&dirfab);
5542           PerlMem_free(trndir);
5543           PerlMem_free(esa);
5544           set_errno(ENOTDIR);
5545           set_vaxc_errno(RMS$_DIR);
5546           return NULL;
5547         }
5548       }
5549       /* OK, the type was fine.  Now pull any file name into the
5550          directory path. */
5551       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5552       else {
5553         cp1 = strrchr(esa,'>');
5554         *(rms_nam_typel(dirnam)) = '>';
5555       }
5556       *cp1 = '.';
5557       *(rms_nam_typel(dirnam) + 1) = '\0';
5558       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5559       if (buf) retpath = buf;
5560       else if (ts) Newx(retpath,retlen,char);
5561       else retpath = __pathify_retbuf;
5562       strcpy(retpath,esa);
5563       PerlMem_free(esa);
5564       sts = rms_free_search_context(&dirfab);
5565       /* $PARSE may have upcased filespec, so convert output to lower
5566        * case if input contained any lowercase characters. */
5567       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5568     }
5569
5570     PerlMem_free(trndir);
5571     return retpath;
5572 }  /* end of do_pathify_dirspec() */
5573 /*}}}*/
5574 /* External entry points */
5575 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5576 { return do_pathify_dirspec(dir,buf,0,NULL); }
5577 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5578 { return do_pathify_dirspec(dir,buf,1,NULL); }
5579 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5580 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5581 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5582 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5583
5584 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5585 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5586 {
5587   static char __tounixspec_retbuf[VMS_MAXRSS];
5588   char *dirend, *rslt, *cp1, *cp3, *tmp;
5589   const char *cp2;
5590   int devlen, dirlen, retlen = VMS_MAXRSS;
5591   int expand = 1; /* guarantee room for leading and trailing slashes */
5592   unsigned short int trnlnm_iter_count;
5593   int cmp_rslt;
5594   if (utf8_fl != NULL)
5595     *utf8_fl = 0;
5596
5597   if (spec == NULL) return NULL;
5598   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5599   if (buf) rslt = buf;
5600   else if (ts) {
5601     Newx(rslt, VMS_MAXRSS, char);
5602   }
5603   else rslt = __tounixspec_retbuf;
5604
5605   /* New VMS specific format needs translation
5606    * glob passes filenames with trailing '\n' and expects this preserved.
5607    */
5608   if (decc_posix_compliant_pathnames) {
5609     if (strncmp(spec, "\"^UP^", 5) == 0) {
5610       char * uspec;
5611       char *tunix;
5612       int tunix_len;
5613       int nl_flag;
5614
5615       tunix = PerlMem_malloc(VMS_MAXRSS);
5616       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5617       strcpy(tunix, spec);
5618       tunix_len = strlen(tunix);
5619       nl_flag = 0;
5620       if (tunix[tunix_len - 1] == '\n') {
5621         tunix[tunix_len - 1] = '\"';
5622         tunix[tunix_len] = '\0';
5623         tunix_len--;
5624         nl_flag = 1;
5625       }
5626       uspec = decc$translate_vms(tunix);
5627       PerlMem_free(tunix);
5628       if ((int)uspec > 0) {
5629         strcpy(rslt,uspec);
5630         if (nl_flag) {
5631           strcat(rslt,"\n");
5632         }
5633         else {
5634           /* If we can not translate it, makemaker wants as-is */
5635           strcpy(rslt, spec);
5636         }
5637         return rslt;
5638       }
5639     }
5640   }
5641
5642   cmp_rslt = 0; /* Presume VMS */
5643   cp1 = strchr(spec, '/');
5644   if (cp1 == NULL)
5645     cmp_rslt = 0;
5646
5647     /* Look for EFS ^/ */
5648     if (decc_efs_charset) {
5649       while (cp1 != NULL) {
5650         cp2 = cp1 - 1;
5651         if (*cp2 != '^') {
5652           /* Found illegal VMS, assume UNIX */
5653           cmp_rslt = 1;
5654           break;
5655         }
5656       cp1++;
5657       cp1 = strchr(cp1, '/');
5658     }
5659   }
5660
5661   /* Look for "." and ".." */
5662   if (decc_filename_unix_report) {
5663     if (spec[0] == '.') {
5664       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5665         cmp_rslt = 1;
5666       }
5667       else {
5668         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5669           cmp_rslt = 1;
5670         }
5671       }
5672     }
5673   }
5674   /* This is already UNIX or at least nothing VMS understands */
5675   if (cmp_rslt) {
5676     strcpy(rslt,spec);
5677     return rslt;
5678   }
5679
5680   cp1 = rslt;
5681   cp2 = spec;
5682   dirend = strrchr(spec,']');
5683   if (dirend == NULL) dirend = strrchr(spec,'>');
5684   if (dirend == NULL) dirend = strchr(spec,':');
5685   if (dirend == NULL) {
5686     strcpy(rslt,spec);
5687     return rslt;
5688   }
5689
5690   /* Special case 1 - sys$posix_root = / */
5691 #if __CRTL_VER >= 70000000
5692   if (!decc_disable_posix_root) {
5693     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5694       *cp1 = '/';
5695       cp1++;
5696       cp2 = cp2 + 15;
5697       }
5698   }
5699 #endif
5700
5701   /* Special case 2 - Convert NLA0: to /dev/null */
5702 #if __CRTL_VER < 70000000
5703   cmp_rslt = strncmp(spec,"NLA0:", 5);
5704   if (cmp_rslt != 0)
5705      cmp_rslt = strncmp(spec,"nla0:", 5);
5706 #else
5707   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5708 #endif
5709   if (cmp_rslt == 0) {
5710     strcpy(rslt, "/dev/null");
5711     cp1 = cp1 + 9;
5712     cp2 = cp2 + 5;
5713     if (spec[6] != '\0') {
5714       cp1[9] == '/';
5715       cp1++;
5716       cp2++;
5717     }
5718   }
5719
5720    /* Also handle special case "SYS$SCRATCH:" */
5721 #if __CRTL_VER < 70000000
5722   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5723   if (cmp_rslt != 0)
5724      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5725 #else
5726   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5727 #endif
5728   tmp = PerlMem_malloc(VMS_MAXRSS);
5729   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
5730   if (cmp_rslt == 0) {
5731   int islnm;
5732
5733     islnm = my_trnlnm(tmp, "TMP", 0);
5734     if (!islnm) {
5735       strcpy(rslt, "/tmp");
5736       cp1 = cp1 + 4;
5737       cp2 = cp2 + 12;
5738       if (spec[12] != '\0') {
5739         cp1[4] == '/';
5740         cp1++;
5741         cp2++;
5742       }
5743     }
5744   }
5745
5746   if (*cp2 != '[' && *cp2 != '<') {
5747     *(cp1++) = '/';
5748   }
5749   else {  /* the VMS spec begins with directories */
5750     cp2++;
5751     if (*cp2 == ']' || *cp2 == '>') {
5752       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5753       PerlMem_free(tmp);
5754       return rslt;
5755     }
5756     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5757       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
5758         if (ts) Safefree(rslt);
5759         PerlMem_free(tmp);
5760         return NULL;
5761       }
5762       trnlnm_iter_count = 0;
5763       do {
5764         cp3 = tmp;
5765         while (*cp3 != ':' && *cp3) cp3++;
5766         *(cp3++) = '\0';
5767         if (strchr(cp3,']') != NULL) break;
5768         trnlnm_iter_count++;
5769         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5770       } while (vmstrnenv(tmp,tmp,0,fildev,0));
5771       if (ts && !buf &&
5772           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5773         retlen = devlen + dirlen;
5774         Renew(rslt,retlen+1+2*expand,char);
5775         cp1 = rslt;
5776       }
5777       cp3 = tmp;
5778       *(cp1++) = '/';
5779       while (*cp3) {
5780         *(cp1++) = *(cp3++);
5781         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
5782             PerlMem_free(tmp);
5783             return NULL; /* No room */
5784         }
5785       }
5786       *(cp1++) = '/';
5787     }
5788     if ((*cp2 == '^')) {
5789         /* EFS file escape, pass the next character as is */
5790         /* Fix me: HEX encoding for UNICODE not implemented */
5791         cp2++;
5792     }
5793     else if ( *cp2 == '.') {
5794       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5795         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5796         cp2 += 3;
5797       }
5798       else cp2++;
5799     }
5800   }
5801   PerlMem_free(tmp);
5802   for (; cp2 <= dirend; cp2++) {
5803     if ((*cp2 == '^')) {
5804         /* EFS file escape, pass the next character as is */
5805         /* Fix me: HEX encoding for UNICODE not implemented */
5806         cp2++;
5807         *(cp1++) = *cp2;
5808     }
5809     if (*cp2 == ':') {
5810       *(cp1++) = '/';
5811       if (*(cp2+1) == '[') cp2++;
5812     }
5813     else if (*cp2 == ']' || *cp2 == '>') {
5814       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5815     }
5816     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5817       *(cp1++) = '/';
5818       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5819         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5820                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5821         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5822             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5823       }
5824       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5825         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5826         cp2 += 2;
5827       }
5828     }
5829     else if (*cp2 == '-') {
5830       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5831         while (*cp2 == '-') {
5832           cp2++;
5833           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5834         }
5835         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5836           if (ts) Safefree(rslt);                        /* filespecs like */
5837           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
5838           return NULL;
5839         }
5840       }
5841       else *(cp1++) = *cp2;
5842     }
5843     else *(cp1++) = *cp2;
5844   }
5845   while (*cp2) *(cp1++) = *(cp2++);
5846   *cp1 = '\0';
5847
5848   /* This still leaves /000000/ when working with a
5849    * VMS device root or concealed root.
5850    */
5851   {
5852   int ulen;
5853   char * zeros;
5854
5855       ulen = strlen(rslt);
5856
5857       /* Get rid of "000000/ in rooted filespecs */
5858       if (ulen > 7) {
5859         zeros = strstr(rslt, "/000000/");
5860         if (zeros != NULL) {
5861           int mlen;
5862           mlen = ulen - (zeros - rslt) - 7;
5863           memmove(zeros, &zeros[7], mlen);
5864           ulen = ulen - 7;
5865           rslt[ulen] = '\0';
5866         }
5867       }
5868   }
5869
5870   return rslt;
5871
5872 }  /* end of do_tounixspec() */
5873 /*}}}*/
5874 /* External entry points */
5875 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
5876   { return do_tounixspec(spec,buf,0, NULL); }
5877 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
5878   { return do_tounixspec(spec,buf,1, NULL); }
5879 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
5880   { return do_tounixspec(spec,buf,0, utf8_fl); }
5881 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
5882   { return do_tounixspec(spec,buf,1, utf8_fl); }
5883
5884 #if __CRTL_VER >= 70200000 && !defined(__VAX)
5885
5886 /*
5887  This procedure is used to identify if a path is based in either
5888  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
5889  it returns the OpenVMS format directory for it.
5890
5891  It is expecting specifications of only '/' or '/xxxx/'
5892
5893  If a posix root does not exist, or 'xxxx' is not a directory
5894  in the posix root, it returns a failure.
5895
5896  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
5897
5898  It is used only internally by posix_to_vmsspec_hardway().
5899  */
5900
5901 static int posix_root_to_vms
5902   (char *vmspath, int vmspath_len,
5903    const char *unixpath,
5904    const int * utf8_fl) {
5905 int sts;
5906 struct FAB myfab = cc$rms_fab;
5907 struct NAML mynam = cc$rms_naml;
5908 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5909  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5910 char *esa;
5911 char *vms_delim;
5912 int dir_flag;
5913 int unixlen;
5914
5915     dir_flag = 0;
5916     unixlen = strlen(unixpath);
5917     if (unixlen == 0) {
5918       vmspath[0] = '\0';
5919       return RMS$_FNF;
5920     }
5921
5922 #if __CRTL_VER >= 80200000
5923   /* If not a posix spec already, convert it */
5924   if (decc_posix_compliant_pathnames) {
5925     if (strncmp(unixpath,"\"^UP^",5) != 0) {
5926       sprintf(vmspath,"\"^UP^%s\"",unixpath);
5927     }
5928     else {
5929       /* This is already a VMS specification, no conversion */
5930       unixlen--;
5931       strncpy(vmspath,unixpath, vmspath_len);
5932     }
5933   }
5934   else
5935 #endif
5936   {
5937   int path_len;
5938   int i,j;
5939
5940      /* Check to see if this is under the POSIX root */
5941      if (decc_disable_posix_root) {
5942         return RMS$_FNF;
5943      }
5944
5945      /* Skip leading / */
5946      if (unixpath[0] == '/') {
5947         unixpath++;
5948         unixlen--;
5949      }
5950
5951
5952      strcpy(vmspath,"SYS$POSIX_ROOT:");
5953
5954      /* If this is only the / , or blank, then... */
5955      if (unixpath[0] == '\0') {
5956         /* by definition, this is the answer */
5957         return SS$_NORMAL;
5958      }
5959
5960      /* Need to look up a directory */
5961      vmspath[15] = '[';
5962      vmspath[16] = '\0';
5963
5964      /* Copy and add '^' escape characters as needed */
5965      j = 16;
5966      i = 0;
5967      while (unixpath[i] != 0) {
5968      int k;
5969
5970         j += copy_expand_unix_filename_escape
5971             (&vmspath[j], &unixpath[i], &k, utf8_fl);
5972         i += k;
5973      }
5974
5975      path_len = strlen(vmspath);
5976      if (vmspath[path_len - 1] == '/')
5977         path_len--;
5978      vmspath[path_len] = ']';
5979      path_len++;
5980      vmspath[path_len] = '\0';
5981
5982   }
5983   vmspath[vmspath_len] = 0;
5984   if (unixpath[unixlen - 1] == '/')
5985   dir_flag = 1;
5986   esa = PerlMem_malloc(VMS_MAXRSS);
5987   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5988   myfab.fab$l_fna = vmspath;
5989   myfab.fab$b_fns = strlen(vmspath);
5990   myfab.fab$l_naml = &mynam;
5991   mynam.naml$l_esa = NULL;
5992   mynam.naml$b_ess = 0;
5993   mynam.naml$l_long_expand = esa;
5994   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
5995   mynam.naml$l_rsa = NULL;
5996   mynam.naml$b_rss = 0;
5997   if (decc_efs_case_preserve)
5998     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5999 #ifdef NAML$M_OPEN_SPECIAL
6000   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6001 #endif
6002
6003   /* Set up the remaining naml fields */
6004   sts = sys$parse(&myfab);
6005
6006   /* It failed! Try again as a UNIX filespec */
6007   if (!(sts & 1)) {
6008     PerlMem_free(esa);
6009     return sts;
6010   }
6011
6012    /* get the Device ID and the FID */
6013    sts = sys$search(&myfab);
6014    /* on any failure, returned the POSIX ^UP^ filespec */
6015    if (!(sts & 1)) {
6016       PerlMem_free(esa);
6017       return sts;
6018    }
6019    specdsc.dsc$a_pointer = vmspath;
6020    specdsc.dsc$w_length = vmspath_len;
6021
6022    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6023    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6024    sts = lib$fid_to_name
6025       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6026
6027   /* on any failure, returned the POSIX ^UP^ filespec */
6028   if (!(sts & 1)) {
6029      /* This can happen if user does not have permission to read directories */
6030      if (strncmp(unixpath,"\"^UP^",5) != 0)
6031        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6032      else
6033        strcpy(vmspath, unixpath);
6034   }
6035   else {
6036     vmspath[specdsc.dsc$w_length] = 0;
6037
6038     /* Are we expecting a directory? */
6039     if (dir_flag != 0) {
6040     int i;
6041     char *eptr;
6042
6043       eptr = NULL;
6044
6045       i = specdsc.dsc$w_length - 1;
6046       while (i > 0) {
6047       int zercnt;
6048         zercnt = 0;
6049         /* Version must be '1' */
6050         if (vmspath[i--] != '1')
6051           break;
6052         /* Version delimiter is one of ".;" */
6053         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6054           break;
6055         i--;
6056         if (vmspath[i--] != 'R')
6057           break;
6058         if (vmspath[i--] != 'I')
6059           break;
6060         if (vmspath[i--] != 'D')
6061           break;
6062         if (vmspath[i--] != '.')
6063           break;
6064         eptr = &vmspath[i+1];
6065         while (i > 0) {
6066           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6067             if (vmspath[i-1] != '^') {
6068               if (zercnt != 6) {
6069                 *eptr = vmspath[i];
6070                 eptr[1] = '\0';
6071                 vmspath[i] = '.';
6072                 break;
6073               }
6074               else {
6075                 /* Get rid of 6 imaginary zero directory filename */
6076                 vmspath[i+1] = '\0';
6077               }
6078             }
6079           }
6080           if (vmspath[i] == '0')
6081             zercnt++;
6082           else
6083             zercnt = 10;
6084           i--;
6085         }
6086         break;
6087       }
6088     }
6089   }
6090   PerlMem_free(esa);
6091   return sts;
6092 }
6093
6094 /* /dev/mumble needs to be handled special.
6095    /dev/null becomes NLA0:, And there is the potential for other stuff
6096    like /dev/tty which may need to be mapped to something.
6097 */
6098
6099 static int
6100 slash_dev_special_to_vms
6101    (const char * unixptr,
6102     char * vmspath,
6103     int vmspath_len)
6104 {
6105 char * nextslash;
6106 int len;
6107 int cmp;
6108 int islnm;
6109
6110     unixptr += 4;
6111     nextslash = strchr(unixptr, '/');
6112     len = strlen(unixptr);
6113     if (nextslash != NULL)
6114         len = nextslash - unixptr;
6115     cmp = strncmp("null", unixptr, 5);
6116     if (cmp == 0) {
6117         if (vmspath_len >= 6) {
6118             strcpy(vmspath, "_NLA0:");
6119             return SS$_NORMAL;
6120         }
6121     }
6122 }
6123
6124
6125 /* The built in routines do not understand perl's special needs, so
6126     doing a manual conversion from UNIX to VMS
6127
6128     If the utf8_fl is not null and points to a non-zero value, then
6129     treat 8 bit characters as UTF-8.
6130
6131     The sequence starting with '$(' and ending with ')' will be passed
6132     through with out interpretation instead of being escaped.
6133
6134   */
6135 static int posix_to_vmsspec_hardway
6136   (char *vmspath, int vmspath_len,
6137    const char *unixpath,
6138    int dir_flag,
6139    int * utf8_fl) {
6140
6141 char *esa;
6142 const char *unixptr;
6143 const char *unixend;
6144 char *vmsptr;
6145 const char *lastslash;
6146 const char *lastdot;
6147 int unixlen;
6148 int vmslen;
6149 int dir_start;
6150 int dir_dot;
6151 int quoted;
6152 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6153 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6154
6155   if (utf8_fl != NULL)
6156     *utf8_fl = 0;
6157
6158   unixptr = unixpath;
6159   dir_dot = 0;
6160
6161   /* Ignore leading "/" characters */
6162   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6163     unixptr++;
6164   }
6165   unixlen = strlen(unixptr);
6166
6167   /* Do nothing with blank paths */
6168   if (unixlen == 0) {
6169     vmspath[0] = '\0';
6170     return SS$_NORMAL;
6171   }
6172
6173   quoted = 0;
6174   /* This could have a "^UP^ on the front */
6175   if (strncmp(unixptr,"\"^UP^",5) == 0) {
6176     quoted = 1;
6177     unixptr+= 5;
6178     unixlen-= 5;
6179   }
6180
6181   lastslash = strrchr(unixptr,'/');
6182   lastdot = strrchr(unixptr,'.');
6183   unixend = strrchr(unixptr,'\"');
6184   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6185     unixend = unixptr + unixlen;
6186   }
6187
6188   /* last dot is last dot or past end of string */
6189   if (lastdot == NULL)
6190     lastdot = unixptr + unixlen;
6191
6192   /* if no directories, set last slash to beginning of string */
6193   if (lastslash == NULL) {
6194     lastslash = unixptr;
6195   }
6196   else {
6197     /* Watch out for trailing "." after last slash, still a directory */
6198     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6199       lastslash = unixptr + unixlen;
6200     }
6201
6202     /* Watch out for traiing ".." after last slash, still a directory */
6203     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6204       lastslash = unixptr + unixlen;
6205     }
6206
6207     /* dots in directories are aways escaped */
6208     if (lastdot < lastslash)
6209       lastdot = unixptr + unixlen;
6210   }
6211
6212   /* if (unixptr < lastslash) then we are in a directory */
6213
6214   dir_start = 0;
6215
6216   vmsptr = vmspath;
6217   vmslen = 0;
6218
6219   /* Start with the UNIX path */
6220   if (*unixptr != '/') {
6221     /* relative paths */
6222
6223     /* If allowing logical names on relative pathnames, then handle here */
6224     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6225         !decc_posix_compliant_pathnames) {
6226     char * nextslash;
6227     int seg_len;
6228     char * trn;
6229     int islnm;
6230
6231         /* Find the next slash */
6232         nextslash = strchr(unixptr,'/');
6233
6234         esa = PerlMem_malloc(vmspath_len);
6235         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6236
6237         trn = PerlMem_malloc(VMS_MAXRSS);
6238         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6239
6240         if (nextslash != NULL) {
6241
6242             seg_len = nextslash - unixptr;
6243             strncpy(esa, unixptr, seg_len);
6244             esa[seg_len] = 0;
6245         }
6246         else {
6247             strcpy(esa, unixptr);
6248             seg_len = strlen(unixptr);
6249         }
6250         /* trnlnm(section) */
6251         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6252
6253         if (islnm) {
6254             /* Now fix up the directory */
6255
6256             /* Split up the path to find the components */
6257             sts = vms_split_path
6258                   (trn,
6259                    &v_spec,
6260                    &v_len,
6261                    &r_spec,
6262                    &r_len,
6263                    &d_spec,
6264                    &d_len,
6265                    &n_spec,
6266                    &n_len,
6267                    &e_spec,
6268                    &e_len,
6269                    &vs_spec,
6270                    &vs_len);
6271
6272             while (sts == 0) {
6273             char * strt;
6274             int cmp;
6275
6276                 /* A logical name must be a directory  or the full
6277                    specification.  It is only a full specification if
6278                    it is the only component */
6279                 if ((unixptr[seg_len] == '\0') ||
6280                     (unixptr[seg_len+1] == '\0')) {
6281
6282                     /* Is a directory being required? */
6283                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6284                         /* Not a logical name */
6285                         break;
6286                     }
6287
6288
6289                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6290                         /* This must be a directory */
6291                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6292                             strcpy(vmsptr, esa);
6293                             vmslen=strlen(vmsptr);
6294                             vmsptr[vmslen] = ':';
6295                             vmslen++;
6296                             vmsptr[vmslen] = '\0';
6297                             return SS$_NORMAL;
6298                         }
6299                     }
6300
6301                 }
6302
6303
6304                 /* must be dev/directory - ignore version */
6305                 if ((n_len + e_len) != 0)
6306                     break;
6307
6308                 /* transfer the volume */
6309                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6310                     strncpy(vmsptr, v_spec, v_len);
6311                     vmsptr += v_len;
6312                     vmsptr[0] = '\0';
6313                     vmslen += v_len;
6314                 }
6315
6316                 /* unroot the rooted directory */
6317                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6318                     r_spec[0] = '[';
6319                     r_spec[r_len - 1] = ']';
6320
6321                     /* This should not be there, but nothing is perfect */
6322                     if (r_len > 9) {
6323                         cmp = strcmp(&r_spec[1], "000000.");
6324                         if (cmp == 0) {
6325                             r_spec += 7;
6326                             r_spec[7] = '[';
6327                             r_len -= 7;
6328                             if (r_len == 2)
6329                                 r_len = 0;
6330                         }
6331                     }
6332                     if (r_len > 0) {
6333                         strncpy(vmsptr, r_spec, r_len);
6334                         vmsptr += r_len;
6335                         vmslen += r_len;
6336                         vmsptr[0] = '\0';
6337                     }
6338                 }
6339                 /* Bring over the directory. */
6340                 if ((d_len > 0) &&
6341                     ((d_len + vmslen) < vmspath_len)) {
6342                     d_spec[0] = '[';
6343                     d_spec[d_len - 1] = ']';
6344                     if (d_len > 9) {
6345                         cmp = strcmp(&d_spec[1], "000000.");
6346                         if (cmp == 0) {
6347                             d_spec += 7;
6348                             d_spec[7] = '[';
6349                             d_len -= 7;
6350                             if (d_len == 2)
6351                                 d_len = 0;
6352                         }
6353                     }
6354
6355                     if (r_len > 0) {
6356                         /* Remove the redundant root */
6357                         if (r_len > 0) {
6358                             /* remove the ][ */
6359                             vmsptr--;
6360                             vmslen--;
6361                             d_spec++;
6362                             d_len--;
6363                         }
6364                         strncpy(vmsptr, d_spec, d_len);
6365                             vmsptr += d_len;
6366                             vmslen += d_len;
6367                             vmsptr[0] = '\0';
6368                     }
6369                 }
6370                 break;
6371             }
6372         }
6373
6374         PerlMem_free(esa);
6375         PerlMem_free(trn);
6376     }
6377
6378     if (lastslash > unixptr) {
6379     int dotdir_seen;
6380
6381       /* skip leading ./ */
6382       dotdir_seen = 0;
6383       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6384         dotdir_seen = 1;
6385         unixptr++;
6386         unixptr++;
6387       }
6388
6389       /* Are we still in a directory? */
6390       if (unixptr <= lastslash) {
6391         *vmsptr++ = '[';
6392         vmslen = 1;
6393         dir_start = 1;
6394
6395         /* if not backing up, then it is relative forward. */
6396         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6397               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6398           *vmsptr++ = '.';
6399           vmslen++;
6400           dir_dot = 1;
6401           }
6402        }
6403        else {
6404          if (dotdir_seen) {
6405            /* Perl wants an empty directory here to tell the difference
6406             * between a DCL commmand and a filename
6407             */
6408           *vmsptr++ = '[';
6409           *vmsptr++ = ']';
6410           vmslen = 2;
6411         }
6412       }
6413     }
6414     else {
6415       /* Handle two special files . and .. */
6416       if (unixptr[0] == '.') {
6417         if (&unixptr[1] == unixend) {
6418           *vmsptr++ = '[';
6419           *vmsptr++ = ']';
6420           vmslen += 2;
6421           *vmsptr++ = '\0';
6422           return SS$_NORMAL;
6423         }
6424         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6425           *vmsptr++ = '[';
6426           *vmsptr++ = '-';
6427           *vmsptr++ = ']';
6428           vmslen += 3;
6429           *vmsptr++ = '\0';
6430           return SS$_NORMAL;
6431         }
6432       }
6433     }
6434   }
6435   else {        /* Absolute PATH handling */
6436   int sts;
6437   char * nextslash;
6438   int seg_len;
6439     /* Need to find out where root is */
6440
6441     /* In theory, this procedure should never get an absolute POSIX pathname
6442      * that can not be found on the POSIX root.
6443      * In practice, that can not be relied on, and things will show up
6444      * here that are a VMS device name or concealed logical name instead.
6445      * So to make things work, this procedure must be tolerant.
6446      */
6447     esa = PerlMem_malloc(vmspath_len);
6448     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6449
6450     sts = SS$_NORMAL;
6451     nextslash = strchr(&unixptr[1],'/');
6452     seg_len = 0;
6453     if (nextslash != NULL) {
6454     int cmp;
6455       seg_len = nextslash - &unixptr[1];
6456       strncpy(vmspath, unixptr, seg_len + 1);
6457       vmspath[seg_len+1] = 0;
6458       cmp = 1;
6459       if (seg_len == 3) {
6460         cmp = strncmp(vmspath, "dev", 4);
6461         if (cmp == 0) {
6462             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6463             if (sts = SS$_NORMAL)
6464                 return SS$_NORMAL;
6465         }
6466       }
6467       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6468     }
6469
6470     if ($VMS_STATUS_SUCCESS(sts)) {
6471       /* This is verified to be a real path */
6472
6473       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6474       if ($VMS_STATUS_SUCCESS(sts)) {
6475         strcpy(vmspath, esa);
6476         vmslen = strlen(vmspath);
6477         vmsptr = vmspath + vmslen;
6478         unixptr++;
6479         if (unixptr < lastslash) {
6480         char * rptr;
6481           vmsptr--;
6482           *vmsptr++ = '.';
6483           dir_start = 1;
6484           dir_dot = 1;
6485           if (vmslen > 7) {
6486           int cmp;
6487             rptr = vmsptr - 7;
6488             cmp = strcmp(rptr,"000000.");
6489             if (cmp == 0) {
6490               vmslen -= 7;
6491               vmsptr -= 7;
6492               vmsptr[1] = '\0';
6493             } /* removing 6 zeros */
6494           } /* vmslen < 7, no 6 zeros possible */
6495         } /* Not in a directory */
6496       } /* Posix root found */
6497       else {
6498         /* No posix root, fall back to default directory */
6499         strcpy(vmspath, "SYS$DISK:[");
6500         vmsptr = &vmspath[10];
6501         vmslen = 10;
6502         if (unixptr > lastslash) {
6503            *vmsptr = ']';
6504            vmsptr++;
6505            vmslen++;
6506         }
6507         else {
6508            dir_start = 1;
6509         }
6510       }
6511     } /* end of verified real path handling */
6512     else {
6513     int add_6zero;
6514     int islnm;
6515
6516       /* Ok, we have a device or a concealed root that is not in POSIX
6517        * or we have garbage.  Make the best of it.
6518        */
6519
6520       /* Posix to VMS destroyed this, so copy it again */
6521       strncpy(vmspath, &unixptr[1], seg_len);
6522       vmspath[seg_len] = 0;
6523       vmslen = seg_len;
6524       vmsptr = &vmsptr[vmslen];
6525       islnm = 0;
6526
6527       /* Now do we need to add the fake 6 zero directory to it? */
6528       add_6zero = 1;
6529       if ((*lastslash == '/') && (nextslash < lastslash)) {
6530         /* No there is another directory */
6531         add_6zero = 0;
6532       }
6533       else {
6534       int trnend;
6535       int cmp;
6536
6537         /* now we have foo:bar or foo:[000000]bar to decide from */
6538         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6539
6540         if (!islnm && !decc_posix_compliant_pathnames) {
6541
6542             cmp = strncmp("bin", vmspath, 4);
6543             if (cmp == 0) {
6544                 /* bin => SYS$SYSTEM: */
6545                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6546             }
6547             else {
6548                 /* tmp => SYS$SCRATCH: */
6549                 cmp = strncmp("tmp", vmspath, 4);
6550                 if (cmp == 0) {
6551                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6552                 }
6553             }
6554         }
6555
6556         trnend = islnm ? islnm - 1 : 0;
6557
6558         /* if this was a logical name, ']' or '>' must be present */
6559         /* if not a logical name, then assume a device and hope. */
6560         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6561
6562         /* if log name and trailing '.' then rooted - treat as device */
6563         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6564
6565         /* Fix me, if not a logical name, a device lookup should be
6566          * done to see if the device is file structured.  If the device
6567          * is not file structured, the 6 zeros should not be put on.
6568          *
6569          * As it is, perl is occasionally looking for dev:[000000]tty.
6570          * which looks a little strange.
6571          *
6572          * Not that easy to detect as "/dev" may be file structured with
6573          * special device files.
6574          */
6575
6576         if ((add_6zero == 0) && (*nextslash == '/') &&
6577             (&nextslash[1] == unixend)) {
6578           /* No real directory present */
6579           add_6zero = 1;
6580         }
6581       }
6582
6583       /* Put the device delimiter on */
6584       *vmsptr++ = ':';
6585       vmslen++;
6586       unixptr = nextslash;
6587       unixptr++;
6588
6589       /* Start directory if needed */
6590       if (!islnm || add_6zero) {
6591         *vmsptr++ = '[';
6592         vmslen++;
6593         dir_start = 1;
6594       }
6595
6596       /* add fake 000000] if needed */
6597       if (add_6zero) {
6598         *vmsptr++ = '0';
6599         *vmsptr++ = '0';
6600         *vmsptr++ = '0';
6601         *vmsptr++ = '0';
6602         *vmsptr++ = '0';
6603         *vmsptr++ = '0';
6604         *vmsptr++ = ']';
6605         vmslen += 7;
6606         dir_start = 0;
6607       }
6608
6609     } /* non-POSIX translation */
6610     PerlMem_free(esa);
6611   } /* End of relative/absolute path handling */
6612
6613   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6614   int dash_flag;
6615   int in_cnt;
6616   int out_cnt;
6617
6618     dash_flag = 0;
6619
6620     if (dir_start != 0) {
6621
6622       /* First characters in a directory are handled special */
6623       while ((*unixptr == '/') ||
6624              ((*unixptr == '.') &&
6625               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6626                 (&unixptr[1]==unixend)))) {
6627       int loop_flag;
6628
6629         loop_flag = 0;
6630
6631         /* Skip redundant / in specification */
6632         while ((*unixptr == '/') && (dir_start != 0)) {
6633           loop_flag = 1;
6634           unixptr++;
6635           if (unixptr == lastslash)
6636             break;
6637         }
6638         if (unixptr == lastslash)
6639           break;
6640
6641         /* Skip redundant ./ characters */
6642         while ((*unixptr == '.') &&
6643                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6644           loop_flag = 1;
6645           unixptr++;
6646           if (unixptr == lastslash)
6647             break;
6648           if (*unixptr == '/')
6649             unixptr++;
6650         }
6651         if (unixptr == lastslash)
6652           break;
6653
6654         /* Skip redundant ../ characters */
6655         while ((*unixptr == '.') && (unixptr[1] == '.') &&
6656              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6657           /* Set the backing up flag */
6658           loop_flag = 1;
6659           dir_dot = 0;
6660           dash_flag = 1;
6661           *vmsptr++ = '-';
6662           vmslen++;
6663           unixptr++; /* first . */
6664           unixptr++; /* second . */
6665           if (unixptr == lastslash)
6666             break;
6667           if (*unixptr == '/') /* The slash */
6668             unixptr++;
6669         }
6670         if (unixptr == lastslash)
6671           break;
6672
6673         /* To do: Perl expects /.../ to be translated to [...] on VMS */
6674         /* Not needed when VMS is pretending to be UNIX. */
6675
6676         /* Is this loop stuck because of too many dots? */
6677         if (loop_flag == 0) {
6678           /* Exit the loop and pass the rest through */
6679           break;
6680         }
6681       }
6682
6683       /* Are we done with directories yet? */
6684       if (unixptr >= lastslash) {
6685
6686         /* Watch out for trailing dots */
6687         if (dir_dot != 0) {
6688             vmslen --;
6689             vmsptr--;
6690         }
6691         *vmsptr++ = ']';
6692         vmslen++;
6693         dash_flag = 0;
6694         dir_start = 0;
6695         if (*unixptr == '/')
6696           unixptr++;
6697       }
6698       else {
6699         /* Have we stopped backing up? */
6700         if (dash_flag) {
6701           *vmsptr++ = '.';
6702           vmslen++;
6703           dash_flag = 0;
6704           /* dir_start continues to be = 1 */
6705         }
6706         if (*unixptr == '-') {
6707           *vmsptr++ = '^';
6708           *vmsptr++ = *unixptr++;
6709           vmslen += 2;
6710           dir_start = 0;
6711
6712           /* Now are we done with directories yet? */
6713           if (unixptr >= lastslash) {
6714
6715             /* Watch out for trailing dots */
6716             if (dir_dot != 0) {
6717               vmslen --;
6718               vmsptr--;
6719             }
6720
6721             *vmsptr++ = ']';
6722             vmslen++;
6723             dash_flag = 0;
6724             dir_start = 0;
6725           }
6726         }
6727       }
6728     }
6729
6730     /* All done? */
6731     if (unixptr >= unixend)
6732       break;
6733
6734     /* Normal characters - More EFS work probably needed */
6735     dir_start = 0;
6736     dir_dot = 0;
6737
6738     switch(*unixptr) {
6739     case '/':
6740         /* remove multiple / */
6741         while (unixptr[1] == '/') {
6742            unixptr++;
6743         }
6744         if (unixptr == lastslash) {
6745           /* Watch out for trailing dots */
6746           if (dir_dot != 0) {
6747             vmslen --;
6748             vmsptr--;
6749           }
6750           *vmsptr++ = ']';
6751         }
6752         else {
6753           dir_start = 1;
6754           *vmsptr++ = '.';
6755           dir_dot = 1;
6756
6757           /* To do: Perl expects /.../ to be translated to [...] on VMS */
6758           /* Not needed when VMS is pretending to be UNIX. */
6759
6760         }
6761         dash_flag = 0;
6762         if (unixptr != unixend)
6763           unixptr++;
6764         vmslen++;
6765         break;
6766     case '.':
6767         if ((unixptr < lastdot) || (unixptr < lastslash) ||
6768             (&unixptr[1] == unixend)) {
6769           *vmsptr++ = '^';
6770           *vmsptr++ = '.';
6771           vmslen += 2;
6772           unixptr++;
6773
6774           /* trailing dot ==> '^..' on VMS */
6775           if (unixptr == unixend) {
6776             *vmsptr++ = '.';
6777             vmslen++;
6778             unixptr++;
6779           }
6780           break;
6781         }
6782
6783         *vmsptr++ = *unixptr++;
6784         vmslen ++;
6785         break;
6786     case '"':
6787         if (quoted && (&unixptr[1] == unixend)) {
6788             unixptr++;
6789             break;
6790         }
6791         in_cnt = copy_expand_unix_filename_escape
6792                 (vmsptr, unixptr, &out_cnt, utf8_fl);
6793         vmsptr += out_cnt;
6794         unixptr += in_cnt;
6795         break;
6796     case '~':
6797     case ';':
6798     case '\\':
6799     case '?':
6800     case ' ':
6801     default:
6802         in_cnt = copy_expand_unix_filename_escape
6803                 (vmsptr, unixptr, &out_cnt, utf8_fl);
6804         vmsptr += out_cnt;
6805         unixptr += in_cnt;
6806         break;
6807     }
6808   }
6809
6810   /* Make sure directory is closed */
6811   if (unixptr == lastslash) {
6812     char *vmsptr2;
6813     vmsptr2 = vmsptr - 1;
6814
6815     if (*vmsptr2 != ']') {
6816       *vmsptr2--;
6817
6818       /* directories do not end in a dot bracket */
6819       if (*vmsptr2 == '.') {
6820         vmsptr2--;
6821
6822         /* ^. is allowed */
6823         if (*vmsptr2 != '^') {
6824           vmsptr--; /* back up over the dot */
6825         }
6826       }
6827       *vmsptr++ = ']';
6828     }
6829   }
6830   else {
6831     char *vmsptr2;
6832     /* Add a trailing dot if a file with no extension */
6833     vmsptr2 = vmsptr - 1;
6834     if ((vmslen > 1) &&
6835         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6836         (*vmsptr2 != ')') && (*lastdot != '.')) {
6837         *vmsptr++ = '.';
6838         vmslen++;
6839     }
6840   }
6841
6842   *vmsptr = '\0';
6843   return SS$_NORMAL;
6844 }
6845 #endif
6846
6847  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
6848 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
6849 {
6850 char * result;
6851 int utf8_flag;
6852
6853    /* If a UTF8 flag is being passed, honor it */
6854    utf8_flag = 0;
6855    if (utf8_fl != NULL) {
6856      utf8_flag = *utf8_fl;
6857     *utf8_fl = 0;
6858    }
6859
6860    if (utf8_flag) {
6861      /* If there is a possibility of UTF8, then if any UTF8 characters
6862         are present, then they must be converted to VTF-7
6863       */
6864      result = strcpy(rslt, path); /* FIX-ME */
6865    }
6866    else
6867      result = strcpy(rslt, path);
6868
6869    return result;
6870 }
6871
6872
6873 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
6874 static char *mp_do_tovmsspec
6875    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
6876   static char __tovmsspec_retbuf[VMS_MAXRSS];
6877   char *rslt, *dirend;
6878   char *lastdot;
6879   char *vms_delim;
6880   register char *cp1;
6881   const char *cp2;
6882   unsigned long int infront = 0, hasdir = 1;
6883   int rslt_len;
6884   int no_type_seen;
6885   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6886   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6887
6888   if (path == NULL) return NULL;
6889   rslt_len = VMS_MAXRSS-1;
6890   if (buf) rslt = buf;
6891   else if (ts) Newx(rslt, VMS_MAXRSS, char);
6892   else rslt = __tovmsspec_retbuf;
6893
6894   /* '.' and '..' are "[]" and "[-]" for a quick check */
6895   if (path[0] == '.') {
6896     if (path[1] == '\0') {
6897       strcpy(rslt,"[]");
6898       if (utf8_flag != NULL)
6899         *utf8_flag = 0;
6900       return rslt;
6901     }
6902     else {
6903       if (path[1] == '.' && path[2] == '\0') {
6904         strcpy(rslt,"[-]");
6905         if (utf8_flag != NULL)
6906            *utf8_flag = 0;
6907         return rslt;
6908       }
6909     }
6910   }
6911
6912    /* Posix specifications are now a native VMS format */
6913   /*--------------------------------------------------*/
6914 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6915   if (decc_posix_compliant_pathnames) {
6916     if (strncmp(path,"\"^UP^",5) == 0) {
6917       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
6918       return rslt;
6919     }
6920   }
6921 #endif
6922
6923   /* This is really the only way to see if this is already in VMS format */
6924   sts = vms_split_path
6925        (path,
6926         &v_spec,
6927         &v_len,
6928         &r_spec,
6929         &r_len,
6930         &d_spec,
6931         &d_len,
6932         &n_spec,
6933         &n_len,
6934         &e_spec,
6935         &e_len,
6936         &vs_spec,
6937         &vs_len);
6938   if (sts == 0) {
6939     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
6940        replacement, because the above parse just took care of most of
6941        what is needed to do vmspath when the specification is already
6942        in VMS format.
6943
6944        And if it is not already, it is easier to do the conversion as
6945        part of this routine than to call this routine and then work on
6946        the result.
6947      */
6948
6949     /* If VMS punctuation was found, it is already VMS format */
6950     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
6951       if (utf8_flag != NULL)
6952         *utf8_flag = 0;
6953       strcpy(rslt, path);
6954       return rslt;
6955     }
6956     /* Now, what to do with trailing "." cases where there is no
6957        extension?  If this is a UNIX specification, and EFS characters
6958        are enabled, then the trailing "." should be converted to a "^.".
6959        But if this was already a VMS specification, then it should be
6960        left alone.
6961
6962        So in the case of ambiguity, leave the specification alone.
6963      */
6964
6965
6966     /* If there is a possibility of UTF8, then if any UTF8 characters
6967         are present, then they must be converted to VTF-7
6968      */
6969     if (utf8_flag != NULL)
6970       *utf8_flag = 0;
6971     strcpy(rslt, path);
6972     return rslt;
6973   }
6974
6975   dirend = strrchr(path,'/');
6976
6977   if (dirend == NULL) {
6978      /* If we get here with no UNIX directory delimiters, then this is
6979         not a complete file specification, either garbage a UNIX glob
6980         specification that can not be converted to a VMS wildcard, or
6981         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
6982         so apparently other programs expect this also.
6983
6984         utf8 flag setting needs to be preserved.
6985       */
6986       strcpy(rslt, path);
6987       return rslt;
6988   }
6989
6990 /* If POSIX mode active, handle the conversion */
6991 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6992   if (decc_efs_charset) {
6993     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
6994     return rslt;
6995   }
6996 #endif
6997
6998   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
6999     if (!*(dirend+2)) dirend +=2;
7000     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7001     if (decc_efs_charset == 0) {
7002       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7003     }
7004   }
7005
7006   cp1 = rslt;
7007   cp2 = path;
7008   lastdot = strrchr(cp2,'.');
7009   if (*cp2 == '/') {
7010     char *trndev;
7011     int islnm, rooted;
7012     STRLEN trnend;
7013
7014     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7015     if (!*(cp2+1)) {
7016       if (decc_disable_posix_root) {
7017         strcpy(rslt,"sys$disk:[000000]");
7018       }
7019       else {
7020         strcpy(rslt,"sys$posix_root:[000000]");
7021       }
7022       if (utf8_flag != NULL)
7023         *utf8_flag = 0;
7024       return rslt;
7025     }
7026     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7027     *cp1 = '\0';
7028     trndev = PerlMem_malloc(VMS_MAXRSS);
7029     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7030     islnm =  my_trnlnm(rslt,trndev,0);
7031
7032      /* DECC special handling */
7033     if (!islnm) {
7034       if (strcmp(rslt,"bin") == 0) {
7035         strcpy(rslt,"sys$system");
7036         cp1 = rslt + 10;
7037         *cp1 = 0;
7038         islnm =  my_trnlnm(rslt,trndev,0);
7039       }
7040       else if (strcmp(rslt,"tmp") == 0) {
7041         strcpy(rslt,"sys$scratch");
7042         cp1 = rslt + 11;
7043         *cp1 = 0;
7044         islnm =  my_trnlnm(rslt,trndev,0);
7045       }
7046       else if (!decc_disable_posix_root) {
7047         strcpy(rslt, "sys$posix_root");
7048         cp1 = rslt + 13;
7049         *cp1 = 0;
7050         cp2 = path;
7051         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7052         islnm =  my_trnlnm(rslt,trndev,0);
7053       }
7054       else if (strcmp(rslt,"dev") == 0) {
7055         if (strncmp(cp2,"/null", 5) == 0) {
7056           if ((cp2[5] == 0) || (cp2[5] == '/')) {
7057             strcpy(rslt,"NLA0");
7058             cp1 = rslt + 4;
7059             *cp1 = 0;
7060             cp2 = cp2 + 5;
7061             islnm =  my_trnlnm(rslt,trndev,0);
7062           }
7063         }
7064       }
7065     }
7066
7067     trnend = islnm ? strlen(trndev) - 1 : 0;
7068     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7069     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7070     /* If the first element of the path is a logical name, determine
7071      * whether it has to be translated so we can add more directories. */
7072     if (!islnm || rooted) {
7073       *(cp1++) = ':';
7074       *(cp1++) = '[';
7075       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7076       else cp2++;
7077     }
7078     else {
7079       if (cp2 != dirend) {
7080         strcpy(rslt,trndev);
7081         cp1 = rslt + trnend;
7082         if (*cp2 != 0) {
7083           *(cp1++) = '.';
7084           cp2++;
7085         }
7086       }
7087       else {
7088         if (decc_disable_posix_root) {
7089           *(cp1++) = ':';
7090           hasdir = 0;
7091         }
7092       }
7093     }
7094     PerlMem_free(trndev);
7095   }
7096   else {
7097     *(cp1++) = '[';
7098     if (*cp2 == '.') {
7099       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7100         cp2 += 2;         /* skip over "./" - it's redundant */
7101         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
7102       }
7103       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7104         *(cp1++) = '-';                                 /* "../" --> "-" */
7105         cp2 += 3;
7106       }
7107       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7108                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7109         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7110         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7111         cp2 += 4;
7112       }
7113       else if ((cp2 != lastdot) || (lastdot < dirend)) {
7114         /* Escape the extra dots in EFS file specifications */
7115         *(cp1++) = '^';
7116       }
7117       if (cp2 > dirend) cp2 = dirend;
7118     }
7119     else *(cp1++) = '.';
7120   }
7121   for (; cp2 < dirend; cp2++) {
7122     if (*cp2 == '/') {
7123       if (*(cp2-1) == '/') continue;
7124       if (*(cp1-1) != '.') *(cp1++) = '.';
7125       infront = 0;
7126     }
7127     else if (!infront && *cp2 == '.') {
7128       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7129       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
7130       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7131         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7132         else if (*(cp1-2) == '[') *(cp1-1) = '-';
7133         else {  /* back up over previous directory name */
7134           cp1--;
7135           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7136           if (*(cp1-1) == '[') {
7137             memcpy(cp1,"000000.",7);
7138             cp1 += 7;
7139           }
7140         }
7141         cp2 += 2;
7142         if (cp2 == dirend) break;
7143       }
7144       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7145                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7146         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7147         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7148         if (!*(cp2+3)) {
7149           *(cp1++) = '.';  /* Simulate trailing '/' */
7150           cp2 += 2;  /* for loop will incr this to == dirend */
7151         }
7152         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
7153       }
7154       else {
7155         if (decc_efs_charset == 0)
7156           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
7157         else {
7158           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
7159           *(cp1++) = '.';
7160         }
7161       }
7162     }
7163     else {
7164       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
7165       if (*cp2 == '.') {
7166         if (decc_efs_charset == 0)
7167           *(cp1++) = '_';
7168         else {
7169           *(cp1++) = '^';
7170           *(cp1++) = '.';
7171         }
7172       }
7173       else                  *(cp1++) =  *cp2;
7174       infront = 1;
7175     }
7176   }
7177   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7178   if (hasdir) *(cp1++) = ']';
7179   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
7180   /* fixme for ODS5 */
7181   no_type_seen = 0;
7182   if (cp2 > lastdot)
7183     no_type_seen = 1;
7184   while (*cp2) {
7185     switch(*cp2) {
7186     case '?':
7187         if (decc_efs_charset == 0)
7188           *(cp1++) = '%';
7189         else
7190           *(cp1++) = '?';
7191         cp2++;
7192     case ' ':
7193         *(cp1)++ = '^';
7194         *(cp1)++ = '_';
7195         cp2++;
7196         break;
7197     case '.':
7198         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7199             decc_readdir_dropdotnotype) {
7200           *(cp1)++ = '^';
7201           *(cp1)++ = '.';
7202           cp2++;
7203
7204           /* trailing dot ==> '^..' on VMS */
7205           if (*cp2 == '\0') {
7206             *(cp1++) = '.';
7207             no_type_seen = 0;
7208           }
7209         }
7210         else {
7211           *(cp1++) = *(cp2++);
7212           no_type_seen = 0;
7213         }
7214         break;
7215     case '$':
7216          /* This could be a macro to be passed through */
7217         *(cp1++) = *(cp2++);
7218         if (*cp2 == '(') {
7219         const char * save_cp2;
7220         char * save_cp1;
7221         int is_macro;
7222
7223             /* paranoid check */
7224             save_cp2 = cp2;
7225             save_cp1 = cp1;
7226             is_macro = 0;
7227
7228             /* Test through */
7229             *(cp1++) = *(cp2++);
7230             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7231                 *(cp1++) = *(cp2++);
7232                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7233                     *(cp1++) = *(cp2++);
7234                 }
7235                 if (*cp2 == ')') {
7236                     *(cp1++) = *(cp2++);
7237                     is_macro = 1;
7238                 }
7239             }
7240             if (is_macro == 0) {
7241                 /* Not really a macro - never mind */
7242                 cp2 = save_cp2;
7243                 cp1 = save_cp1;
7244             }
7245         }
7246         break;
7247     case '\"':
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         *(cp1++) = '^';
7271         *(cp1++) = *(cp2++);
7272         break;
7273     case ';':
7274         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7275          * which is wrong.  UNIX notation should be ".dir." unless
7276          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7277          * changing this behavior could break more things at this time.
7278          * efs character set effectively does not allow "." to be a version
7279          * delimiter as a further complication about changing this.
7280          */
7281         if (decc_filename_unix_report != 0) {
7282           *(cp1++) = '^';
7283         }
7284         *(cp1++) = *(cp2++);
7285         break;
7286     default:
7287         *(cp1++) = *(cp2++);
7288     }
7289   }
7290   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7291   char *lcp1;
7292     lcp1 = cp1;
7293     lcp1--;
7294      /* Fix me for "^]", but that requires making sure that you do
7295       * not back up past the start of the filename
7296       */
7297     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7298       *cp1++ = '.';
7299   }
7300   *cp1 = '\0';
7301
7302   if (utf8_flag != NULL)
7303     *utf8_flag = 0;
7304   return rslt;
7305
7306 }  /* end of do_tovmsspec() */
7307 /*}}}*/
7308 /* External entry points */
7309 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7310   { return do_tovmsspec(path,buf,0,NULL); }
7311 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7312   { return do_tovmsspec(path,buf,1,NULL); }
7313 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7314   { return do_tovmsspec(path,buf,0,utf8_fl); }
7315 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7316   { return do_tovmsspec(path,buf,1,utf8_fl); }
7317
7318 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7319 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7320   static char __tovmspath_retbuf[VMS_MAXRSS];
7321   int vmslen;
7322   char *pathified, *vmsified, *cp;
7323
7324   if (path == NULL) return NULL;
7325   pathified = PerlMem_malloc(VMS_MAXRSS);
7326   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7327   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7328     PerlMem_free(pathified);
7329     return NULL;
7330   }
7331
7332   vmsified = NULL;
7333   if (buf == NULL)
7334      Newx(vmsified, VMS_MAXRSS, char);
7335   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7336     PerlMem_free(pathified);
7337     if (vmsified) Safefree(vmsified);
7338     return NULL;
7339   }
7340   PerlMem_free(pathified);
7341   if (buf) {
7342     return buf;
7343   }
7344   else if (ts) {
7345     vmslen = strlen(vmsified);
7346     Newx(cp,vmslen+1,char);
7347     memcpy(cp,vmsified,vmslen);
7348     cp[vmslen] = '\0';
7349     Safefree(vmsified);
7350     return cp;
7351   }
7352   else {
7353     strcpy(__tovmspath_retbuf,vmsified);
7354     Safefree(vmsified);
7355     return __tovmspath_retbuf;
7356   }
7357
7358 }  /* end of do_tovmspath() */
7359 /*}}}*/
7360 /* External entry points */
7361 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7362   { return do_tovmspath(path,buf,0, NULL); }
7363 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7364   { return do_tovmspath(path,buf,1, NULL); }
7365 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7366   { return do_tovmspath(path,buf,0,utf8_fl); }
7367 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7368   { return do_tovmspath(path,buf,1,utf8_fl); }
7369
7370
7371 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7372 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7373   static char __tounixpath_retbuf[VMS_MAXRSS];
7374   int unixlen;
7375   char *pathified, *unixified, *cp;
7376
7377   if (path == NULL) return NULL;
7378   pathified = PerlMem_malloc(VMS_MAXRSS);
7379   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7380   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7381     PerlMem_free(pathified);
7382     return NULL;
7383   }
7384
7385   unixified = NULL;
7386   if (buf == NULL) {
7387       Newx(unixified, VMS_MAXRSS, char);
7388   }
7389   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7390     PerlMem_free(pathified);
7391     if (unixified) Safefree(unixified);
7392     return NULL;
7393   }
7394   PerlMem_free(pathified);
7395   if (buf) {
7396     return buf;
7397   }
7398   else if (ts) {
7399     unixlen = strlen(unixified);
7400     Newx(cp,unixlen+1,char);
7401     memcpy(cp,unixified,unixlen);
7402     cp[unixlen] = '\0';
7403     Safefree(unixified);
7404     return cp;
7405   }
7406   else {
7407     strcpy(__tounixpath_retbuf,unixified);
7408     Safefree(unixified);
7409     return __tounixpath_retbuf;
7410   }
7411
7412 }  /* end of do_tounixpath() */
7413 /*}}}*/
7414 /* External entry points */
7415 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7416   { return do_tounixpath(path,buf,0,NULL); }
7417 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7418   { return do_tounixpath(path,buf,1,NULL); }
7419 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7420   { return do_tounixpath(path,buf,0,utf8_fl); }
7421 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7422   { return do_tounixpath(path,buf,1,utf8_fl); }
7423
7424 /*
7425  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
7426  *
7427  *****************************************************************************
7428  *                                                                           *
7429  *  Copyright (C) 1989-1994 by                                               *
7430  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
7431  *                                                                           *
7432  *  Permission is hereby  granted for the reproduction of this software,     *
7433  *  on condition that this copyright notice is included in the reproduction, *
7434  *  and that such reproduction is not for purposes of profit or material     *
7435  *  gain.                                                                    *
7436  *                                                                           *
7437  *  27-Aug-1994 Modified for inclusion in perl5                              *
7438  *              by Charles Bailey  bailey@newman.upenn.edu                   *
7439  *****************************************************************************
7440  */
7441
7442 /*
7443  * getredirection() is intended to aid in porting C programs
7444  * to VMS (Vax-11 C).  The native VMS environment does not support
7445  * '>' and '<' I/O redirection, or command line wild card expansion,
7446  * or a command line pipe mechanism using the '|' AND background
7447  * command execution '&'.  All of these capabilities are provided to any
7448  * C program which calls this procedure as the first thing in the
7449  * main program.
7450  * The piping mechanism will probably work with almost any 'filter' type
7451  * of program.  With suitable modification, it may useful for other
7452  * portability problems as well.
7453  *
7454  * Author:  Mark Pizzolato      mark@infocomm.com
7455  */
7456 struct list_item
7457     {
7458     struct list_item *next;
7459     char *value;
7460     };
7461
7462 static void add_item(struct list_item **head,
7463                      struct list_item **tail,
7464                      char *value,
7465                      int *count);
7466
7467 static void mp_expand_wild_cards(pTHX_ char *item,
7468                                 struct list_item **head,
7469                                 struct list_item **tail,
7470                                 int *count);
7471
7472 static int background_process(pTHX_ int argc, char **argv);
7473
7474 static void pipe_and_fork(pTHX_ char **cmargv);
7475
7476 /*{{{ void getredirection(int *ac, char ***av)*/
7477 static void
7478 mp_getredirection(pTHX_ int *ac, char ***av)
7479 /*
7480  * Process vms redirection arg's.  Exit if any error is seen.
7481  * If getredirection() processes an argument, it is erased
7482  * from the vector.  getredirection() returns a new argc and argv value.
7483  * In the event that a background command is requested (by a trailing "&"),
7484  * this routine creates a background subprocess, and simply exits the program.
7485  *
7486  * Warning: do not try to simplify the code for vms.  The code
7487  * presupposes that getredirection() is called before any data is
7488  * read from stdin or written to stdout.
7489  *
7490  * Normal usage is as follows:
7491  *
7492  *      main(argc, argv)
7493  *      int             argc;
7494  *      char            *argv[];
7495  *      {
7496  *              getredirection(&argc, &argv);
7497  *      }
7498  */
7499 {
7500     int                 argc = *ac;     /* Argument Count         */
7501     char                **argv = *av;   /* Argument Vector        */
7502     char                *ap;            /* Argument pointer       */
7503     int                 j;              /* argv[] index           */
7504     int                 item_count = 0; /* Count of Items in List */
7505     struct list_item    *list_head = 0; /* First Item in List       */
7506     struct list_item    *list_tail;     /* Last Item in List        */
7507     char                *in = NULL;     /* Input File Name          */
7508     char                *out = NULL;    /* Output File Name         */
7509     char                *outmode = "w"; /* Mode to Open Output File */
7510     char                *err = NULL;    /* Error File Name          */
7511     char                *errmode = "w"; /* Mode to Open Error File  */
7512     int                 cmargc = 0;     /* Piped Command Arg Count  */
7513     char                **cmargv = NULL;/* Piped Command Arg Vector */
7514
7515     /*
7516      * First handle the case where the last thing on the line ends with
7517      * a '&'.  This indicates the desire for the command to be run in a
7518      * subprocess, so we satisfy that desire.
7519      */
7520     ap = argv[argc-1];
7521     if (0 == strcmp("&", ap))
7522        exit(background_process(aTHX_ --argc, argv));
7523     if (*ap && '&' == ap[strlen(ap)-1])
7524         {
7525         ap[strlen(ap)-1] = '\0';
7526        exit(background_process(aTHX_ argc, argv));
7527         }
7528     /*
7529      * Now we handle the general redirection cases that involve '>', '>>',
7530      * '<', and pipes '|'.
7531      */
7532     for (j = 0; j < argc; ++j)
7533         {
7534         if (0 == strcmp("<", argv[j]))
7535             {
7536             if (j+1 >= argc)
7537                 {
7538                 fprintf(stderr,"No input file after < on command line");
7539                 exit(LIB$_WRONUMARG);
7540                 }
7541             in = argv[++j];
7542             continue;
7543             }
7544         if ('<' == *(ap = argv[j]))
7545             {
7546             in = 1 + ap;
7547             continue;
7548             }
7549         if (0 == strcmp(">", ap))
7550             {
7551             if (j+1 >= argc)
7552                 {
7553                 fprintf(stderr,"No output file after > on command line");
7554                 exit(LIB$_WRONUMARG);
7555                 }
7556             out = argv[++j];
7557             continue;
7558             }
7559         if ('>' == *ap)
7560             {
7561             if ('>' == ap[1])
7562                 {
7563                 outmode = "a";
7564                 if ('\0' == ap[2])
7565                     out = argv[++j];
7566                 else
7567                     out = 2 + ap;
7568                 }
7569             else
7570                 out = 1 + ap;
7571             if (j >= argc)
7572                 {
7573                 fprintf(stderr,"No output file after > or >> on command line");
7574                 exit(LIB$_WRONUMARG);
7575                 }
7576             continue;
7577             }
7578         if (('2' == *ap) && ('>' == ap[1]))
7579             {
7580             if ('>' == ap[2])
7581                 {
7582                 errmode = "a";
7583                 if ('\0' == ap[3])
7584                     err = argv[++j];
7585                 else
7586                     err = 3 + ap;
7587                 }
7588             else
7589                 if ('\0' == ap[2])
7590                     err = argv[++j];
7591                 else
7592                     err = 2 + ap;
7593             if (j >= argc)
7594                 {
7595                 fprintf(stderr,"No output file after 2> or 2>> on command line");
7596                 exit(LIB$_WRONUMARG);
7597                 }
7598             continue;
7599             }
7600         if (0 == strcmp("|", argv[j]))
7601             {
7602             if (j+1 >= argc)
7603                 {
7604                 fprintf(stderr,"No command into which to pipe on command line");
7605                 exit(LIB$_WRONUMARG);
7606                 }
7607             cmargc = argc-(j+1);
7608             cmargv = &argv[j+1];
7609             argc = j;
7610             continue;
7611             }
7612         if ('|' == *(ap = argv[j]))
7613             {
7614             ++argv[j];
7615             cmargc = argc-j;
7616             cmargv = &argv[j];
7617             argc = j;
7618             continue;
7619             }
7620         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7621         }
7622     /*
7623      * Allocate and fill in the new argument vector, Some Unix's terminate
7624      * the list with an extra null pointer.
7625      */
7626     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7627     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7628     *av = argv;
7629     for (j = 0; j < item_count; ++j, list_head = list_head->next)
7630         argv[j] = list_head->value;
7631     *ac = item_count;
7632     if (cmargv != NULL)
7633         {
7634         if (out != NULL)
7635             {
7636             fprintf(stderr,"'|' and '>' may not both be specified on command line");
7637             exit(LIB$_INVARGORD);
7638             }
7639         pipe_and_fork(aTHX_ cmargv);
7640         }
7641
7642     /* Check for input from a pipe (mailbox) */
7643
7644     if (in == NULL && 1 == isapipe(0))
7645         {
7646         char mbxname[L_tmpnam];
7647         long int bufsize;
7648         long int dvi_item = DVI$_DEVBUFSIZ;
7649         $DESCRIPTOR(mbxnam, "");
7650         $DESCRIPTOR(mbxdevnam, "");
7651
7652         /* Input from a pipe, reopen it in binary mode to disable       */
7653         /* carriage control processing.                                 */
7654
7655         fgetname(stdin, mbxname);
7656         mbxnam.dsc$a_pointer = mbxname;
7657         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7658         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7659         mbxdevnam.dsc$a_pointer = mbxname;
7660         mbxdevnam.dsc$w_length = sizeof(mbxname);
7661         dvi_item = DVI$_DEVNAM;
7662         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7663         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7664         set_errno(0);
7665         set_vaxc_errno(1);
7666         freopen(mbxname, "rb", stdin);
7667         if (errno != 0)
7668             {
7669             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7670             exit(vaxc$errno);
7671             }
7672         }
7673     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7674         {
7675         fprintf(stderr,"Can't open input file %s as stdin",in);
7676         exit(vaxc$errno);
7677         }
7678     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7679         {
7680         fprintf(stderr,"Can't open output file %s as stdout",out);
7681         exit(vaxc$errno);
7682         }
7683         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7684
7685     if (err != NULL) {
7686         if (strcmp(err,"&1") == 0) {
7687             dup2(fileno(stdout), fileno(stderr));
7688             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7689         } else {
7690         FILE *tmperr;
7691         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7692             {
7693             fprintf(stderr,"Can't open error file %s as stderr",err);
7694             exit(vaxc$errno);
7695             }
7696             fclose(tmperr);
7697            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7698                 {
7699                 exit(vaxc$errno);
7700                 }
7701             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7702         }
7703         }
7704 #ifdef ARGPROC_DEBUG
7705     PerlIO_printf(Perl_debug_log, "Arglist:\n");
7706     for (j = 0; j < *ac;  ++j)
7707         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7708 #endif
7709    /* Clear errors we may have hit expanding wildcards, so they don't
7710       show up in Perl's $! later */
7711    set_errno(0); set_vaxc_errno(1);
7712 }  /* end of getredirection() */
7713 /*}}}*/
7714
7715 static void add_item(struct list_item **head,
7716                      struct list_item **tail,
7717                      char *value,
7718                      int *count)
7719 {
7720     if (*head == 0)
7721         {
7722         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7723         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7724         *tail = *head;
7725         }
7726     else {
7727         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7728         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7729         *tail = (*tail)->next;
7730         }
7731     (*tail)->value = value;
7732     ++(*count);
7733 }
7734
7735 static void mp_expand_wild_cards(pTHX_ char *item,
7736                               struct list_item **head,
7737                               struct list_item **tail,
7738                               int *count)
7739 {
7740 int expcount = 0;
7741 unsigned long int context = 0;
7742 int isunix = 0;
7743 int item_len = 0;
7744 char *had_version;
7745 char *had_device;
7746 int had_directory;
7747 char *devdir,*cp;
7748 char *vmsspec;
7749 $DESCRIPTOR(filespec, "");
7750 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
7751 $DESCRIPTOR(resultspec, "");
7752 unsigned long int lff_flags = 0;
7753 int sts;
7754 int rms_sts;
7755
7756 #ifdef VMS_LONGNAME_SUPPORT
7757     lff_flags = LIB$M_FIL_LONG_NAMES;
7758 #endif
7759
7760     for (cp = item; *cp; cp++) {
7761         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
7762         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
7763     }
7764     if (!*cp || isspace(*cp))
7765         {
7766         add_item(head, tail, item, count);
7767         return;
7768         }
7769     else
7770         {
7771      /* "double quoted" wild card expressions pass as is */
7772      /* From DCL that means using e.g.:                  */
7773      /* perl program """perl.*"""                        */
7774      item_len = strlen(item);
7775      if ( '"' == *item && '"' == item[item_len-1] )
7776        {
7777        item++;
7778        item[item_len-2] = '\0';
7779        add_item(head, tail, item, count);
7780        return;
7781        }
7782      }
7783     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
7784     resultspec.dsc$b_class = DSC$K_CLASS_D;
7785     resultspec.dsc$a_pointer = NULL;
7786     vmsspec = PerlMem_malloc(VMS_MAXRSS);
7787     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7788     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
7789       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
7790     if (!isunix || !filespec.dsc$a_pointer)
7791       filespec.dsc$a_pointer = item;
7792     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
7793     /*
7794      * Only return version specs, if the caller specified a version
7795      */
7796     had_version = strchr(item, ';');
7797     /*
7798      * Only return device and directory specs, if the caller specifed either.
7799      */
7800     had_device = strchr(item, ':');
7801     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
7802
7803     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
7804                                  (&filespec, &resultspec, &context,
7805                                   &defaultspec, 0, &rms_sts, &lff_flags)))
7806         {
7807         char *string;
7808         char *c;
7809
7810         string = PerlMem_malloc(resultspec.dsc$w_length+1);
7811         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7812         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
7813         string[resultspec.dsc$w_length] = '\0';
7814         if (NULL == had_version)
7815             *(strrchr(string, ';')) = '\0';
7816         if ((!had_directory) && (had_device == NULL))
7817             {
7818             if (NULL == (devdir = strrchr(string, ']')))
7819                 devdir = strrchr(string, '>');
7820             strcpy(string, devdir + 1);
7821             }
7822         /*
7823          * Be consistent with what the C RTL has already done to the rest of
7824          * the argv items and lowercase all of these names.
7825          */
7826         if (!decc_efs_case_preserve) {
7827             for (c = string; *c; ++c)
7828             if (isupper(*c))
7829                 *c = tolower(*c);
7830         }
7831         if (isunix) trim_unixpath(string,item,1);
7832         add_item(head, tail, string, count);
7833         ++expcount;
7834     }
7835     PerlMem_free(vmsspec);
7836     if (sts != RMS$_NMF)
7837         {
7838         set_vaxc_errno(sts);
7839         switch (sts)
7840             {
7841             case RMS$_FNF: case RMS$_DNF:
7842                 set_errno(ENOENT); break;
7843             case RMS$_DIR:
7844                 set_errno(ENOTDIR); break;
7845             case RMS$_DEV:
7846                 set_errno(ENODEV); break;
7847             case RMS$_FNM: case RMS$_SYN:
7848                 set_errno(EINVAL); break;
7849             case RMS$_PRV:
7850                 set_errno(EACCES); break;
7851             default:
7852                 _ckvmssts_noperl(sts);
7853             }
7854         }
7855     if (expcount == 0)
7856         add_item(head, tail, item, count);
7857     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
7858     _ckvmssts_noperl(lib$find_file_end(&context));
7859 }
7860
7861 static int child_st[2];/* Event Flag set when child process completes   */
7862
7863 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
7864
7865 static unsigned long int exit_handler(int *status)
7866 {
7867 short iosb[4];
7868
7869     if (0 == child_st[0])
7870         {
7871 #ifdef ARGPROC_DEBUG
7872         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
7873 #endif
7874         fflush(stdout);     /* Have to flush pipe for binary data to    */
7875                             /* terminate properly -- <tp@mccall.com>    */
7876         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
7877         sys$dassgn(child_chan);
7878         fclose(stdout);
7879         sys$synch(0, child_st);
7880         }
7881     return(1);
7882 }
7883
7884 static void sig_child(int chan)
7885 {
7886 #ifdef ARGPROC_DEBUG
7887     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
7888 #endif
7889     if (child_st[0] == 0)
7890         child_st[0] = 1;
7891 }
7892
7893 static struct exit_control_block exit_block =
7894     {
7895     0,
7896     exit_handler,
7897     1,
7898     &exit_block.exit_status,
7899     0
7900     };
7901
7902 static void
7903 pipe_and_fork(pTHX_ char **cmargv)
7904 {
7905     PerlIO *fp;
7906     struct dsc$descriptor_s *vmscmd;
7907     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
7908     int sts, j, l, ismcr, quote, tquote = 0;
7909
7910     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
7911     vms_execfree(vmscmd);
7912
7913     j = l = 0;
7914     p = subcmd;
7915     q = cmargv[0];
7916     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
7917               && toupper(*(q+2)) == 'R' && !*(q+3);
7918
7919     while (q && l < MAX_DCL_LINE_LENGTH) {
7920         if (!*q) {
7921             if (j > 0 && quote) {
7922                 *p++ = '"';
7923                 l++;
7924             }
7925             q = cmargv[++j];
7926             if (q) {
7927                 if (ismcr && j > 1) quote = 1;
7928                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
7929                 *p++ = ' ';
7930                 l++;
7931                 if (quote || tquote) {
7932                     *p++ = '"';
7933                     l++;
7934                 }
7935             }
7936         } else {
7937             if ((quote||tquote) && *q == '"') {
7938                 *p++ = '"';
7939                 l++;
7940             }
7941             *p++ = *q++;
7942             l++;
7943         }
7944     }
7945     *p = '\0';
7946
7947     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7948     if (fp == Nullfp) {
7949         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7950     }
7951 }
7952
7953 static int background_process(pTHX_ int argc, char **argv)
7954 {
7955 char command[MAX_DCL_SYMBOL + 1] = "$";
7956 $DESCRIPTOR(value, "");
7957 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7958 static $DESCRIPTOR(null, "NLA0:");
7959 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7960 char pidstring[80];
7961 $DESCRIPTOR(pidstr, "");
7962 int pid;
7963 unsigned long int flags = 17, one = 1, retsts;
7964 int len;
7965
7966     strcat(command, argv[0]);
7967     len = strlen(command);
7968     while (--argc && (len < MAX_DCL_SYMBOL))
7969         {
7970         strcat(command, " \"");
7971         strcat(command, *(++argv));
7972         strcat(command, "\"");
7973         len = strlen(command);
7974         }
7975     value.dsc$a_pointer = command;
7976     value.dsc$w_length = strlen(value.dsc$a_pointer);
7977     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7978     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7979     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7980         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
7981     }
7982     else {
7983         _ckvmssts_noperl(retsts);
7984     }
7985 #ifdef ARGPROC_DEBUG
7986     PerlIO_printf(Perl_debug_log, "%s\n", command);
7987 #endif
7988     sprintf(pidstring, "%08X", pid);
7989     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
7990     pidstr.dsc$a_pointer = pidstring;
7991     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7992     lib$set_symbol(&pidsymbol, &pidstr);
7993     return(SS$_NORMAL);
7994 }
7995 /*}}}*/
7996 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
7997
7998
7999 /* OS-specific initialization at image activation (not thread startup) */
8000 /* Older VAXC header files lack these constants */
8001 #ifndef JPI$_RIGHTS_SIZE
8002 #  define JPI$_RIGHTS_SIZE 817
8003 #endif
8004 #ifndef KGB$M_SUBSYSTEM
8005 #  define KGB$M_SUBSYSTEM 0x8
8006 #endif
8007
8008 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8009
8010 /*{{{void vms_image_init(int *, char ***)*/
8011 void
8012 vms_image_init(int *argcp, char ***argvp)
8013 {
8014   char eqv[LNM$C_NAMLENGTH+1] = "";
8015   unsigned int len, tabct = 8, tabidx = 0;
8016   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8017   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8018   unsigned short int dummy, rlen;
8019   struct dsc$descriptor_s **tabvec;
8020 #if defined(PERL_IMPLICIT_CONTEXT)
8021   pTHX = NULL;
8022 #endif
8023   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8024                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8025                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8026                                  {          0,                0,    0,      0} };
8027
8028 #ifdef KILL_BY_SIGPRC
8029     Perl_csighandler_init();
8030 #endif
8031
8032   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8033   _ckvmssts_noperl(iosb[0]);
8034   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8035     if (iprv[i]) {           /* Running image installed with privs? */
8036       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8037       will_taint = TRUE;
8038       break;
8039     }
8040   }
8041   /* Rights identifiers might trigger tainting as well. */
8042   if (!will_taint && (rlen || rsz)) {
8043     while (rlen < rsz) {
8044       /* We didn't get all the identifiers on the first pass.  Allocate a
8045        * buffer much larger than $GETJPI wants (rsz is size in bytes that
8046        * were needed to hold all identifiers at time of last call; we'll
8047        * allocate that many unsigned long ints), and go back and get 'em.
8048        * If it gave us less than it wanted to despite ample buffer space,
8049        * something's broken.  Is your system missing a system identifier?
8050        */
8051       if (rsz <= jpilist[1].buflen) {
8052          /* Perl_croak accvios when used this early in startup. */
8053          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8054                          rsz, (unsigned long) jpilist[1].buflen,
8055                          "Check your rights database for corruption.\n");
8056          exit(SS$_ABORT);
8057       }
8058       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8059       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8060       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8061       jpilist[1].buflen = rsz * sizeof(unsigned long int);
8062       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8063       _ckvmssts_noperl(iosb[0]);
8064     }
8065     mask = jpilist[1].bufadr;
8066     /* Check attribute flags for each identifier (2nd longword); protected
8067      * subsystem identifiers trigger tainting.
8068      */
8069     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8070       if (mask[i] & KGB$M_SUBSYSTEM) {
8071         will_taint = TRUE;
8072         break;
8073       }
8074     }
8075     if (mask != rlst) PerlMem_free(mask);
8076   }
8077
8078   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8079    * logical, some versions of the CRTL will add a phanthom /000000/
8080    * directory.  This needs to be removed.
8081    */
8082   if (decc_filename_unix_report) {
8083   char * zeros;
8084   int ulen;
8085     ulen = strlen(argvp[0][0]);
8086     if (ulen > 7) {
8087       zeros = strstr(argvp[0][0], "/000000/");
8088       if (zeros != NULL) {
8089         int mlen;
8090         mlen = ulen - (zeros - argvp[0][0]) - 7;
8091         memmove(zeros, &zeros[7], mlen);
8092         ulen = ulen - 7;
8093         argvp[0][0][ulen] = '\0';
8094       }
8095     }
8096     /* It also may have a trailing dot that needs to be removed otherwise
8097      * it will be converted to VMS mode incorrectly.
8098      */
8099     ulen--;
8100     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8101       argvp[0][0][ulen] = '\0';
8102   }
8103
8104   /* We need to use this hack to tell Perl it should run with tainting,
8105    * since its tainting flag may be part of the PL_curinterp struct, which
8106    * hasn't been allocated when vms_image_init() is called.
8107    */
8108   if (will_taint) {
8109     char **newargv, **oldargv;
8110     oldargv = *argvp;
8111     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8112     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8113     newargv[0] = oldargv[0];
8114     newargv[1] = PerlMem_malloc(3 * sizeof(char));
8115     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8116     strcpy(newargv[1], "-T");
8117     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8118     (*argcp)++;
8119     newargv[*argcp] = NULL;
8120     /* We orphan the old argv, since we don't know where it's come from,
8121      * so we don't know how to free it.
8122      */
8123     *argvp = newargv;
8124   }
8125   else {  /* Did user explicitly request tainting? */
8126     int i;
8127     char *cp, **av = *argvp;
8128     for (i = 1; i < *argcp; i++) {
8129       if (*av[i] != '-') break;
8130       for (cp = av[i]+1; *cp; cp++) {
8131         if (*cp == 'T') { will_taint = 1; break; }
8132         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8133                   strchr("DFIiMmx",*cp)) break;
8134       }
8135       if (will_taint) break;
8136     }
8137   }
8138
8139   for (tabidx = 0;
8140        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8141        tabidx++) {
8142     if (!tabidx) {
8143       tabvec = (struct dsc$descriptor_s **)
8144             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8145       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8146     }
8147     else if (tabidx >= tabct) {
8148       tabct += 8;
8149       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8150       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8151     }
8152     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8153     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8154     tabvec[tabidx]->dsc$w_length  = 0;
8155     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
8156     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
8157     tabvec[tabidx]->dsc$a_pointer = NULL;
8158     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8159   }
8160   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8161
8162   getredirection(argcp,argvp);
8163 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8164   {
8165 # include <reentrancy.h>
8166   decc$set_reentrancy(C$C_MULTITHREAD);
8167   }
8168 #endif
8169   return;
8170 }
8171 /*}}}*/
8172
8173
8174 /* trim_unixpath()
8175  * Trim Unix-style prefix off filespec, so it looks like what a shell
8176  * glob expansion would return (i.e. from specified prefix on, not
8177  * full path).  Note that returned filespec is Unix-style, regardless
8178  * of whether input filespec was VMS-style or Unix-style.
8179  *
8180  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8181  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
8182  * vector of options; at present, only bit 0 is used, and if set tells
8183  * trim unixpath to try the current default directory as a prefix when
8184  * presented with a possibly ambiguous ... wildcard.
8185  *
8186  * Returns !=0 on success, with trimmed filespec replacing contents of
8187  * fspec, and 0 on failure, with contents of fpsec unchanged.
8188  */
8189 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8190 int
8191 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8192 {
8193   char *unixified, *unixwild,
8194        *template, *base, *end, *cp1, *cp2;
8195   register int tmplen, reslen = 0, dirs = 0;
8196
8197   unixwild = PerlMem_malloc(VMS_MAXRSS);
8198   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8199   if (!wildspec || !fspec) return 0;
8200   template = unixwild;
8201   if (strpbrk(wildspec,"]>:") != NULL) {
8202     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8203         PerlMem_free(unixwild);
8204         return 0;
8205     }
8206   }
8207   else {
8208     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8209     unixwild[VMS_MAXRSS-1] = 0;
8210   }
8211   unixified = PerlMem_malloc(VMS_MAXRSS);
8212   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8213   if (strpbrk(fspec,"]>:") != NULL) {
8214     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8215         PerlMem_free(unixwild);
8216         PerlMem_free(unixified);
8217         return 0;
8218     }
8219     else base = unixified;
8220     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8221      * check to see that final result fits into (isn't longer than) fspec */
8222     reslen = strlen(fspec);
8223   }
8224   else base = fspec;
8225
8226   /* No prefix or absolute path on wildcard, so nothing to remove */
8227   if (!*template || *template == '/') {
8228     PerlMem_free(unixwild);
8229     if (base == fspec) {
8230         PerlMem_free(unixified);
8231         return 1;
8232     }
8233     tmplen = strlen(unixified);
8234     if (tmplen > reslen) {
8235         PerlMem_free(unixified);
8236         return 0;  /* not enough space */
8237     }
8238     /* Copy unixified resultant, including trailing NUL */
8239     memmove(fspec,unixified,tmplen+1);
8240     PerlMem_free(unixified);
8241     return 1;
8242   }
8243
8244   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
8245   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8246     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8247     for (cp1 = end ;cp1 >= base; cp1--)
8248       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8249         { cp1++; break; }
8250     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8251     PerlMem_free(unixified);
8252     PerlMem_free(unixwild);
8253     return 1;
8254   }
8255   else {
8256     char *tpl, *lcres;
8257     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8258     int ells = 1, totells, segdirs, match;
8259     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8260                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8261
8262     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8263     totells = ells;
8264     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8265     tpl = PerlMem_malloc(VMS_MAXRSS);
8266     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8267     if (ellipsis == template && opts & 1) {
8268       /* Template begins with an ellipsis.  Since we can't tell how many
8269        * directory names at the front of the resultant to keep for an
8270        * arbitrary starting point, we arbitrarily choose the current
8271        * default directory as a starting point.  If it's there as a prefix,
8272        * clip it off.  If not, fall through and act as if the leading
8273        * ellipsis weren't there (i.e. return shortest possible path that
8274        * could match template).
8275        */
8276       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8277           PerlMem_free(tpl);
8278           PerlMem_free(unixified);
8279           PerlMem_free(unixwild);
8280           return 0;
8281       }
8282       if (!decc_efs_case_preserve) {
8283         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8284           if (_tolower(*cp1) != _tolower(*cp2)) break;
8285       }
8286       segdirs = dirs - totells;  /* Min # of dirs we must have left */
8287       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8288       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8289         memmove(fspec,cp2+1,end - cp2);
8290         PerlMem_free(tpl);
8291         PerlMem_free(unixified);
8292         PerlMem_free(unixwild);
8293         return 1;
8294       }
8295     }
8296     /* First off, back up over constant elements at end of path */
8297     if (dirs) {
8298       for (front = end ; front >= base; front--)
8299          if (*front == '/' && !dirs--) { front++; break; }
8300     }
8301     lcres = PerlMem_malloc(VMS_MAXRSS);
8302     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8303     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8304          cp1++,cp2++) {
8305             if (!decc_efs_case_preserve) {
8306                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
8307             }
8308             else {
8309                 *cp2 = *cp1;
8310             }
8311     }
8312     if (cp1 != '\0') {
8313         PerlMem_free(tpl);
8314         PerlMem_free(unixified);
8315         PerlMem_free(unixwild);
8316         PerlMem_free(lcres);
8317         return 0;  /* Path too long. */
8318     }
8319     lcend = cp2;
8320     *cp2 = '\0';  /* Pick up with memcpy later */
8321     lcfront = lcres + (front - base);
8322     /* Now skip over each ellipsis and try to match the path in front of it. */
8323     while (ells--) {
8324       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8325         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
8326             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
8327       if (cp1 < template) break; /* template started with an ellipsis */
8328       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8329         ellipsis = cp1; continue;
8330       }
8331       wilddsc.dsc$a_pointer = tpl;
8332       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8333       nextell = cp1;
8334       for (segdirs = 0, cp2 = tpl;
8335            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8336            cp1++, cp2++) {
8337          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8338          else {
8339             if (!decc_efs_case_preserve) {
8340               *cp2 = _tolower(*cp1);  /* else lowercase for match */
8341             }
8342             else {
8343               *cp2 = *cp1;  /* else preserve case for match */
8344             }
8345          }
8346          if (*cp2 == '/') segdirs++;
8347       }
8348       if (cp1 != ellipsis - 1) {
8349           PerlMem_free(tpl);
8350           PerlMem_free(unixified);
8351           PerlMem_free(unixwild);
8352           PerlMem_free(lcres);
8353           return 0; /* Path too long */
8354       }
8355       /* Back up at least as many dirs as in template before matching */
8356       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8357         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8358       for (match = 0; cp1 > lcres;) {
8359         resdsc.dsc$a_pointer = cp1;
8360         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8361           match++;
8362           if (match == 1) lcfront = cp1;
8363         }
8364         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8365       }
8366       if (!match) {
8367         PerlMem_free(tpl);
8368         PerlMem_free(unixified);
8369         PerlMem_free(unixwild);
8370         PerlMem_free(lcres);
8371         return 0;  /* Can't find prefix ??? */
8372       }
8373       if (match > 1 && opts & 1) {
8374         /* This ... wildcard could cover more than one set of dirs (i.e.
8375          * a set of similar dir names is repeated).  If the template
8376          * contains more than 1 ..., upstream elements could resolve the
8377          * ambiguity, but it's not worth a full backtracking setup here.
8378          * As a quick heuristic, clip off the current default directory
8379          * if it's present to find the trimmed spec, else use the
8380          * shortest string that this ... could cover.
8381          */
8382         char def[NAM$C_MAXRSS+1], *st;
8383
8384         if (getcwd(def, sizeof def,0) == NULL) {
8385             Safefree(unixified);
8386             Safefree(unixwild);
8387             Safefree(lcres);
8388             Safefree(tpl);
8389             return 0;
8390         }
8391         if (!decc_efs_case_preserve) {
8392           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8393             if (_tolower(*cp1) != _tolower(*cp2)) break;
8394         }
8395         segdirs = dirs - totells;  /* Min # of dirs we must have left */
8396         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8397         if (*cp1 == '\0' && *cp2 == '/') {
8398           memmove(fspec,cp2+1,end - cp2);
8399           PerlMem_free(tpl);
8400           PerlMem_free(unixified);
8401           PerlMem_free(unixwild);
8402           PerlMem_free(lcres);
8403           return 1;
8404         }
8405         /* Nope -- stick with lcfront from above and keep going. */
8406       }
8407     }
8408     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8409     PerlMem_free(tpl);
8410     PerlMem_free(unixified);
8411     PerlMem_free(unixwild);
8412     PerlMem_free(lcres);
8413     return 1;
8414     ellipsis = nextell;
8415   }
8416
8417 }  /* end of trim_unixpath() */
8418 /*}}}*/
8419
8420
8421 /*
8422  *  VMS readdir() routines.
8423  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8424  *
8425  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
8426  *  Minor modifications to original routines.
8427  */
8428
8429 /* readdir may have been redefined by reentr.h, so make sure we get
8430  * the local version for what we do here.
8431  */
8432 #ifdef readdir
8433 # undef readdir
8434 #endif
8435 #if !defined(PERL_IMPLICIT_CONTEXT)
8436 # define readdir Perl_readdir
8437 #else
8438 # define readdir(a) Perl_readdir(aTHX_ a)
8439 #endif
8440
8441     /* Number of elements in vms_versions array */
8442 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
8443
8444 /*
8445  *  Open a directory, return a handle for later use.
8446  */
8447 /*{{{ DIR *opendir(char*name) */
8448 DIR *
8449 Perl_opendir(pTHX_ const char *name)
8450 {
8451     DIR *dd;
8452     char *dir;
8453     Stat_t sb;
8454     int unix_flag;
8455
8456     unix_flag = 0;
8457     if (decc_efs_charset) {
8458         unix_flag = is_unix_filespec(name);
8459     }
8460
8461     Newx(dir, VMS_MAXRSS, char);
8462     if (do_tovmspath(name,dir,0,NULL) == NULL) {
8463       Safefree(dir);
8464       return NULL;
8465     }
8466     /* Check access before stat; otherwise stat does not
8467      * accurately report whether it's a directory.
8468      */
8469     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8470       /* cando_by_name has already set errno */
8471       Safefree(dir);
8472       return NULL;
8473     }
8474     if (flex_stat(dir,&sb) == -1) return NULL;
8475     if (!S_ISDIR(sb.st_mode)) {
8476       Safefree(dir);
8477       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
8478       return NULL;
8479     }
8480     /* Get memory for the handle, and the pattern. */
8481     Newx(dd,1,DIR);
8482     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8483
8484     /* Fill in the fields; mainly playing with the descriptor. */
8485     sprintf(dd->pattern, "%s*.*",dir);
8486     Safefree(dir);
8487     dd->context = 0;
8488     dd->count = 0;
8489     dd->flags = 0;
8490     if (unix_flag)
8491         dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8492     dd->pat.dsc$a_pointer = dd->pattern;
8493     dd->pat.dsc$w_length = strlen(dd->pattern);
8494     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8495     dd->pat.dsc$b_class = DSC$K_CLASS_S;
8496 #if defined(USE_ITHREADS)
8497     Newx(dd->mutex,1,perl_mutex);
8498     MUTEX_INIT( (perl_mutex *) dd->mutex );
8499 #else
8500     dd->mutex = NULL;
8501 #endif
8502
8503     return dd;
8504 }  /* end of opendir() */
8505 /*}}}*/
8506
8507 /*
8508  *  Set the flag to indicate we want versions or not.
8509  */
8510 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8511 void
8512 vmsreaddirversions(DIR *dd, int flag)
8513 {
8514     if (flag)
8515         dd->flags |= PERL_VMSDIR_M_VERSIONS;
8516     else
8517         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8518 }
8519 /*}}}*/
8520
8521 /*
8522  *  Free up an opened directory.
8523  */
8524 /*{{{ void closedir(DIR *dd)*/
8525 void
8526 Perl_closedir(DIR *dd)
8527 {
8528     int sts;
8529
8530     sts = lib$find_file_end(&dd->context);
8531     Safefree(dd->pattern);
8532 #if defined(USE_ITHREADS)
8533     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8534     Safefree(dd->mutex);
8535 #endif
8536     Safefree(dd);
8537 }
8538 /*}}}*/
8539
8540 /*
8541  *  Collect all the version numbers for the current file.
8542  */
8543 static void
8544 collectversions(pTHX_ DIR *dd)
8545 {
8546     struct dsc$descriptor_s     pat;
8547     struct dsc$descriptor_s     res;
8548     struct dirent *e;
8549     char *p, *text, *buff;
8550     int i;
8551     unsigned long context, tmpsts;
8552
8553     /* Convenient shorthand. */
8554     e = &dd->entry;
8555
8556     /* Add the version wildcard, ignoring the "*.*" put on before */
8557     i = strlen(dd->pattern);
8558     Newx(text,i + e->d_namlen + 3,char);
8559     strcpy(text, dd->pattern);
8560     sprintf(&text[i - 3], "%s;*", e->d_name);
8561
8562     /* Set up the pattern descriptor. */
8563     pat.dsc$a_pointer = text;
8564     pat.dsc$w_length = i + e->d_namlen - 1;
8565     pat.dsc$b_dtype = DSC$K_DTYPE_T;
8566     pat.dsc$b_class = DSC$K_CLASS_S;
8567
8568     /* Set up result descriptor. */
8569     Newx(buff, VMS_MAXRSS, char);
8570     res.dsc$a_pointer = buff;
8571     res.dsc$w_length = VMS_MAXRSS - 1;
8572     res.dsc$b_dtype = DSC$K_DTYPE_T;
8573     res.dsc$b_class = DSC$K_CLASS_S;
8574
8575     /* Read files, collecting versions. */
8576     for (context = 0, e->vms_verscount = 0;
8577          e->vms_verscount < VERSIZE(e);
8578          e->vms_verscount++) {
8579         unsigned long rsts;
8580         unsigned long flags = 0;
8581
8582 #ifdef VMS_LONGNAME_SUPPORT
8583         flags = LIB$M_FIL_LONG_NAMES;
8584 #endif
8585         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8586         if (tmpsts == RMS$_NMF || context == 0) break;
8587         _ckvmssts(tmpsts);
8588         buff[VMS_MAXRSS - 1] = '\0';
8589         if ((p = strchr(buff, ';')))
8590             e->vms_versions[e->vms_verscount] = atoi(p + 1);
8591         else
8592             e->vms_versions[e->vms_verscount] = -1;
8593     }
8594
8595     _ckvmssts(lib$find_file_end(&context));
8596     Safefree(text);
8597     Safefree(buff);
8598
8599 }  /* end of collectversions() */
8600
8601 /*
8602  *  Read the next entry from the directory.
8603  */
8604 /*{{{ struct dirent *readdir(DIR *dd)*/
8605 struct dirent *
8606 Perl_readdir(pTHX_ DIR *dd)
8607 {
8608     struct dsc$descriptor_s     res;
8609     char *p, *buff;
8610     unsigned long int tmpsts;
8611     unsigned long rsts;
8612     unsigned long flags = 0;
8613     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8614     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8615
8616     /* Set up result descriptor, and get next file. */
8617     Newx(buff, VMS_MAXRSS, char);
8618     res.dsc$a_pointer = buff;
8619     res.dsc$w_length = VMS_MAXRSS - 1;
8620     res.dsc$b_dtype = DSC$K_DTYPE_T;
8621     res.dsc$b_class = DSC$K_CLASS_S;
8622
8623 #ifdef VMS_LONGNAME_SUPPORT
8624     flags = LIB$M_FIL_LONG_NAMES;
8625 #endif
8626
8627     tmpsts = lib$find_file
8628         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8629     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
8630     if (!(tmpsts & 1)) {
8631       set_vaxc_errno(tmpsts);
8632       switch (tmpsts) {
8633         case RMS$_PRV:
8634           set_errno(EACCES); break;
8635         case RMS$_DEV:
8636           set_errno(ENODEV); break;
8637         case RMS$_DIR:
8638           set_errno(ENOTDIR); break;
8639         case RMS$_FNF: case RMS$_DNF:
8640           set_errno(ENOENT); break;
8641         default:
8642           set_errno(EVMSERR);
8643       }
8644       Safefree(buff);
8645       return NULL;
8646     }
8647     dd->count++;
8648     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8649     if (!decc_efs_case_preserve) {
8650       buff[VMS_MAXRSS - 1] = '\0';
8651       for (p = buff; *p; p++) *p = _tolower(*p);
8652     }
8653     else {
8654       /* we don't want to force to lowercase, just null terminate */
8655       buff[res.dsc$w_length] = '\0';
8656     }
8657     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
8658     *p = '\0';
8659
8660     /* Skip any directory component and just copy the name. */
8661     sts = vms_split_path
8662        (buff,
8663         &v_spec,
8664         &v_len,
8665         &r_spec,
8666         &r_len,
8667         &d_spec,
8668         &d_len,
8669         &n_spec,
8670         &n_len,
8671         &e_spec,
8672         &e_len,
8673         &vs_spec,
8674         &vs_len);
8675
8676     /* Drop NULL extensions on UNIX file specification */
8677     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8678         (e_len == 1) && decc_readdir_dropdotnotype)) {
8679         e_len = 0;
8680         e_spec[0] = '\0';
8681     }
8682
8683     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8684     dd->entry.d_name[n_len + e_len] = '\0';
8685     dd->entry.d_namlen = strlen(dd->entry.d_name);
8686
8687     /* Convert the filename to UNIX format if needed */
8688     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8689
8690         /* Translate the encoded characters. */
8691         /* Fixme: unicode handling could result in embedded 0 characters */
8692         if (strchr(dd->entry.d_name, '^') != NULL) {
8693             char new_name[256];
8694             char * q;
8695             int cnt;
8696             p = dd->entry.d_name;
8697             q = new_name;
8698             while (*p != 0) {
8699                 int x, y;
8700                 x = copy_expand_vms_filename_escape(q, p, &y);
8701                 p += x;
8702                 q += y;
8703                 /* fix-me */
8704                 /* if y > 1, then this is a wide file specification */
8705                 /* Wide file specifications need to be passed in Perl */
8706                 /* counted strings apparently with a unicode flag */
8707             }
8708             *q = 0;
8709             strcpy(dd->entry.d_name, new_name);
8710         }
8711     }
8712
8713     dd->entry.vms_verscount = 0;
8714     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8715     Safefree(buff);
8716     return &dd->entry;
8717
8718 }  /* end of readdir() */
8719 /*}}}*/
8720
8721 /*
8722  *  Read the next entry from the directory -- thread-safe version.
8723  */
8724 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
8725 int
8726 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
8727 {
8728     int retval;
8729
8730     MUTEX_LOCK( (perl_mutex *) dd->mutex );
8731
8732     entry = readdir(dd);
8733     *result = entry;
8734     retval = ( *result == NULL ? errno : 0 );
8735
8736     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
8737
8738     return retval;
8739
8740 }  /* end of readdir_r() */
8741 /*}}}*/
8742
8743 /*
8744  *  Return something that can be used in a seekdir later.
8745  */
8746 /*{{{ long telldir(DIR *dd)*/
8747 long
8748 Perl_telldir(DIR *dd)
8749 {
8750     return dd->count;
8751 }
8752 /*}}}*/
8753
8754 /*
8755  *  Return to a spot where we used to be.  Brute force.
8756  */
8757 /*{{{ void seekdir(DIR *dd,long count)*/
8758 void
8759 Perl_seekdir(pTHX_ DIR *dd, long count)
8760 {
8761     int old_flags;
8762
8763     /* If we haven't done anything yet... */
8764     if (dd->count == 0)
8765         return;
8766
8767     /* Remember some state, and clear it. */
8768     old_flags = dd->flags;
8769     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8770     _ckvmssts(lib$find_file_end(&dd->context));
8771     dd->context = 0;
8772
8773     /* The increment is in readdir(). */
8774     for (dd->count = 0; dd->count < count; )
8775         readdir(dd);
8776
8777     dd->flags = old_flags;
8778
8779 }  /* end of seekdir() */
8780 /*}}}*/
8781
8782 /* VMS subprocess management
8783  *
8784  * my_vfork() - just a vfork(), after setting a flag to record that
8785  * the current script is trying a Unix-style fork/exec.
8786  *
8787  * vms_do_aexec() and vms_do_exec() are called in response to the
8788  * perl 'exec' function.  If this follows a vfork call, then they
8789  * call out the regular perl routines in doio.c which do an
8790  * execvp (for those who really want to try this under VMS).
8791  * Otherwise, they do exactly what the perl docs say exec should
8792  * do - terminate the current script and invoke a new command
8793  * (See below for notes on command syntax.)
8794  *
8795  * do_aspawn() and do_spawn() implement the VMS side of the perl
8796  * 'system' function.
8797  *
8798  * Note on command arguments to perl 'exec' and 'system': When handled
8799  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
8800  * are concatenated to form a DCL command string.  If the first arg
8801  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
8802  * the command string is handed off to DCL directly.  Otherwise,
8803  * the first token of the command is taken as the filespec of an image
8804  * to run.  The filespec is expanded using a default type of '.EXE' and
8805  * the process defaults for device, directory, etc., and if found, the resultant
8806  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
8807  * the command string as parameters.  This is perhaps a bit complicated,
8808  * but I hope it will form a happy medium between what VMS folks expect
8809  * from lib$spawn and what Unix folks expect from exec.
8810  */
8811
8812 static int vfork_called;
8813
8814 /*{{{int my_vfork()*/
8815 int
8816 my_vfork()
8817 {
8818   vfork_called++;
8819   return vfork();
8820 }
8821 /*}}}*/
8822
8823
8824 static void
8825 vms_execfree(struct dsc$descriptor_s *vmscmd)
8826 {
8827   if (vmscmd) {
8828       if (vmscmd->dsc$a_pointer) {
8829           PerlMem_free(vmscmd->dsc$a_pointer);
8830       }
8831       PerlMem_free(vmscmd);
8832   }
8833 }
8834
8835 static char *
8836 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
8837 {
8838   char *junk, *tmps = Nullch;
8839   register size_t cmdlen = 0;
8840   size_t rlen;
8841   register SV **idx;
8842   STRLEN n_a;
8843
8844   idx = mark;
8845   if (really) {
8846     tmps = SvPV(really,rlen);
8847     if (*tmps) {
8848       cmdlen += rlen + 1;
8849       idx++;
8850     }
8851   }
8852
8853   for (idx++; idx <= sp; idx++) {
8854     if (*idx) {
8855       junk = SvPVx(*idx,rlen);
8856       cmdlen += rlen ? rlen + 1 : 0;
8857     }
8858   }
8859   Newx(PL_Cmd, cmdlen+1, char);
8860
8861   if (tmps && *tmps) {
8862     strcpy(PL_Cmd,tmps);
8863     mark++;
8864   }
8865   else *PL_Cmd = '\0';
8866   while (++mark <= sp) {
8867     if (*mark) {
8868       char *s = SvPVx(*mark,n_a);
8869       if (!*s) continue;
8870       if (*PL_Cmd) strcat(PL_Cmd," ");
8871       strcat(PL_Cmd,s);
8872     }
8873   }
8874   return PL_Cmd;
8875
8876 }  /* end of setup_argstr() */
8877
8878
8879 static unsigned long int
8880 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
8881                    struct dsc$descriptor_s **pvmscmd)
8882 {
8883   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
8884   char image_name[NAM$C_MAXRSS+1];
8885   char image_argv[NAM$C_MAXRSS+1];
8886   $DESCRIPTOR(defdsc,".EXE");
8887   $DESCRIPTOR(defdsc2,".");
8888   $DESCRIPTOR(resdsc,resspec);
8889   struct dsc$descriptor_s *vmscmd;
8890   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8891   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
8892   register char *s, *rest, *cp, *wordbreak;
8893   char * cmd;
8894   int cmdlen;
8895   register int isdcl;
8896
8897   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8898   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
8899
8900   /* Make a copy for modification */
8901   cmdlen = strlen(incmd);
8902   cmd = PerlMem_malloc(cmdlen+1);
8903   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
8904   strncpy(cmd, incmd, cmdlen);
8905   cmd[cmdlen] = 0;
8906   image_name[0] = 0;
8907   image_argv[0] = 0;
8908
8909   vmscmd->dsc$a_pointer = NULL;
8910   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
8911   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
8912   vmscmd->dsc$w_length = 0;
8913   if (pvmscmd) *pvmscmd = vmscmd;
8914
8915   if (suggest_quote) *suggest_quote = 0;
8916
8917   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
8918     PerlMem_free(cmd);
8919     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
8920   }
8921
8922   s = cmd;
8923
8924   while (*s && isspace(*s)) s++;
8925
8926   if (*s == '@' || *s == '$') {
8927     vmsspec[0] = *s;  rest = s + 1;
8928     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
8929   }
8930   else { cp = vmsspec; rest = s; }
8931   if (*rest == '.' || *rest == '/') {
8932     char *cp2;
8933     for (cp2 = resspec;
8934          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
8935          rest++, cp2++) *cp2 = *rest;
8936     *cp2 = '\0';
8937     if (do_tovmsspec(resspec,cp,0,NULL)) {
8938       s = vmsspec;
8939       if (*rest) {
8940         for (cp2 = vmsspec + strlen(vmsspec);
8941              *rest && cp2 - vmsspec < sizeof vmsspec;
8942              rest++, cp2++) *cp2 = *rest;
8943         *cp2 = '\0';
8944       }
8945     }
8946   }
8947   /* Intuit whether verb (first word of cmd) is a DCL command:
8948    *   - if first nonspace char is '@', it's a DCL indirection
8949    * otherwise
8950    *   - if verb contains a filespec separator, it's not a DCL command
8951    *   - if it doesn't, caller tells us whether to default to a DCL
8952    *     command, or to a local image unless told it's DCL (by leading '$')
8953    */
8954   if (*s == '@') {
8955       isdcl = 1;
8956       if (suggest_quote) *suggest_quote = 1;
8957   } else {
8958     register char *filespec = strpbrk(s,":<[.;");
8959     rest = wordbreak = strpbrk(s," \"\t/");
8960     if (!wordbreak) wordbreak = s + strlen(s);
8961     if (*s == '$') check_img = 0;
8962     if (filespec && (filespec < wordbreak)) isdcl = 0;
8963     else isdcl = !check_img;
8964   }
8965
8966   if (!isdcl) {
8967     int rsts;
8968     imgdsc.dsc$a_pointer = s;
8969     imgdsc.dsc$w_length = wordbreak - s;
8970     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8971     if (!(retsts&1)) {
8972         _ckvmssts(lib$find_file_end(&cxt));
8973         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8974       if (!(retsts & 1) && *s == '$') {
8975         _ckvmssts(lib$find_file_end(&cxt));
8976         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
8977         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8978         if (!(retsts&1)) {
8979           _ckvmssts(lib$find_file_end(&cxt));
8980           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8981         }
8982       }
8983     }
8984     _ckvmssts(lib$find_file_end(&cxt));
8985
8986     if (retsts & 1) {
8987       FILE *fp;
8988       s = resspec;
8989       while (*s && !isspace(*s)) s++;
8990       *s = '\0';
8991
8992       /* check that it's really not DCL with no file extension */
8993       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8994       if (fp) {
8995         char b[256] = {0,0,0,0};
8996         read(fileno(fp), b, 256);
8997         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
8998         if (isdcl) {
8999           int shebang_len;
9000
9001           /* Check for script */
9002           shebang_len = 0;
9003           if ((b[0] == '#') && (b[1] == '!'))
9004              shebang_len = 2;
9005 #ifdef ALTERNATE_SHEBANG
9006           else {
9007             shebang_len = strlen(ALTERNATE_SHEBANG);
9008             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9009               char * perlstr;
9010                 perlstr = strstr("perl",b);
9011                 if (perlstr == NULL)
9012                   shebang_len = 0;
9013             }
9014             else
9015               shebang_len = 0;
9016           }
9017 #endif
9018
9019           if (shebang_len > 0) {
9020           int i;
9021           int j;
9022           char tmpspec[NAM$C_MAXRSS + 1];
9023
9024             i = shebang_len;
9025              /* Image is following after white space */
9026             /*--------------------------------------*/
9027             while (isprint(b[i]) && isspace(b[i]))
9028                 i++;
9029
9030             j = 0;
9031             while (isprint(b[i]) && !isspace(b[i])) {
9032                 tmpspec[j++] = b[i++];
9033                 if (j >= NAM$C_MAXRSS)
9034                    break;
9035             }
9036             tmpspec[j] = '\0';
9037
9038              /* There may be some default parameters to the image */
9039             /*---------------------------------------------------*/
9040             j = 0;
9041             while (isprint(b[i])) {
9042                 image_argv[j++] = b[i++];
9043                 if (j >= NAM$C_MAXRSS)
9044                    break;
9045             }
9046             while ((j > 0) && !isprint(image_argv[j-1]))
9047                 j--;
9048             image_argv[j] = 0;
9049
9050             /* It will need to be converted to VMS format and validated */
9051             if (tmpspec[0] != '\0') {
9052               char * iname;
9053
9054                /* Try to find the exact program requested to be run */
9055               /*---------------------------------------------------*/
9056               iname = do_rmsexpand
9057                  (tmpspec, image_name, 0, ".exe",
9058                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
9059               if (iname != NULL) {
9060                 if (cando_by_name_int
9061                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9062                   /* MCR prefix needed */
9063                   isdcl = 0;
9064                 }
9065                 else {
9066                    /* Try again with a null type */
9067                   /*----------------------------*/
9068                   iname = do_rmsexpand
9069                     (tmpspec, image_name, 0, ".",
9070                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
9071                   if (iname != NULL) {
9072                     if (cando_by_name_int
9073                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9074                       /* MCR prefix needed */
9075                       isdcl = 0;
9076                     }
9077                   }
9078                 }
9079
9080                  /* Did we find the image to run the script? */
9081                 /*------------------------------------------*/
9082                 if (isdcl) {
9083                   char *tchr;
9084
9085                    /* Assume DCL or foreign command exists */
9086                   /*--------------------------------------*/
9087                   tchr = strrchr(tmpspec, '/');
9088                   if (tchr != NULL) {
9089                     tchr++;
9090                   }
9091                   else {
9092                     tchr = tmpspec;
9093                   }
9094                   strcpy(image_name, tchr);
9095                 }
9096               }
9097             }
9098           }
9099         }
9100         fclose(fp);
9101       }
9102       if (check_img && isdcl) return RMS$_FNF;
9103
9104       if (cando_by_name(S_IXUSR,0,resspec)) {
9105         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9106         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9107         if (!isdcl) {
9108             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9109             if (image_name[0] != 0) {
9110                 strcat(vmscmd->dsc$a_pointer, image_name);
9111                 strcat(vmscmd->dsc$a_pointer, " ");
9112             }
9113         } else if (image_name[0] != 0) {
9114             strcpy(vmscmd->dsc$a_pointer, image_name);
9115             strcat(vmscmd->dsc$a_pointer, " ");
9116         } else {
9117             strcpy(vmscmd->dsc$a_pointer,"@");
9118         }
9119         if (suggest_quote) *suggest_quote = 1;
9120
9121         /* If there is an image name, use original command */
9122         if (image_name[0] == 0)
9123             strcat(vmscmd->dsc$a_pointer,resspec);
9124         else {
9125             rest = cmd;
9126             while (*rest && isspace(*rest)) rest++;
9127         }
9128
9129         if (image_argv[0] != 0) {
9130           strcat(vmscmd->dsc$a_pointer,image_argv);
9131           strcat(vmscmd->dsc$a_pointer, " ");
9132         }
9133         if (rest) {
9134            int rest_len;
9135            int vmscmd_len;
9136
9137            rest_len = strlen(rest);
9138            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9139            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9140               strcat(vmscmd->dsc$a_pointer,rest);
9141            else
9142              retsts = CLI$_BUFOVF;
9143         }
9144         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9145         PerlMem_free(cmd);
9146         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9147       }
9148       else
9149         retsts = RMS$_PRV;
9150     }
9151   }
9152   /* It's either a DCL command or we couldn't find a suitable image */
9153   vmscmd->dsc$w_length = strlen(cmd);
9154
9155   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9156   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9157   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9158
9159   PerlMem_free(cmd);
9160
9161   /* check if it's a symbol (for quoting purposes) */
9162   if (suggest_quote && !*suggest_quote) {
9163     int iss;
9164     char equiv[LNM$C_NAMLENGTH];
9165     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9166     eqvdsc.dsc$a_pointer = equiv;
9167
9168     iss = lib$get_symbol(vmscmd,&eqvdsc);
9169     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9170   }
9171   if (!(retsts & 1)) {
9172     /* just hand off status values likely to be due to user error */
9173     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9174         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9175        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9176     else { _ckvmssts(retsts); }
9177   }
9178
9179   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9180
9181 }  /* end of setup_cmddsc() */
9182
9183
9184 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9185 bool
9186 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9187 {
9188 bool exec_sts;
9189 char * cmd;
9190
9191   if (sp > mark) {
9192     if (vfork_called) {           /* this follows a vfork - act Unixish */
9193       vfork_called--;
9194       if (vfork_called < 0) {
9195         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9196         vfork_called = 0;
9197       }
9198       else return do_aexec(really,mark,sp);
9199     }
9200                                            /* no vfork - act VMSish */
9201     cmd = setup_argstr(aTHX_ really,mark,sp);
9202     exec_sts = vms_do_exec(cmd);
9203     Safefree(cmd);  /* Clean up from setup_argstr() */
9204     return exec_sts;
9205   }
9206
9207   return FALSE;
9208 }  /* end of vms_do_aexec() */
9209 /*}}}*/
9210
9211 /* {{{bool vms_do_exec(char *cmd) */
9212 bool
9213 Perl_vms_do_exec(pTHX_ const char *cmd)
9214 {
9215   struct dsc$descriptor_s *vmscmd;
9216
9217   if (vfork_called) {             /* this follows a vfork - act Unixish */
9218     vfork_called--;
9219     if (vfork_called < 0) {
9220       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9221       vfork_called = 0;
9222     }
9223     else return do_exec(cmd);
9224   }
9225
9226   {                               /* no vfork - act VMSish */
9227     unsigned long int retsts;
9228
9229     TAINT_ENV();
9230     TAINT_PROPER("exec");
9231     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9232       retsts = lib$do_command(vmscmd);
9233
9234     switch (retsts) {
9235       case RMS$_FNF: case RMS$_DNF:
9236         set_errno(ENOENT); break;
9237       case RMS$_DIR:
9238         set_errno(ENOTDIR); break;
9239       case RMS$_DEV:
9240         set_errno(ENODEV); break;
9241       case RMS$_PRV:
9242         set_errno(EACCES); break;
9243       case RMS$_SYN:
9244         set_errno(EINVAL); break;
9245       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9246         set_errno(E2BIG); break;
9247       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9248         _ckvmssts(retsts); /* fall through */
9249       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9250         set_errno(EVMSERR);
9251     }
9252     set_vaxc_errno(retsts);
9253     if (ckWARN(WARN_EXEC)) {
9254       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9255              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9256     }
9257     vms_execfree(vmscmd);
9258   }
9259
9260   return FALSE;
9261
9262 }  /* end of vms_do_exec() */
9263 /*}}}*/
9264
9265 unsigned long int Perl_do_spawn(pTHX_ const char *);
9266
9267 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9268 unsigned long int
9269 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9270 {
9271 unsigned long int sts;
9272 char * cmd;
9273
9274   if (sp > mark) {
9275     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9276     sts = do_spawn(cmd);
9277     /* pp_sys will clean up cmd */
9278     return sts;
9279   }
9280   return SS$_ABORT;
9281 }  /* end of do_aspawn() */
9282 /*}}}*/
9283
9284 /* {{{unsigned long int do_spawn(char *cmd) */
9285 unsigned long int
9286 Perl_do_spawn(pTHX_ const char *cmd)
9287 {
9288   unsigned long int sts, substs;
9289
9290   /* The caller of this routine expects to Safefree(PL_Cmd) */
9291   Newx(PL_Cmd,10,char);
9292
9293   TAINT_ENV();
9294   TAINT_PROPER("spawn");
9295   if (!cmd || !*cmd) {
9296     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9297     if (!(sts & 1)) {
9298       switch (sts) {
9299         case RMS$_FNF:  case RMS$_DNF:
9300           set_errno(ENOENT); break;
9301         case RMS$_DIR:
9302           set_errno(ENOTDIR); break;
9303         case RMS$_DEV:
9304           set_errno(ENODEV); break;
9305         case RMS$_PRV:
9306           set_errno(EACCES); break;
9307         case RMS$_SYN:
9308           set_errno(EINVAL); break;
9309         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9310           set_errno(E2BIG); break;
9311         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9312           _ckvmssts(sts); /* fall through */
9313         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9314           set_errno(EVMSERR);
9315       }
9316       set_vaxc_errno(sts);
9317       if (ckWARN(WARN_EXEC)) {
9318         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9319                     Strerror(errno));
9320       }
9321     }
9322     sts = substs;
9323   }
9324   else {
9325     PerlIO * fp;
9326     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9327     if (fp != NULL)
9328       my_pclose(fp);
9329   }
9330   return sts;
9331 }  /* end of do_spawn() */
9332 /*}}}*/
9333
9334
9335 static unsigned int *sockflags, sockflagsize;
9336
9337 /*
9338  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9339  * routines found in some versions of the CRTL can't deal with sockets.
9340  * We don't shim the other file open routines since a socket isn't
9341  * likely to be opened by a name.
9342  */
9343 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9344 FILE *my_fdopen(int fd, const char *mode)
9345 {
9346   FILE *fp = fdopen(fd, mode);
9347
9348   if (fp) {
9349     unsigned int fdoff = fd / sizeof(unsigned int);
9350     Stat_t sbuf; /* native stat; we don't need flex_stat */
9351     if (!sockflagsize || fdoff > sockflagsize) {
9352       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
9353       else           Newx  (sockflags,fdoff+2,unsigned int);
9354       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9355       sockflagsize = fdoff + 2;
9356     }
9357     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9358       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9359   }
9360   return fp;
9361
9362 }
9363 /*}}}*/
9364
9365
9366 /*
9367  * Clear the corresponding bit when the (possibly) socket stream is closed.
9368  * There still a small hole: we miss an implicit close which might occur
9369  * via freopen().  >> Todo
9370  */
9371 /*{{{ int my_fclose(FILE *fp)*/
9372 int my_fclose(FILE *fp) {
9373   if (fp) {
9374     unsigned int fd = fileno(fp);
9375     unsigned int fdoff = fd / sizeof(unsigned int);
9376
9377     if (sockflagsize && fdoff <= sockflagsize)
9378       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9379   }
9380   return fclose(fp);
9381 }
9382 /*}}}*/
9383
9384
9385 /*
9386  * A simple fwrite replacement which outputs itmsz*nitm chars without
9387  * introducing record boundaries every itmsz chars.
9388  * We are using fputs, which depends on a terminating null.  We may
9389  * well be writing binary data, so we need to accommodate not only
9390  * data with nulls sprinkled in the middle but also data with no null
9391  * byte at the end.
9392  */
9393 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9394 int
9395 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9396 {
9397   register char *cp, *end, *cpd, *data;
9398   register unsigned int fd = fileno(dest);
9399   register unsigned int fdoff = fd / sizeof(unsigned int);
9400   int retval;
9401   int bufsize = itmsz * nitm + 1;
9402
9403   if (fdoff < sockflagsize &&
9404       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9405     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9406     return nitm;
9407   }
9408
9409   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9410   memcpy( data, src, itmsz*nitm );
9411   data[itmsz*nitm] = '\0';
9412
9413   end = data + itmsz * nitm;
9414   retval = (int) nitm; /* on success return # items written */
9415
9416   cpd = data;
9417   while (cpd <= end) {
9418     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9419     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9420     if (cp < end)
9421       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9422     cpd = cp + 1;
9423   }
9424
9425   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9426   return retval;
9427
9428 }  /* end of my_fwrite() */
9429 /*}}}*/
9430
9431 /*{{{ int my_flush(FILE *fp)*/
9432 int
9433 Perl_my_flush(pTHX_ FILE *fp)
9434 {
9435     int res;
9436     if ((res = fflush(fp)) == 0 && fp) {
9437 #ifdef VMS_DO_SOCKETS
9438         Stat_t s;
9439         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9440 #endif
9441             res = fsync(fileno(fp));
9442     }
9443 /*
9444  * If the flush succeeded but set end-of-file, we need to clear
9445  * the error because our caller may check ferror().  BTW, this
9446  * probably means we just flushed an empty file.
9447  */
9448     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9449
9450     return res;
9451 }
9452 /*}}}*/
9453
9454 /*
9455  * Here are replacements for the following Unix routines in the VMS environment:
9456  *      getpwuid    Get information for a particular UIC or UID
9457  *      getpwnam    Get information for a named user
9458  *      getpwent    Get information for each user in the rights database
9459  *      setpwent    Reset search to the start of the rights database
9460  *      endpwent    Finish searching for users in the rights database
9461  *
9462  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9463  * (defined in pwd.h), which contains the following fields:-
9464  *      struct passwd {
9465  *              char        *pw_name;    Username (in lower case)
9466  *              char        *pw_passwd;  Hashed password
9467  *              unsigned int pw_uid;     UIC
9468  *              unsigned int pw_gid;     UIC group  number
9469  *              char        *pw_unixdir; Default device/directory (VMS-style)
9470  *              char        *pw_gecos;   Owner name
9471  *              char        *pw_dir;     Default device/directory (Unix-style)
9472  *              char        *pw_shell;   Default CLI name (eg. DCL)
9473  *      };
9474  * If the specified user does not exist, getpwuid and getpwnam return NULL.
9475  *
9476  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9477  * not the UIC member number (eg. what's returned by getuid()),
9478  * getpwuid() can accept either as input (if uid is specified, the caller's
9479  * UIC group is used), though it won't recognise gid=0.
9480  *
9481  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9482  * information about other users in your group or in other groups, respectively.
9483  * If the required privilege is not available, then these routines fill only
9484  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9485  * string).
9486  *
9487  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9488  */
9489
9490 /* sizes of various UAF record fields */
9491 #define UAI$S_USERNAME 12
9492 #define UAI$S_IDENT    31
9493 #define UAI$S_OWNER    31
9494 #define UAI$S_DEFDEV   31
9495 #define UAI$S_DEFDIR   63
9496 #define UAI$S_DEFCLI   31
9497 #define UAI$S_PWD       8
9498
9499 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
9500                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9501                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
9502
9503 static char __empty[]= "";
9504 static struct passwd __passwd_empty=
9505     {(char *) __empty, (char *) __empty, 0, 0,
9506      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9507 static int contxt= 0;
9508 static struct passwd __pwdcache;
9509 static char __pw_namecache[UAI$S_IDENT+1];
9510
9511 /*
9512  * This routine does most of the work extracting the user information.
9513  */
9514 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9515 {
9516     static struct {
9517         unsigned char length;
9518         char pw_gecos[UAI$S_OWNER+1];
9519     } owner;
9520     static union uicdef uic;
9521     static struct {
9522         unsigned char length;
9523         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9524     } defdev;
9525     static struct {
9526         unsigned char length;
9527         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9528     } defdir;
9529     static struct {
9530         unsigned char length;
9531         char pw_shell[UAI$S_DEFCLI+1];
9532     } defcli;
9533     static char pw_passwd[UAI$S_PWD+1];
9534
9535     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9536     struct dsc$descriptor_s name_desc;
9537     unsigned long int sts;
9538
9539     static struct itmlst_3 itmlst[]= {
9540         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
9541         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
9542         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
9543         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
9544         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
9545         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
9546         {0,                0,           NULL,    NULL}};
9547
9548     name_desc.dsc$w_length=  strlen(name);
9549     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9550     name_desc.dsc$b_class=   DSC$K_CLASS_S;
9551     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9552
9553 /*  Note that sys$getuai returns many fields as counted strings. */
9554     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9555     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9556       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9557     }
9558     else { _ckvmssts(sts); }
9559     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
9560
9561     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
9562     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9563     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9564     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9565     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9566     owner.pw_gecos[lowner]=            '\0';
9567     defdev.pw_dir[ldefdev+ldefdir]= '\0';
9568     defcli.pw_shell[ldefcli]=          '\0';
9569     if (valid_uic(uic)) {
9570         pwd->pw_uid= uic.uic$l_uic;
9571         pwd->pw_gid= uic.uic$v_group;
9572     }
9573     else
9574       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9575     pwd->pw_passwd=  pw_passwd;
9576     pwd->pw_gecos=   owner.pw_gecos;
9577     pwd->pw_dir=     defdev.pw_dir;
9578     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9579     pwd->pw_shell=   defcli.pw_shell;
9580     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9581         int ldir;
9582         ldir= strlen(pwd->pw_unixdir) - 1;
9583         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9584     }
9585     else
9586         strcpy(pwd->pw_unixdir, pwd->pw_dir);
9587     if (!decc_efs_case_preserve)
9588         __mystrtolower(pwd->pw_unixdir);
9589     return 1;
9590 }
9591
9592 /*
9593  * Get information for a named user.
9594 */
9595 /*{{{struct passwd *getpwnam(char *name)*/
9596 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9597 {
9598     struct dsc$descriptor_s name_desc;
9599     union uicdef uic;
9600     unsigned long int status, sts;
9601
9602     __pwdcache = __passwd_empty;
9603     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9604       /* We still may be able to determine pw_uid and pw_gid */
9605       name_desc.dsc$w_length=  strlen(name);
9606       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9607       name_desc.dsc$b_class=   DSC$K_CLASS_S;
9608       name_desc.dsc$a_pointer= (char *) name;
9609       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9610         __pwdcache.pw_uid= uic.uic$l_uic;
9611         __pwdcache.pw_gid= uic.uic$v_group;
9612       }
9613       else {
9614         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9615           set_vaxc_errno(sts);
9616           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9617           return NULL;
9618         }
9619         else { _ckvmssts(sts); }
9620       }
9621     }
9622     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9623     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9624     __pwdcache.pw_name= __pw_namecache;
9625     return &__pwdcache;
9626 }  /* end of my_getpwnam() */
9627 /*}}}*/
9628
9629 /*
9630  * Get information for a particular UIC or UID.
9631  * Called by my_getpwent with uid=-1 to list all users.
9632 */
9633 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9634 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9635 {
9636     const $DESCRIPTOR(name_desc,__pw_namecache);
9637     unsigned short lname;
9638     union uicdef uic;
9639     unsigned long int status;
9640
9641     if (uid == (unsigned int) -1) {
9642       do {
9643         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9644         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9645           set_vaxc_errno(status);
9646           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9647           my_endpwent();
9648           return NULL;
9649         }
9650         else { _ckvmssts(status); }
9651       } while (!valid_uic (uic));
9652     }
9653     else {
9654       uic.uic$l_uic= uid;
9655       if (!uic.uic$v_group)
9656         uic.uic$v_group= PerlProc_getgid();
9657       if (valid_uic(uic))
9658         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9659       else status = SS$_IVIDENT;
9660       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9661           status == RMS$_PRV) {
9662         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9663         return NULL;
9664       }
9665       else { _ckvmssts(status); }
9666     }
9667     __pw_namecache[lname]= '\0';
9668     __mystrtolower(__pw_namecache);
9669
9670     __pwdcache = __passwd_empty;
9671     __pwdcache.pw_name = __pw_namecache;
9672
9673 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9674     The identifier's value is usually the UIC, but it doesn't have to be,
9675     so if we can, we let fillpasswd update this. */
9676     __pwdcache.pw_uid =  uic.uic$l_uic;
9677     __pwdcache.pw_gid =  uic.uic$v_group;
9678
9679     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9680     return &__pwdcache;
9681
9682 }  /* end of my_getpwuid() */
9683 /*}}}*/
9684
9685 /*
9686  * Get information for next user.
9687 */
9688 /*{{{struct passwd *my_getpwent()*/
9689 struct passwd *Perl_my_getpwent(pTHX)
9690 {
9691     return (my_getpwuid((unsigned int) -1));
9692 }
9693 /*}}}*/
9694
9695 /*
9696  * Finish searching rights database for users.
9697 */
9698 /*{{{void my_endpwent()*/
9699 void Perl_my_endpwent(pTHX)
9700 {
9701     if (contxt) {
9702       _ckvmssts(sys$finish_rdb(&contxt));
9703       contxt= 0;
9704     }
9705 }
9706 /*}}}*/
9707
9708 #ifdef HOMEGROWN_POSIX_SIGNALS
9709   /* Signal handling routines, pulled into the core from POSIX.xs.
9710    *
9711    * We need these for threads, so they've been rolled into the core,
9712    * rather than left in POSIX.xs.
9713    *
9714    * (DRS, Oct 23, 1997)
9715    */
9716
9717   /* sigset_t is atomic under VMS, so these routines are easy */
9718 /*{{{int my_sigemptyset(sigset_t *) */
9719 int my_sigemptyset(sigset_t *set) {
9720     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9721     *set = 0; return 0;
9722 }
9723 /*}}}*/
9724
9725
9726 /*{{{int my_sigfillset(sigset_t *)*/
9727 int my_sigfillset(sigset_t *set) {
9728     int i;
9729     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9730     for (i = 0; i < NSIG; i++) *set |= (1 << i);
9731     return 0;
9732 }
9733 /*}}}*/
9734
9735
9736 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
9737 int my_sigaddset(sigset_t *set, int sig) {
9738     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9739     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9740     *set |= (1 << (sig - 1));
9741     return 0;
9742 }
9743 /*}}}*/
9744
9745
9746 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
9747 int my_sigdelset(sigset_t *set, int sig) {
9748     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9749     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9750     *set &= ~(1 << (sig - 1));
9751     return 0;
9752 }
9753 /*}}}*/
9754
9755
9756 /*{{{int my_sigismember(sigset_t *set, int sig)*/
9757 int my_sigismember(sigset_t *set, int sig) {
9758     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9759     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9760     return *set & (1 << (sig - 1));
9761 }
9762 /*}}}*/
9763
9764
9765 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
9766 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
9767     sigset_t tempmask;
9768
9769     /* If set and oset are both null, then things are badly wrong. Bail out. */
9770     if ((oset == NULL) && (set == NULL)) {
9771       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
9772       return -1;
9773     }
9774
9775     /* If set's null, then we're just handling a fetch. */
9776     if (set == NULL) {
9777         tempmask = sigblock(0);
9778     }
9779     else {
9780       switch (how) {
9781       case SIG_SETMASK:
9782         tempmask = sigsetmask(*set);
9783         break;
9784       case SIG_BLOCK:
9785         tempmask = sigblock(*set);
9786         break;
9787       case SIG_UNBLOCK:
9788         tempmask = sigblock(0);
9789         sigsetmask(*oset & ~tempmask);
9790         break;
9791       default:
9792         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9793         return -1;
9794       }
9795     }
9796
9797     /* Did they pass us an oset? If so, stick our holding mask into it */
9798     if (oset)
9799       *oset = tempmask;
9800
9801     return 0;
9802 }
9803 /*}}}*/
9804 #endif  /* HOMEGROWN_POSIX_SIGNALS */
9805
9806
9807 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
9808  * my_utime(), and flex_stat(), all of which operate on UTC unless
9809  * VMSISH_TIMES is true.
9810  */
9811 /* method used to handle UTC conversions:
9812  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
9813  */
9814 static int gmtime_emulation_type;
9815 /* number of secs to add to UTC POSIX-style time to get local time */
9816 static long int utc_offset_secs;
9817
9818 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
9819  * in vmsish.h.  #undef them here so we can call the CRTL routines
9820  * directly.
9821  */
9822 #undef gmtime
9823 #undef localtime
9824 #undef time
9825
9826
9827 /*
9828  * DEC C previous to 6.0 corrupts the behavior of the /prefix
9829  * qualifier with the extern prefix pragma.  This provisional
9830  * hack circumvents this prefix pragma problem in previous
9831  * precompilers.
9832  */
9833 #if defined(__VMS_VER) && __VMS_VER >= 70000000
9834 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
9835 #    pragma __extern_prefix save
9836 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
9837 #    define gmtime decc$__utctz_gmtime
9838 #    define localtime decc$__utctz_localtime
9839 #    define time decc$__utc_time
9840 #    pragma __extern_prefix restore
9841
9842      struct tm *gmtime(), *localtime();
9843
9844 #  endif
9845 #endif
9846
9847
9848 static time_t toutc_dst(time_t loc) {
9849   struct tm *rsltmp;
9850
9851   if ((rsltmp = localtime(&loc)) == NULL) return -1;
9852   loc -= utc_offset_secs;
9853   if (rsltmp->tm_isdst) loc -= 3600;
9854   return loc;
9855 }
9856 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9857        ((gmtime_emulation_type || my_time(NULL)), \
9858        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
9859        ((secs) - utc_offset_secs))))
9860
9861 static time_t toloc_dst(time_t utc) {
9862   struct tm *rsltmp;
9863
9864   utc += utc_offset_secs;
9865   if ((rsltmp = localtime(&utc)) == NULL) return -1;
9866   if (rsltmp->tm_isdst) utc += 3600;
9867   return utc;
9868 }
9869 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9870        ((gmtime_emulation_type || my_time(NULL)), \
9871        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
9872        ((secs) + utc_offset_secs))))
9873
9874 #ifndef RTL_USES_UTC
9875 /*
9876
9877     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
9878         DST starts on 1st sun of april      at 02:00  std time
9879             ends on last sun of october     at 02:00  dst time
9880     see the UCX management command reference, SET CONFIG TIMEZONE
9881     for formatting info.
9882
9883     No, it's not as general as it should be, but then again, NOTHING
9884     will handle UK times in a sensible way.
9885 */
9886
9887
9888 /*
9889     parse the DST start/end info:
9890     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
9891 */
9892
9893 static char *
9894 tz_parse_startend(char *s, struct tm *w, int *past)
9895 {
9896     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
9897     int ly, dozjd, d, m, n, hour, min, sec, j, k;
9898     time_t g;
9899
9900     if (!s)    return 0;
9901     if (!w) return 0;
9902     if (!past) return 0;
9903
9904     ly = 0;
9905     if (w->tm_year % 4        == 0) ly = 1;
9906     if (w->tm_year % 100      == 0) ly = 0;
9907     if (w->tm_year+1900 % 400 == 0) ly = 1;
9908     if (ly) dinm[1]++;
9909
9910     dozjd = isdigit(*s);
9911     if (*s == 'J' || *s == 'j' || dozjd) {
9912         if (!dozjd && !isdigit(*++s)) return 0;
9913         d = *s++ - '0';
9914         if (isdigit(*s)) {
9915             d = d*10 + *s++ - '0';
9916             if (isdigit(*s)) {
9917                 d = d*10 + *s++ - '0';
9918             }
9919         }
9920         if (d == 0) return 0;
9921         if (d > 366) return 0;
9922         d--;
9923         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
9924         g = d * 86400;
9925         dozjd = 1;
9926     } else if (*s == 'M' || *s == 'm') {
9927         if (!isdigit(*++s)) return 0;
9928         m = *s++ - '0';
9929         if (isdigit(*s)) m = 10*m + *s++ - '0';
9930         if (*s != '.') return 0;
9931         if (!isdigit(*++s)) return 0;
9932         n = *s++ - '0';
9933         if (n < 1 || n > 5) return 0;
9934         if (*s != '.') return 0;
9935         if (!isdigit(*++s)) return 0;
9936         d = *s++ - '0';
9937         if (d > 6) return 0;
9938     }
9939
9940     if (*s == '/') {
9941         if (!isdigit(*++s)) return 0;
9942         hour = *s++ - '0';
9943         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
9944         if (*s == ':') {
9945             if (!isdigit(*++s)) return 0;
9946             min = *s++ - '0';
9947             if (isdigit(*s)) min = 10*min + *s++ - '0';
9948             if (*s == ':') {
9949                 if (!isdigit(*++s)) return 0;
9950                 sec = *s++ - '0';
9951                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
9952             }
9953         }
9954     } else {
9955         hour = 2;
9956         min = 0;
9957         sec = 0;
9958     }
9959
9960     if (dozjd) {
9961         if (w->tm_yday < d) goto before;
9962         if (w->tm_yday > d) goto after;
9963     } else {
9964         if (w->tm_mon+1 < m) goto before;
9965         if (w->tm_mon+1 > m) goto after;
9966
9967         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
9968         k = d - j; /* mday of first d */
9969         if (k <= 0) k += 7;
9970         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
9971         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
9972         if (w->tm_mday < k) goto before;
9973         if (w->tm_mday > k) goto after;
9974     }
9975
9976     if (w->tm_hour < hour) goto before;
9977     if (w->tm_hour > hour) goto after;
9978     if (w->tm_min  < min)  goto before;
9979     if (w->tm_min  > min)  goto after;
9980     if (w->tm_sec  < sec)  goto before;
9981     goto after;
9982
9983 before:
9984     *past = 0;
9985     return s;
9986 after:
9987     *past = 1;
9988     return s;
9989 }
9990
9991
9992
9993
9994 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
9995
9996 static char *
9997 tz_parse_offset(char *s, int *offset)
9998 {
9999     int hour = 0, min = 0, sec = 0;
10000     int neg = 0;
10001     if (!s) return 0;
10002     if (!offset) return 0;
10003
10004     if (*s == '-') {neg++; s++;}
10005     if (*s == '+') s++;
10006     if (!isdigit(*s)) return 0;
10007     hour = *s++ - '0';
10008     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10009     if (hour > 24) return 0;
10010     if (*s == ':') {
10011         if (!isdigit(*++s)) return 0;
10012         min = *s++ - '0';
10013         if (isdigit(*s)) min = min*10 + (*s++ - '0');
10014         if (min > 59) return 0;
10015         if (*s == ':') {
10016             if (!isdigit(*++s)) return 0;
10017             sec = *s++ - '0';
10018             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10019             if (sec > 59) return 0;
10020         }
10021     }
10022
10023     *offset = (hour*60+min)*60 + sec;
10024     if (neg) *offset = -*offset;
10025     return s;
10026 }
10027
10028 /*
10029     input time is w, whatever type of time the CRTL localtime() uses.
10030     sets dst, the zone, and the gmtoff (seconds)
10031
10032     caches the value of TZ and UCX$TZ env variables; note that
10033     my_setenv looks for these and sets a flag if they're changed
10034     for efficiency.
10035
10036     We have to watch out for the "australian" case (dst starts in
10037     october, ends in april)...flagged by "reverse" and checked by
10038     scanning through the months of the previous year.
10039
10040 */
10041
10042 static int
10043 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10044 {
10045     time_t when;
10046     struct tm *w2;
10047     char *s,*s2;
10048     char *dstzone, *tz, *s_start, *s_end;
10049     int std_off, dst_off, isdst;
10050     int y, dststart, dstend;
10051     static char envtz[1025];  /* longer than any logical, symbol, ... */
10052     static char ucxtz[1025];
10053     static char reversed = 0;
10054
10055     if (!w) return 0;
10056
10057     if (tz_updated) {
10058         tz_updated = 0;
10059         reversed = -1;  /* flag need to check  */
10060         envtz[0] = ucxtz[0] = '\0';
10061         tz = my_getenv("TZ",0);
10062         if (tz) strcpy(envtz, tz);
10063         tz = my_getenv("UCX$TZ",0);
10064         if (tz) strcpy(ucxtz, tz);
10065         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
10066     }
10067     tz = envtz;
10068     if (!*tz) tz = ucxtz;
10069
10070     s = tz;
10071     while (isalpha(*s)) s++;
10072     s = tz_parse_offset(s, &std_off);
10073     if (!s) return 0;
10074     if (!*s) {                  /* no DST, hurray we're done! */
10075         isdst = 0;
10076         goto done;
10077     }
10078
10079     dstzone = s;
10080     while (isalpha(*s)) s++;
10081     s2 = tz_parse_offset(s, &dst_off);
10082     if (s2) {
10083         s = s2;
10084     } else {
10085         dst_off = std_off - 3600;
10086     }
10087
10088     if (!*s) {      /* default dst start/end?? */
10089         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
10090             s = strchr(ucxtz,',');
10091         }
10092         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
10093     }
10094     if (*s != ',') return 0;
10095
10096     when = *w;
10097     when = _toutc(when);      /* convert to utc */
10098     when = when - std_off;    /* convert to pseudolocal time*/
10099
10100     w2 = localtime(&when);
10101     y = w2->tm_year;
10102     s_start = s+1;
10103     s = tz_parse_startend(s_start,w2,&dststart);
10104     if (!s) return 0;
10105     if (*s != ',') return 0;
10106
10107     when = *w;
10108     when = _toutc(when);      /* convert to utc */
10109     when = when - dst_off;    /* convert to pseudolocal time*/
10110     w2 = localtime(&when);
10111     if (w2->tm_year != y) {   /* spans a year, just check one time */
10112         when += dst_off - std_off;
10113         w2 = localtime(&when);
10114     }
10115     s_end = s+1;
10116     s = tz_parse_startend(s_end,w2,&dstend);
10117     if (!s) return 0;
10118
10119     if (reversed == -1) {  /* need to check if start later than end */
10120         int j, ds, de;
10121
10122         when = *w;
10123         if (when < 2*365*86400) {
10124             when += 2*365*86400;
10125         } else {
10126             when -= 365*86400;
10127         }
10128         w2 =localtime(&when);
10129         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
10130
10131         for (j = 0; j < 12; j++) {
10132             w2 =localtime(&when);
10133             tz_parse_startend(s_start,w2,&ds);
10134             tz_parse_startend(s_end,w2,&de);
10135             if (ds != de) break;
10136             when += 30*86400;
10137         }
10138         reversed = 0;
10139         if (de && !ds) reversed = 1;
10140     }
10141
10142     isdst = dststart && !dstend;
10143     if (reversed) isdst = dststart  || !dstend;
10144
10145 done:
10146     if (dst)    *dst = isdst;
10147     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10148     if (isdst)  tz = dstzone;
10149     if (zone) {
10150         while(isalpha(*tz))  *zone++ = *tz++;
10151         *zone = '\0';
10152     }
10153     return 1;
10154 }
10155
10156 #endif /* !RTL_USES_UTC */
10157
10158 /* my_time(), my_localtime(), my_gmtime()
10159  * By default traffic in UTC time values, using CRTL gmtime() or
10160  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10161  * Note: We need to use these functions even when the CRTL has working
10162  * UTC support, since they also handle C<use vmsish qw(times);>
10163  *
10164  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
10165  * Modified by Charles Bailey <bailey@newman.upenn.edu>
10166  */
10167
10168 /*{{{time_t my_time(time_t *timep)*/
10169 time_t Perl_my_time(pTHX_ time_t *timep)
10170 {
10171   time_t when;
10172   struct tm *tm_p;
10173
10174   if (gmtime_emulation_type == 0) {
10175     int dstnow;
10176     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
10177                               /* results of calls to gmtime() and localtime() */
10178                               /* for same &base */
10179
10180     gmtime_emulation_type++;
10181     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10182       char off[LNM$C_NAMLENGTH+1];;
10183
10184       gmtime_emulation_type++;
10185       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10186         gmtime_emulation_type++;
10187         utc_offset_secs = 0;
10188         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10189       }
10190       else { utc_offset_secs = atol(off); }
10191     }
10192     else { /* We've got a working gmtime() */
10193       struct tm gmt, local;
10194
10195       gmt = *tm_p;
10196       tm_p = localtime(&base);
10197       local = *tm_p;
10198       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
10199       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10200       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
10201       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
10202     }
10203   }
10204
10205   when = time(NULL);
10206 # ifdef VMSISH_TIME
10207 # ifdef RTL_USES_UTC
10208   if (VMSISH_TIME) when = _toloc(when);
10209 # else
10210   if (!VMSISH_TIME) when = _toutc(when);
10211 # endif
10212 # endif
10213   if (timep != NULL) *timep = when;
10214   return when;
10215
10216 }  /* end of my_time() */
10217 /*}}}*/
10218
10219
10220 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10221 struct tm *
10222 Perl_my_gmtime(pTHX_ const time_t *timep)
10223 {
10224   char *p;
10225   time_t when;
10226   struct tm *rsltmp;
10227
10228   if (timep == NULL) {
10229     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10230     return NULL;
10231   }
10232   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10233
10234   when = *timep;
10235 # ifdef VMSISH_TIME
10236   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10237 #  endif
10238 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
10239   return gmtime(&when);
10240 # else
10241   /* CRTL localtime() wants local time as input, so does no tz correction */
10242   rsltmp = localtime(&when);
10243   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
10244   return rsltmp;
10245 #endif
10246 }  /* end of my_gmtime() */
10247 /*}}}*/
10248
10249
10250 /*{{{struct tm *my_localtime(const time_t *timep)*/
10251 struct tm *
10252 Perl_my_localtime(pTHX_ const time_t *timep)
10253 {
10254   time_t when, whenutc;
10255   struct tm *rsltmp;
10256   int dst, offset;
10257
10258   if (timep == NULL) {
10259     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10260     return NULL;
10261   }
10262   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10263   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10264
10265   when = *timep;
10266 # ifdef RTL_USES_UTC
10267 # ifdef VMSISH_TIME
10268   if (VMSISH_TIME) when = _toutc(when);
10269 # endif
10270   /* CRTL localtime() wants UTC as input, does tz correction itself */
10271   return localtime(&when);
10272
10273 # else /* !RTL_USES_UTC */
10274   whenutc = when;
10275 # ifdef VMSISH_TIME
10276   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
10277   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
10278 # endif
10279   dst = -1;
10280 #ifndef RTL_USES_UTC
10281   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
10282       when = whenutc - offset;                   /* pseudolocal time*/
10283   }
10284 # endif
10285   /* CRTL localtime() wants local time as input, so does no tz correction */
10286   rsltmp = localtime(&when);
10287   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10288   return rsltmp;
10289 # endif
10290
10291 } /*  end of my_localtime() */
10292 /*}}}*/
10293
10294 /* Reset definitions for later calls */
10295 #define gmtime(t)    my_gmtime(t)
10296 #define localtime(t) my_localtime(t)
10297 #define time(t)      my_time(t)
10298
10299
10300 /* my_utime - update modification/access time of a file
10301  *
10302  * VMS 7.3 and later implementation
10303  * Only the UTC translation is home-grown. The rest is handled by the
10304  * CRTL utime(), which will take into account the relevant feature
10305  * logicals and ODS-5 volume characteristics for true access times.
10306  *
10307  * pre VMS 7.3 implementation:
10308  * The calling sequence is identical to POSIX utime(), but under
10309  * VMS with ODS-2, only the modification time is changed; ODS-2 does
10310  * not maintain access times.  Restrictions differ from the POSIX
10311  * definition in that the time can be changed as long as the
10312  * caller has permission to execute the necessary IO$_MODIFY $QIO;
10313  * no separate checks are made to insure that the caller is the
10314  * owner of the file or has special privs enabled.
10315  * Code here is based on Joe Meadows' FILE utility.
10316  *
10317  */
10318
10319 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10320  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
10321  * in 100 ns intervals.
10322  */
10323 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10324
10325 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10326 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10327 {
10328 #if __CRTL_VER >= 70300000
10329   struct utimbuf utc_utimes, *utc_utimesp;
10330
10331   if (utimes != NULL) {
10332     utc_utimes.actime = utimes->actime;
10333     utc_utimes.modtime = utimes->modtime;
10334 # ifdef VMSISH_TIME
10335     /* If input was local; convert to UTC for sys svc */
10336     if (VMSISH_TIME) {
10337       utc_utimes.actime = _toutc(utimes->actime);
10338       utc_utimes.modtime = _toutc(utimes->modtime);
10339     }
10340 # endif
10341     utc_utimesp = &utc_utimes;
10342   }
10343   else {
10344     utc_utimesp = NULL;
10345   }
10346
10347   return utime(file, utc_utimesp);
10348
10349 #else /* __CRTL_VER < 70300000 */
10350
10351   register int i;
10352   int sts;
10353   long int bintime[2], len = 2, lowbit, unixtime,
10354            secscale = 10000000; /* seconds --> 100 ns intervals */
10355   unsigned long int chan, iosb[2], retsts;
10356   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10357   struct FAB myfab = cc$rms_fab;
10358   struct NAM mynam = cc$rms_nam;
10359 #if defined (__DECC) && defined (__VAX)
10360   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10361    * at least through VMS V6.1, which causes a type-conversion warning.
10362    */
10363 #  pragma message save
10364 #  pragma message disable cvtdiftypes
10365 #endif
10366   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10367   struct fibdef myfib;
10368 #if defined (__DECC) && defined (__VAX)
10369   /* This should be right after the declaration of myatr, but due
10370    * to a bug in VAX DEC C, this takes effect a statement early.
10371    */
10372 #  pragma message restore
10373 #endif
10374   /* cast ok for read only parameter */
10375   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10376                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10377                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10378
10379   if (file == NULL || *file == '\0') {
10380     SETERRNO(ENOENT, LIB$_INVARG);
10381     return -1;
10382   }
10383
10384   /* Convert to VMS format ensuring that it will fit in 255 characters */
10385   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10386       SETERRNO(ENOENT, LIB$_INVARG);
10387       return -1;
10388   }
10389   if (utimes != NULL) {
10390     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
10391      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10392      * Since time_t is unsigned long int, and lib$emul takes a signed long int
10393      * as input, we force the sign bit to be clear by shifting unixtime right
10394      * one bit, then multiplying by an extra factor of 2 in lib$emul().
10395      */
10396     lowbit = (utimes->modtime & 1) ? secscale : 0;
10397     unixtime = (long int) utimes->modtime;
10398 #   ifdef VMSISH_TIME
10399     /* If input was UTC; convert to local for sys svc */
10400     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10401 #   endif
10402     unixtime >>= 1;  secscale <<= 1;
10403     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10404     if (!(retsts & 1)) {
10405       SETERRNO(EVMSERR, retsts);
10406       return -1;
10407     }
10408     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10409     if (!(retsts & 1)) {
10410       SETERRNO(EVMSERR, retsts);
10411       return -1;
10412     }
10413   }
10414   else {
10415     /* Just get the current time in VMS format directly */
10416     retsts = sys$gettim(bintime);
10417     if (!(retsts & 1)) {
10418       SETERRNO(EVMSERR, retsts);
10419       return -1;
10420     }
10421   }
10422
10423   myfab.fab$l_fna = vmsspec;
10424   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10425   myfab.fab$l_nam = &mynam;
10426   mynam.nam$l_esa = esa;
10427   mynam.nam$b_ess = (unsigned char) sizeof esa;
10428   mynam.nam$l_rsa = rsa;
10429   mynam.nam$b_rss = (unsigned char) sizeof rsa;
10430   if (decc_efs_case_preserve)
10431       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10432
10433   /* Look for the file to be affected, letting RMS parse the file
10434    * specification for us as well.  I have set errno using only
10435    * values documented in the utime() man page for VMS POSIX.
10436    */
10437   retsts = sys$parse(&myfab,0,0);
10438   if (!(retsts & 1)) {
10439     set_vaxc_errno(retsts);
10440     if      (retsts == RMS$_PRV) set_errno(EACCES);
10441     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10442     else                         set_errno(EVMSERR);
10443     return -1;
10444   }
10445   retsts = sys$search(&myfab,0,0);
10446   if (!(retsts & 1)) {
10447     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10448     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10449     set_vaxc_errno(retsts);
10450     if      (retsts == RMS$_PRV) set_errno(EACCES);
10451     else if (retsts == RMS$_FNF) set_errno(ENOENT);
10452     else                         set_errno(EVMSERR);
10453     return -1;
10454   }
10455
10456   devdsc.dsc$w_length = mynam.nam$b_dev;
10457   /* cast ok for read only parameter */
10458   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10459
10460   retsts = sys$assign(&devdsc,&chan,0,0);
10461   if (!(retsts & 1)) {
10462     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10463     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10464     set_vaxc_errno(retsts);
10465     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
10466     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
10467     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
10468     else                               set_errno(EVMSERR);
10469     return -1;
10470   }
10471
10472   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10473   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10474
10475   memset((void *) &myfib, 0, sizeof myfib);
10476 #if defined(__DECC) || defined(__DECCXX)
10477   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10478   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10479   /* This prevents the revision time of the file being reset to the current
10480    * time as a result of our IO$_MODIFY $QIO. */
10481   myfib.fib$l_acctl = FIB$M_NORECORD;
10482 #else
10483   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10484   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10485   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10486 #endif
10487   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10488   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10489   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10490   _ckvmssts(sys$dassgn(chan));
10491   if (retsts & 1) retsts = iosb[0];
10492   if (!(retsts & 1)) {
10493     set_vaxc_errno(retsts);
10494     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10495     else                      set_errno(EVMSERR);
10496     return -1;
10497   }
10498
10499   return 0;
10500
10501 #endif /* #if __CRTL_VER >= 70300000 */
10502
10503 }  /* end of my_utime() */
10504 /*}}}*/
10505
10506 /*
10507  * flex_stat, flex_lstat, flex_fstat
10508  * basic stat, but gets it right when asked to stat
10509  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10510  */
10511
10512 #ifndef _USE_STD_STAT
10513 /* encode_dev packs a VMS device name string into an integer to allow
10514  * simple comparisons. This can be used, for example, to check whether two
10515  * files are located on the same device, by comparing their encoded device
10516  * names. Even a string comparison would not do, because stat() reuses the
10517  * device name buffer for each call; so without encode_dev, it would be
10518  * necessary to save the buffer and use strcmp (this would mean a number of
10519  * changes to the standard Perl code, to say nothing of what a Perl script
10520  * would have to do.
10521  *
10522  * The device lock id, if it exists, should be unique (unless perhaps compared
10523  * with lock ids transferred from other nodes). We have a lock id if the disk is
10524  * mounted cluster-wide, which is when we tend to get long (host-qualified)
10525  * device names. Thus we use the lock id in preference, and only if that isn't
10526  * available, do we try to pack the device name into an integer (flagged by
10527  * the sign bit (LOCKID_MASK) being set).
10528  *
10529  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10530  * name and its encoded form, but it seems very unlikely that we will find
10531  * two files on different disks that share the same encoded device names,
10532  * and even more remote that they will share the same file id (if the test
10533  * is to check for the same file).
10534  *
10535  * A better method might be to use sys$device_scan on the first call, and to
10536  * search for the device, returning an index into the cached array.
10537  * The number returned would be more intelligible.
10538  * This is probably not worth it, and anyway would take quite a bit longer
10539  * on the first call.
10540  */
10541 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
10542 static mydev_t encode_dev (pTHX_ const char *dev)
10543 {
10544   int i;
10545   unsigned long int f;
10546   mydev_t enc;
10547   char c;
10548   const char *q;
10549
10550   if (!dev || !dev[0]) return 0;
10551
10552 #if LOCKID_MASK
10553   {
10554     struct dsc$descriptor_s dev_desc;
10555     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10556
10557     /* For cluster-mounted disks, the disk lock identifier is unique, so we
10558        can try that first. */
10559     dev_desc.dsc$w_length =  strlen (dev);
10560     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
10561     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
10562     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
10563     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10564     if (!$VMS_STATUS_SUCCESS(status)) {
10565       switch (status) {
10566         case SS$_NOSUCHDEV:
10567           SETERRNO(ENODEV, status);
10568           return 0;
10569         default:
10570           _ckvmssts(status);
10571       }
10572     }
10573     if (lockid) return (lockid & ~LOCKID_MASK);
10574   }
10575 #endif
10576
10577   /* Otherwise we try to encode the device name */
10578   enc = 0;
10579   f = 1;
10580   i = 0;
10581   for (q = dev + strlen(dev); q--; q >= dev) {
10582     if (*q == ':')
10583         break;
10584     if (isdigit (*q))
10585       c= (*q) - '0';
10586     else if (isalpha (toupper (*q)))
10587       c= toupper (*q) - 'A' + (char)10;
10588     else
10589       continue; /* Skip '$'s */
10590     i++;
10591     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
10592     if (i>1) f *= 36;
10593     enc += f * (unsigned long int) c;
10594   }
10595   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
10596
10597 }  /* end of encode_dev() */
10598 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10599         device_no = encode_dev(aTHX_ devname)
10600 #else
10601 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10602         device_no = new_dev_no
10603 #endif
10604
10605 static int
10606 is_null_device(name)
10607     const char *name;
10608 {
10609   if (decc_bug_devnull != 0) {
10610     if (strncmp("/dev/null", name, 9) == 0)
10611       return 1;
10612   }
10613     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10614        The underscore prefix, controller letter, and unit number are
10615        independently optional; for our purposes, the colon punctuation
10616        is not.  The colon can be trailed by optional directory and/or
10617        filename, but two consecutive colons indicates a nodename rather
10618        than a device.  [pr]  */
10619   if (*name == '_') ++name;
10620   if (tolower(*name++) != 'n') return 0;
10621   if (tolower(*name++) != 'l') return 0;
10622   if (tolower(*name) == 'a') ++name;
10623   if (*name == '0') ++name;
10624   return (*name++ == ':') && (*name != ':');
10625 }
10626
10627
10628 static I32
10629 Perl_cando_by_name_int
10630    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10631 {
10632   static char usrname[L_cuserid];
10633   static struct dsc$descriptor_s usrdsc =
10634          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10635   char vmsname[NAM$C_MAXRSS+1];
10636   char *fileified;
10637   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10638   unsigned short int retlen, trnlnm_iter_count;
10639   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10640   union prvdef curprv;
10641   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10642          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10643          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10644   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10645          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10646          {0,0,0,0}};
10647   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10648          {0,0,0,0}};
10649   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10650
10651   if (!fname || !*fname) return FALSE;
10652   /* Make sure we expand logical names, since sys$check_access doesn't */
10653
10654   fileified = NULL;
10655   if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
10656     fileified = PerlMem_malloc(VMS_MAXRSS);
10657     if (!strpbrk(fname,"/]>:")) {
10658       strcpy(fileified,fname);
10659       trnlnm_iter_count = 0;
10660       while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10661         trnlnm_iter_count++;
10662         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10663       }
10664       fname = fileified;
10665     }
10666     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10667       PerlMem_free(fileified);
10668       return FALSE;
10669     }
10670     retlen = namdsc.dsc$w_length = strlen(vmsname);
10671     namdsc.dsc$a_pointer = vmsname;
10672     if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10673       vmsname[retlen-1] == ':') {
10674       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) return FALSE;
10675       namdsc.dsc$w_length = strlen(fileified);
10676       namdsc.dsc$a_pointer = fileified;
10677     }
10678   }
10679   else {
10680     retlen = namdsc.dsc$w_length = strlen(fname);
10681     namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
10682   }
10683
10684   switch (bit) {
10685     case S_IXUSR: case S_IXGRP: case S_IXOTH:
10686       access = ARM$M_EXECUTE;
10687       flags = CHP$M_READ;
10688       break;
10689     case S_IRUSR: case S_IRGRP: case S_IROTH:
10690       access = ARM$M_READ;
10691       flags = CHP$M_READ | CHP$M_USEREADALL;
10692       break;
10693     case S_IWUSR: case S_IWGRP: case S_IWOTH:
10694       access = ARM$M_WRITE;
10695       flags = CHP$M_READ | CHP$M_WRITE;
10696       break;
10697     case S_IDUSR: case S_IDGRP: case S_IDOTH:
10698       access = ARM$M_DELETE;
10699       flags = CHP$M_READ | CHP$M_WRITE;
10700       break;
10701     default:
10702       if (fileified != NULL)
10703         PerlMem_free(fileified);
10704       return FALSE;
10705   }
10706
10707   /* Before we call $check_access, create a user profile with the current
10708    * process privs since otherwise it just uses the default privs from the
10709    * UAF and might give false positives or negatives.  This only works on
10710    * VMS versions v6.0 and later since that's when sys$create_user_profile
10711    * became available.
10712    */
10713
10714   /* get current process privs and username */
10715   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
10716   _ckvmssts(iosb[0]);
10717
10718 #if defined(__VMS_VER) && __VMS_VER >= 60000000
10719
10720   /* find out the space required for the profile */
10721   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
10722                                     &usrprodsc.dsc$w_length,0));
10723
10724   /* allocate space for the profile and get it filled in */
10725   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
10726   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10727   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
10728                                     &usrprodsc.dsc$w_length,0));
10729
10730   /* use the profile to check access to the file; free profile & analyze results */
10731   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
10732   PerlMem_free(usrprodsc.dsc$a_pointer);
10733   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
10734
10735 #else
10736
10737   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
10738
10739 #endif
10740
10741   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
10742       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
10743       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
10744     set_vaxc_errno(retsts);
10745     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10746     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
10747     else set_errno(ENOENT);
10748     if (fileified != NULL)
10749       PerlMem_free(fileified);
10750     return FALSE;
10751   }
10752   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
10753     if (fileified != NULL)
10754       PerlMem_free(fileified);
10755     return TRUE;
10756   }
10757   _ckvmssts(retsts);
10758
10759   if (fileified != NULL)
10760     PerlMem_free(fileified);
10761   return FALSE;  /* Should never get here */
10762
10763 }
10764
10765 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
10766 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
10767  * subset of the applicable information.
10768  */
10769 bool
10770 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
10771 {
10772   return cando_by_name_int
10773         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
10774 }  /* end of cando() */
10775 /*}}}*/
10776
10777
10778 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
10779 I32
10780 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
10781 {
10782    return cando_by_name_int(bit, effective, fname, 0);
10783
10784 }  /* end of cando_by_name() */
10785 /*}}}*/
10786
10787
10788 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
10789 int
10790 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
10791 {
10792   if (!fstat(fd,(stat_t *) statbufp)) {
10793     char *cptr;
10794     char *vms_filename;
10795     vms_filename = PerlMem_malloc(VMS_MAXRSS);
10796     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
10797
10798     /* Save name for cando by name in VMS format */
10799     cptr = getname(fd, vms_filename, 1);
10800
10801     /* This should not happen, but just in case */
10802     if (cptr == NULL) {
10803         statbufp->st_devnam[0] = 0;
10804     }
10805     else {
10806         /* Make sure that the saved name fits in 255 characters */
10807         cptr = do_rmsexpand
10808                        (vms_filename,
10809                         statbufp->st_devnam,
10810                         0,
10811                         NULL,
10812                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
10813                         NULL,
10814                         NULL);
10815         if (cptr == NULL)
10816             statbufp->st_devnam[0] = 0;
10817     }
10818     PerlMem_free(vms_filename);
10819
10820     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10821     VMS_DEVICE_ENCODE
10822         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10823
10824 #   ifdef RTL_USES_UTC
10825 #   ifdef VMSISH_TIME
10826     if (VMSISH_TIME) {
10827       statbufp->st_mtime = _toloc(statbufp->st_mtime);
10828       statbufp->st_atime = _toloc(statbufp->st_atime);
10829       statbufp->st_ctime = _toloc(statbufp->st_ctime);
10830     }
10831 #   endif
10832 #   else
10833 #   ifdef VMSISH_TIME
10834     if (!VMSISH_TIME) { /* Return UTC instead of local time */
10835 #   else
10836     if (1) {
10837 #   endif
10838       statbufp->st_mtime = _toutc(statbufp->st_mtime);
10839       statbufp->st_atime = _toutc(statbufp->st_atime);
10840       statbufp->st_ctime = _toutc(statbufp->st_ctime);
10841     }
10842 #endif
10843     return 0;
10844   }
10845   return -1;
10846
10847 }  /* end of flex_fstat() */
10848 /*}}}*/
10849
10850 #if !defined(__VAX) && __CRTL_VER >= 80200000
10851 #ifdef lstat
10852 #undef lstat
10853 #endif
10854 #else
10855 #ifdef lstat
10856 #undef lstat
10857 #endif
10858 #define lstat(_x, _y) stat(_x, _y)
10859 #endif
10860
10861 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
10862
10863 static int
10864 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
10865 {
10866     char fileified[VMS_MAXRSS];
10867     char temp_fspec[VMS_MAXRSS];
10868     char *save_spec;
10869     int retval = -1;
10870     int saved_errno, saved_vaxc_errno;
10871
10872     if (!fspec) return retval;
10873     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
10874     strcpy(temp_fspec, fspec);
10875
10876     if (decc_bug_devnull != 0) {
10877       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
10878         memset(statbufp,0,sizeof *statbufp);
10879         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
10880         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
10881         statbufp->st_uid = 0x00010001;
10882         statbufp->st_gid = 0x0001;
10883         time((time_t *)&statbufp->st_mtime);
10884         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
10885         return 0;
10886       }
10887     }
10888
10889     /* Try for a directory name first.  If fspec contains a filename without
10890      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
10891      * and sea:[wine.dark]water. exist, we prefer the directory here.
10892      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
10893      * not sea:[wine.dark]., if the latter exists.  If the intended target is
10894      * the file with null type, specify this by calling flex_stat() with
10895      * a '.' at the end of fspec.
10896      *
10897      * If we are in Posix filespec mode, accept the filename as is.
10898      */
10899 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10900   if (decc_posix_compliant_pathnames == 0) {
10901 #endif
10902     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
10903       if (lstat_flag == 0)
10904         retval = stat(fileified,(stat_t *) statbufp);
10905       else
10906         retval = lstat(fileified,(stat_t *) statbufp);
10907       save_spec = fileified;
10908     }
10909     if (retval) {
10910       if (lstat_flag == 0)
10911         retval = stat(temp_fspec,(stat_t *) statbufp);
10912       else
10913         retval = lstat(temp_fspec,(stat_t *) statbufp);
10914       save_spec = temp_fspec;
10915     }
10916 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10917   } else {
10918     if (lstat_flag == 0)
10919       retval = stat(temp_fspec,(stat_t *) statbufp);
10920     else
10921       retval = lstat(temp_fspec,(stat_t *) statbufp);
10922       save_spec = temp_fspec;
10923   }
10924 #endif
10925     if (!retval) {
10926     char * cptr;
10927       cptr = do_rmsexpand
10928        (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
10929       if (cptr == NULL)
10930         statbufp->st_devnam[0] = 0;
10931
10932       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10933       VMS_DEVICE_ENCODE
10934         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10935 #     ifdef RTL_USES_UTC
10936 #     ifdef VMSISH_TIME
10937       if (VMSISH_TIME) {
10938         statbufp->st_mtime = _toloc(statbufp->st_mtime);
10939         statbufp->st_atime = _toloc(statbufp->st_atime);
10940         statbufp->st_ctime = _toloc(statbufp->st_ctime);
10941       }
10942 #     endif
10943 #     else
10944 #     ifdef VMSISH_TIME
10945       if (!VMSISH_TIME) { /* Return UTC instead of local time */
10946 #     else
10947       if (1) {
10948 #     endif
10949         statbufp->st_mtime = _toutc(statbufp->st_mtime);
10950         statbufp->st_atime = _toutc(statbufp->st_atime);
10951         statbufp->st_ctime = _toutc(statbufp->st_ctime);
10952       }
10953 #     endif
10954     }
10955     /* If we were successful, leave errno where we found it */
10956     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
10957     return retval;
10958
10959 }  /* end of flex_stat_int() */
10960
10961
10962 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
10963 int
10964 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
10965 {
10966    return flex_stat_int(fspec, statbufp, 0);
10967 }
10968 /*}}}*/
10969
10970 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
10971 int
10972 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
10973 {
10974    return flex_stat_int(fspec, statbufp, 1);
10975 }
10976 /*}}}*/
10977
10978
10979 /*{{{char *my_getlogin()*/
10980 /* VMS cuserid == Unix getlogin, except calling sequence */
10981 char *
10982 my_getlogin(void)
10983 {
10984     static char user[L_cuserid];
10985     return cuserid(user);
10986 }
10987 /*}}}*/
10988
10989
10990 /*  rmscopy - copy a file using VMS RMS routines
10991  *
10992  *  Copies contents and attributes of spec_in to spec_out, except owner
10993  *  and protection information.  Name and type of spec_in are used as
10994  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
10995  *  should try to propagate timestamps from the input file to the output file.
10996  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
10997  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
10998  *  propagated to the output file at creation iff the output file specification
10999  *  did not contain an explicit name or type, and the revision date is always
11000  *  updated at the end of the copy operation.  If it is greater than 0, then
11001  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11002  *  other than the revision date should be propagated, and bit 1 indicates
11003  *  that the revision date should be propagated.
11004  *
11005  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11006  *
11007  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11008  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
11009  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
11010  * as part of the Perl standard distribution under the terms of the
11011  * GNU General Public License or the Perl Artistic License.  Copies
11012  * of each may be found in the Perl standard distribution.
11013  */ /* FIXME */
11014 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11015 int
11016 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11017 {
11018     char *vmsin, * vmsout, *esa, *esa_out,
11019          *rsa, *ubf;
11020     unsigned long int i, sts, sts2;
11021     int dna_len;
11022     struct FAB fab_in, fab_out;
11023     struct RAB rab_in, rab_out;
11024     rms_setup_nam(nam);
11025     rms_setup_nam(nam_out);
11026     struct XABDAT xabdat;
11027     struct XABFHC xabfhc;
11028     struct XABRDT xabrdt;
11029     struct XABSUM xabsum;
11030
11031     vmsin = PerlMem_malloc(VMS_MAXRSS);
11032     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11033     vmsout = PerlMem_malloc(VMS_MAXRSS);
11034     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11035     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11036         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11037       PerlMem_free(vmsin);
11038       PerlMem_free(vmsout);
11039       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11040       return 0;
11041     }
11042
11043     esa = PerlMem_malloc(VMS_MAXRSS);
11044     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11045     fab_in = cc$rms_fab;
11046     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11047     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11048     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11049     fab_in.fab$l_fop = FAB$M_SQO;
11050     rms_bind_fab_nam(fab_in, nam);
11051     fab_in.fab$l_xab = (void *) &xabdat;
11052
11053     rsa = PerlMem_malloc(VMS_MAXRSS);
11054     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11055     rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11056     rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11057     rms_nam_esl(nam) = 0;
11058     rms_nam_rsl(nam) = 0;
11059     rms_nam_esll(nam) = 0;
11060     rms_nam_rsll(nam) = 0;
11061 #ifdef NAM$M_NO_SHORT_UPCASE
11062     if (decc_efs_case_preserve)
11063         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11064 #endif
11065
11066     xabdat = cc$rms_xabdat;        /* To get creation date */
11067     xabdat.xab$l_nxt = (void *) &xabfhc;
11068
11069     xabfhc = cc$rms_xabfhc;        /* To get record length */
11070     xabfhc.xab$l_nxt = (void *) &xabsum;
11071
11072     xabsum = cc$rms_xabsum;        /* To get key and area information */
11073
11074     if (!((sts = sys$open(&fab_in)) & 1)) {
11075       PerlMem_free(vmsin);
11076       PerlMem_free(vmsout);
11077       PerlMem_free(esa);
11078       PerlMem_free(rsa);
11079       set_vaxc_errno(sts);
11080       switch (sts) {
11081         case RMS$_FNF: case RMS$_DNF:
11082           set_errno(ENOENT); break;
11083         case RMS$_DIR:
11084           set_errno(ENOTDIR); break;
11085         case RMS$_DEV:
11086           set_errno(ENODEV); break;
11087         case RMS$_SYN:
11088           set_errno(EINVAL); break;
11089         case RMS$_PRV:
11090           set_errno(EACCES); break;
11091         default:
11092           set_errno(EVMSERR);
11093       }
11094       return 0;
11095     }
11096
11097     nam_out = nam;
11098     fab_out = fab_in;
11099     fab_out.fab$w_ifi = 0;
11100     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11101     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11102     fab_out.fab$l_fop = FAB$M_SQO;
11103     rms_bind_fab_nam(fab_out, nam_out);
11104     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11105     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11106     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11107     esa_out = PerlMem_malloc(VMS_MAXRSS);
11108     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11109     rms_set_rsa(nam_out, NULL, 0);
11110     rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11111
11112     if (preserve_dates == 0) {  /* Act like DCL COPY */
11113       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11114       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
11115       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11116         PerlMem_free(vmsin);
11117         PerlMem_free(vmsout);
11118         PerlMem_free(esa);
11119         PerlMem_free(rsa);
11120         PerlMem_free(esa_out);
11121         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11122         set_vaxc_errno(sts);
11123         return 0;
11124       }
11125       fab_out.fab$l_xab = (void *) &xabdat;
11126       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11127         preserve_dates = 1;
11128     }
11129     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
11130       preserve_dates =0;      /* bitmask from this point forward   */
11131
11132     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11133     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11134       PerlMem_free(vmsin);
11135       PerlMem_free(vmsout);
11136       PerlMem_free(esa);
11137       PerlMem_free(rsa);
11138       PerlMem_free(esa_out);
11139       set_vaxc_errno(sts);
11140       switch (sts) {
11141         case RMS$_DNF:
11142           set_errno(ENOENT); break;
11143         case RMS$_DIR:
11144           set_errno(ENOTDIR); break;
11145         case RMS$_DEV:
11146           set_errno(ENODEV); break;
11147         case RMS$_SYN:
11148           set_errno(EINVAL); break;
11149         case RMS$_PRV:
11150           set_errno(EACCES); break;
11151         default:
11152           set_errno(EVMSERR);
11153       }
11154       return 0;
11155     }
11156     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
11157     if (preserve_dates & 2) {
11158       /* sys$close() will process xabrdt, not xabdat */
11159       xabrdt = cc$rms_xabrdt;
11160 #ifndef __GNUC__
11161       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11162 #else
11163       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11164        * is unsigned long[2], while DECC & VAXC use a struct */
11165       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11166 #endif
11167       fab_out.fab$l_xab = (void *) &xabrdt;
11168     }
11169
11170     ubf = PerlMem_malloc(32256);
11171     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11172     rab_in = cc$rms_rab;
11173     rab_in.rab$l_fab = &fab_in;
11174     rab_in.rab$l_rop = RAB$M_BIO;
11175     rab_in.rab$l_ubf = ubf;
11176     rab_in.rab$w_usz = 32256;
11177     if (!((sts = sys$connect(&rab_in)) & 1)) {
11178       sys$close(&fab_in); sys$close(&fab_out);
11179       PerlMem_free(vmsin);
11180       PerlMem_free(vmsout);
11181       PerlMem_free(esa);
11182       PerlMem_free(ubf);
11183       PerlMem_free(rsa);
11184       PerlMem_free(esa_out);
11185       set_errno(EVMSERR); set_vaxc_errno(sts);
11186       return 0;
11187     }
11188
11189     rab_out = cc$rms_rab;
11190     rab_out.rab$l_fab = &fab_out;
11191     rab_out.rab$l_rbf = ubf;
11192     if (!((sts = sys$connect(&rab_out)) & 1)) {
11193       sys$close(&fab_in); sys$close(&fab_out);
11194       PerlMem_free(vmsin);
11195       PerlMem_free(vmsout);
11196       PerlMem_free(esa);
11197       PerlMem_free(ubf);
11198       PerlMem_free(rsa);
11199       PerlMem_free(esa_out);
11200       set_errno(EVMSERR); set_vaxc_errno(sts);
11201       return 0;
11202     }
11203
11204     while ((sts = sys$read(&rab_in))) {  /* always true  */
11205       if (sts == RMS$_EOF) break;
11206       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11207       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11208         sys$close(&fab_in); sys$close(&fab_out);
11209         PerlMem_free(vmsin);
11210         PerlMem_free(vmsout);
11211         PerlMem_free(esa);
11212         PerlMem_free(ubf);
11213         PerlMem_free(rsa);
11214         PerlMem_free(esa_out);
11215         set_errno(EVMSERR); set_vaxc_errno(sts);
11216         return 0;
11217       }
11218     }
11219
11220
11221     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
11222     sys$close(&fab_in);  sys$close(&fab_out);
11223     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11224     if (!(sts & 1)) {
11225       PerlMem_free(vmsin);
11226       PerlMem_free(vmsout);
11227       PerlMem_free(esa);
11228       PerlMem_free(ubf);
11229       PerlMem_free(rsa);
11230       PerlMem_free(esa_out);
11231       set_errno(EVMSERR); set_vaxc_errno(sts);
11232       return 0;
11233     }
11234
11235     PerlMem_free(vmsin);
11236     PerlMem_free(vmsout);
11237     PerlMem_free(esa);
11238     PerlMem_free(ubf);
11239     PerlMem_free(rsa);
11240     PerlMem_free(esa_out);
11241     return 1;
11242
11243 }  /* end of rmscopy() */
11244 /*}}}*/
11245
11246
11247 /***  The following glue provides 'hooks' to make some of the routines
11248  * from this file available from Perl.  These routines are sufficiently
11249  * basic, and are required sufficiently early in the build process,
11250  * that's it's nice to have them available to miniperl as well as the
11251  * full Perl, so they're set up here instead of in an extension.  The
11252  * Perl code which handles importation of these names into a given
11253  * package lives in [.VMS]Filespec.pm in @INC.
11254  */
11255
11256 void
11257 rmsexpand_fromperl(pTHX_ CV *cv)
11258 {
11259   dXSARGS;
11260   char *fspec, *defspec = NULL, *rslt;
11261   STRLEN n_a;
11262   int fs_utf8, dfs_utf8;
11263
11264   fs_utf8 = 0;
11265   dfs_utf8 = 0;
11266   if (!items || items > 2)
11267     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11268   fspec = SvPV(ST(0),n_a);
11269   fs_utf8 = SvUTF8(ST(0));
11270   if (!fspec || !*fspec) XSRETURN_UNDEF;
11271   if (items == 2) {
11272     defspec = SvPV(ST(1),n_a);
11273     dfs_utf8 = SvUTF8(ST(1));
11274   }
11275   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11276   ST(0) = sv_newmortal();
11277   if (rslt != NULL) {
11278     sv_usepvn(ST(0),rslt,strlen(rslt));
11279     if (fs_utf8) {
11280         SvUTF8_on(ST(0));
11281     }
11282   }
11283   XSRETURN(1);
11284 }
11285
11286 void
11287 vmsify_fromperl(pTHX_ CV *cv)
11288 {
11289   dXSARGS;
11290   char *vmsified;
11291   STRLEN n_a;
11292   int utf8_fl;
11293
11294   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11295   utf8_fl = SvUTF8(ST(0));
11296   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11297   ST(0) = sv_newmortal();
11298   if (vmsified != NULL) {
11299     sv_usepvn(ST(0),vmsified,strlen(vmsified));
11300     if (utf8_fl) {
11301         SvUTF8_on(ST(0));
11302     }
11303   }
11304   XSRETURN(1);
11305 }
11306
11307 void
11308 unixify_fromperl(pTHX_ CV *cv)
11309 {
11310   dXSARGS;
11311   char *unixified;
11312   STRLEN n_a;
11313   int utf8_fl;
11314
11315   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11316   utf8_fl = SvUTF8(ST(0));
11317   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11318   ST(0) = sv_newmortal();
11319   if (unixified != NULL) {
11320     sv_usepvn(ST(0),unixified,strlen(unixified));
11321     if (utf8_fl) {
11322         SvUTF8_on(ST(0));
11323     }
11324   }
11325   XSRETURN(1);
11326 }
11327
11328 void
11329 fileify_fromperl(pTHX_ CV *cv)
11330 {
11331   dXSARGS;
11332   char *fileified;
11333   STRLEN n_a;
11334   int utf8_fl;
11335
11336   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11337   utf8_fl = SvUTF8(ST(0));
11338   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11339   ST(0) = sv_newmortal();
11340   if (fileified != NULL) {
11341     sv_usepvn(ST(0),fileified,strlen(fileified));
11342     if (utf8_fl) {
11343         SvUTF8_on(ST(0));
11344     }
11345   }
11346   XSRETURN(1);
11347 }
11348
11349 void
11350 pathify_fromperl(pTHX_ CV *cv)
11351 {
11352   dXSARGS;
11353   char *pathified;
11354   STRLEN n_a;
11355   int utf8_fl;
11356
11357   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11358   utf8_fl = SvUTF8(ST(0));
11359   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11360   ST(0) = sv_newmortal();
11361   if (pathified != NULL) {
11362     sv_usepvn(ST(0),pathified,strlen(pathified));
11363     if (utf8_fl) {
11364         SvUTF8_on(ST(0));
11365     }
11366   }
11367   XSRETURN(1);
11368 }
11369
11370 void
11371 vmspath_fromperl(pTHX_ CV *cv)
11372 {
11373   dXSARGS;
11374   char *vmspath;
11375   STRLEN n_a;
11376   int utf8_fl;
11377
11378   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11379   utf8_fl = SvUTF8(ST(0));
11380   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11381   ST(0) = sv_newmortal();
11382   if (vmspath != NULL) {
11383     sv_usepvn(ST(0),vmspath,strlen(vmspath));
11384     if (utf8_fl) {
11385         SvUTF8_on(ST(0));
11386     }
11387   }
11388   XSRETURN(1);
11389 }
11390
11391 void
11392 unixpath_fromperl(pTHX_ CV *cv)
11393 {
11394   dXSARGS;
11395   char *unixpath;
11396   STRLEN n_a;
11397   int utf8_fl;
11398
11399   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11400   utf8_fl = SvUTF8(ST(0));
11401   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11402   ST(0) = sv_newmortal();
11403   if (unixpath != NULL) {
11404     sv_usepvn(ST(0),unixpath,strlen(unixpath));
11405     if (utf8_fl) {
11406         SvUTF8_on(ST(0));
11407     }
11408   }
11409   XSRETURN(1);
11410 }
11411
11412 void
11413 candelete_fromperl(pTHX_ CV *cv)
11414 {
11415   dXSARGS;
11416   char *fspec, *fsp;
11417   SV *mysv;
11418   IO *io;
11419   STRLEN n_a;
11420
11421   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11422
11423   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11424   Newx(fspec, VMS_MAXRSS, char);
11425   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11426   if (SvTYPE(mysv) == SVt_PVGV) {
11427     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11428       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11429       ST(0) = &PL_sv_no;
11430       Safefree(fspec);
11431       XSRETURN(1);
11432     }
11433     fsp = fspec;
11434   }
11435   else {
11436     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11437       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11438       ST(0) = &PL_sv_no;
11439       Safefree(fspec);
11440       XSRETURN(1);
11441     }
11442   }
11443
11444   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11445   Safefree(fspec);
11446   XSRETURN(1);
11447 }
11448
11449 void
11450 rmscopy_fromperl(pTHX_ CV *cv)
11451 {
11452   dXSARGS;
11453   char *inspec, *outspec, *inp, *outp;
11454   int date_flag;
11455   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11456                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11457   unsigned long int sts;
11458   SV *mysv;
11459   IO *io;
11460   STRLEN n_a;
11461
11462   if (items < 2 || items > 3)
11463     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11464
11465   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11466   Newx(inspec, VMS_MAXRSS, char);
11467   if (SvTYPE(mysv) == SVt_PVGV) {
11468     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11469       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11470       ST(0) = &PL_sv_no;
11471       Safefree(inspec);
11472       XSRETURN(1);
11473     }
11474     inp = inspec;
11475   }
11476   else {
11477     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11478       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11479       ST(0) = &PL_sv_no;
11480       Safefree(inspec);
11481       XSRETURN(1);
11482     }
11483   }
11484   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11485   Newx(outspec, VMS_MAXRSS, char);
11486   if (SvTYPE(mysv) == SVt_PVGV) {
11487     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11488       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11489       ST(0) = &PL_sv_no;
11490       Safefree(inspec);
11491       Safefree(outspec);
11492       XSRETURN(1);
11493     }
11494     outp = outspec;
11495   }
11496   else {
11497     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11498       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11499       ST(0) = &PL_sv_no;
11500       Safefree(inspec);
11501       Safefree(outspec);
11502       XSRETURN(1);
11503     }
11504   }
11505   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11506
11507   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11508   Safefree(inspec);
11509   Safefree(outspec);
11510   XSRETURN(1);
11511 }
11512
11513 /* The mod2fname is limited to shorter filenames by design, so it should
11514  * not be modified to support longer EFS pathnames
11515  */
11516 void
11517 mod2fname(pTHX_ CV *cv)
11518 {
11519   dXSARGS;
11520   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11521        workbuff[NAM$C_MAXRSS*1 + 1];
11522   int total_namelen = 3, counter, num_entries;
11523   /* ODS-5 ups this, but we want to be consistent, so... */
11524   int max_name_len = 39;
11525   AV *in_array = (AV *)SvRV(ST(0));
11526
11527   num_entries = av_len(in_array);
11528
11529   /* All the names start with PL_. */
11530   strcpy(ultimate_name, "PL_");
11531
11532   /* Clean up our working buffer */
11533   Zero(work_name, sizeof(work_name), char);
11534
11535   /* Run through the entries and build up a working name */
11536   for(counter = 0; counter <= num_entries; counter++) {
11537     /* If it's not the first name then tack on a __ */
11538     if (counter) {
11539       strcat(work_name, "__");
11540     }
11541     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11542                            PL_na));
11543   }
11544
11545   /* Check to see if we actually have to bother...*/
11546   if (strlen(work_name) + 3 <= max_name_len) {
11547     strcat(ultimate_name, work_name);
11548   } else {
11549     /* It's too darned big, so we need to go strip. We use the same */
11550     /* algorithm as xsubpp does. First, strip out doubled __ */
11551     char *source, *dest, last;
11552     dest = workbuff;
11553     last = 0;
11554     for (source = work_name; *source; source++) {
11555       if (last == *source && last == '_') {
11556         continue;
11557       }
11558       *dest++ = *source;
11559       last = *source;
11560     }
11561     /* Go put it back */
11562     strcpy(work_name, workbuff);
11563     /* Is it still too big? */
11564     if (strlen(work_name) + 3 > max_name_len) {
11565       /* Strip duplicate letters */
11566       last = 0;
11567       dest = workbuff;
11568       for (source = work_name; *source; source++) {
11569         if (last == toupper(*source)) {
11570         continue;
11571         }
11572         *dest++ = *source;
11573         last = toupper(*source);
11574       }
11575       strcpy(work_name, workbuff);
11576     }
11577
11578     /* Is it *still* too big? */
11579     if (strlen(work_name) + 3 > max_name_len) {
11580       /* Too bad, we truncate */
11581       work_name[max_name_len - 2] = 0;
11582     }
11583     strcat(ultimate_name, work_name);
11584   }
11585
11586   /* Okay, return it */
11587   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11588   XSRETURN(1);
11589 }
11590
11591 void
11592 hushexit_fromperl(pTHX_ CV *cv)
11593 {
11594     dXSARGS;
11595
11596     if (items > 0) {
11597         VMSISH_HUSHED = SvTRUE(ST(0));
11598     }
11599     ST(0) = boolSV(VMSISH_HUSHED);
11600     XSRETURN(1);
11601 }
11602
11603
11604 PerlIO *
11605 Perl_vms_start_glob
11606    (pTHX_ SV *tmpglob,
11607     IO *io)
11608 {
11609     PerlIO *fp;
11610     struct vs_str_st *rslt;
11611     char *vmsspec;
11612     char *rstr;
11613     char *begin, *cp;
11614     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11615     PerlIO *tmpfp;
11616     STRLEN i;
11617     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11618     struct dsc$descriptor_vs rsdsc;
11619     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11620     unsigned long hasver = 0, isunix = 0;
11621     unsigned long int lff_flags = 0;
11622     int rms_sts;
11623
11624 #ifdef VMS_LONGNAME_SUPPORT
11625     lff_flags = LIB$M_FIL_LONG_NAMES;
11626 #endif
11627     /* The Newx macro will not allow me to assign a smaller array
11628      * to the rslt pointer, so we will assign it to the begin char pointer
11629      * and then copy the value into the rslt pointer.
11630      */
11631     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11632     rslt = (struct vs_str_st *)begin;
11633     rslt->length = 0;
11634     rstr = &rslt->str[0];
11635     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11636     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11637     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11638     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11639
11640     Newx(vmsspec, VMS_MAXRSS, char);
11641
11642         /* We could find out if there's an explicit dev/dir or version
11643            by peeking into lib$find_file's internal context at
11644            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11645            but that's unsupported, so I don't want to do it now and
11646            have it bite someone in the future. */
11647         /* Fix-me: vms_split_path() is the only way to do this, the
11648            existing method will fail with many legal EFS or UNIX specifications
11649          */
11650
11651     cp = SvPV(tmpglob,i);
11652
11653     for (; i; i--) {
11654         if (cp[i] == ';') hasver = 1;
11655         if (cp[i] == '.') {
11656             if (sts) hasver = 1;
11657             else sts = 1;
11658         }
11659         if (cp[i] == '/') {
11660             hasdir = isunix = 1;
11661             break;
11662         }
11663         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11664             hasdir = 1;
11665             break;
11666         }
11667     }
11668     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11669         Stat_t st;
11670         int stat_sts;
11671         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11672         if (!stat_sts && S_ISDIR(st.st_mode)) {
11673             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
11674             ok = (wilddsc.dsc$a_pointer != NULL);
11675         }
11676         else {
11677             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
11678             ok = (wilddsc.dsc$a_pointer != NULL);
11679         }
11680         if (ok)
11681             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11682
11683         /* If not extended character set, replace ? with % */
11684         /* With extended character set, ? is a wildcard single character */
11685         if (!decc_efs_case_preserve) {
11686             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11687                 if (*cp == '?') *cp = '%';
11688         }
11689         sts = SS$_NORMAL;
11690         while (ok && $VMS_STATUS_SUCCESS(sts)) {
11691          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11692          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11693
11694             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11695                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
11696             if (!$VMS_STATUS_SUCCESS(sts))
11697                 break;
11698
11699             /* with varying string, 1st word of buffer contains result length */
11700             rstr[rslt->length] = '\0';
11701
11702              /* Find where all the components are */
11703              v_sts = vms_split_path
11704                        (rstr,
11705                         &v_spec,
11706                         &v_len,
11707                         &r_spec,
11708                         &r_len,
11709                         &d_spec,
11710                         &d_len,
11711                         &n_spec,
11712                         &n_len,
11713                         &e_spec,
11714                         &e_len,
11715                         &vs_spec,
11716                         &vs_len);
11717
11718             /* If no version on input, truncate the version on output */
11719             if (!hasver && (vs_len > 0)) {
11720                 *vs_spec = '\0';
11721                 vs_len = 0;
11722
11723                 /* No version & a null extension on UNIX handling */
11724                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
11725                     e_len = 0;
11726                     *e_spec = '\0';
11727                 }
11728             }
11729
11730             if (!decc_efs_case_preserve) {
11731                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
11732             }
11733
11734             if (hasdir) {
11735                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
11736                 begin = rstr;
11737             }
11738             else {
11739                 /* Start with the name */
11740                 begin = n_spec;
11741             }
11742             strcat(begin,"\n");
11743             ok = (PerlIO_puts(tmpfp,begin) != EOF);
11744         }
11745         if (cxt) (void)lib$find_file_end(&cxt);
11746         if (ok && sts != RMS$_NMF &&
11747             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
11748         if (!ok) {
11749             if (!(sts & 1)) {
11750                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
11751             }
11752             PerlIO_close(tmpfp);
11753             fp = NULL;
11754         }
11755         else {
11756             PerlIO_rewind(tmpfp);
11757             IoTYPE(io) = IoTYPE_RDONLY;
11758             IoIFP(io) = fp = tmpfp;
11759             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
11760         }
11761     }
11762     Safefree(vmsspec);
11763     Safefree(rslt);
11764     return fp;
11765 }
11766
11767 #ifdef HAS_SYMLINK
11768 static char *
11769 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
11770
11771 void
11772 vms_realpath_fromperl(pTHX_ CV *cv)
11773 {
11774   dXSARGS;
11775   char *fspec, *rslt_spec, *rslt;
11776   STRLEN n_a;
11777
11778   if (!items || items != 1)
11779     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
11780
11781   fspec = SvPV(ST(0),n_a);
11782   if (!fspec || !*fspec) XSRETURN_UNDEF;
11783
11784   Newx(rslt_spec, VMS_MAXRSS + 1, char);
11785   rslt = do_vms_realpath(fspec, rslt_spec, NULL);
11786   ST(0) = sv_newmortal();
11787   if (rslt != NULL)
11788     sv_usepvn(ST(0),rslt,strlen(rslt));
11789   else
11790     Safefree(rslt_spec);
11791   XSRETURN(1);
11792 }
11793 #endif
11794
11795 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11796 int do_vms_case_tolerant(void);
11797
11798 void
11799 vms_case_tolerant_fromperl(pTHX_ CV *cv)
11800 {
11801   dXSARGS;
11802   ST(0) = boolSV(do_vms_case_tolerant());
11803   XSRETURN(1);
11804 }
11805 #endif
11806
11807 void
11808 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
11809                           struct interp_intern *dst)
11810 {
11811     memcpy(dst,src,sizeof(struct interp_intern));
11812 }
11813
11814 void
11815 Perl_sys_intern_clear(pTHX)
11816 {
11817 }
11818
11819 void
11820 Perl_sys_intern_init(pTHX)
11821 {
11822     unsigned int ix = RAND_MAX;
11823     double x;
11824
11825     VMSISH_HUSHED = 0;
11826
11827     /* fix me later to track running under GNV */
11828     /* this allows some limited testing */
11829     MY_POSIX_EXIT = decc_filename_unix_report;
11830
11831     x = (float)ix;
11832     MY_INV_RAND_MAX = 1./x;
11833 }
11834
11835 void
11836 init_os_extras(void)
11837 {
11838   dTHX;
11839   char* file = __FILE__;
11840   if (decc_disable_to_vms_logname_translation) {
11841     no_translate_barewords = TRUE;
11842   } else {
11843     no_translate_barewords = FALSE;
11844   }
11845
11846   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
11847   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
11848   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
11849   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
11850   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
11851   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
11852   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
11853   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
11854   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
11855   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
11856   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
11857 #ifdef HAS_SYMLINK
11858   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
11859 #endif
11860 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11861   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
11862 #endif
11863
11864   store_pipelocs(aTHX);         /* will redo any earlier attempts */
11865
11866   return;
11867 }
11868
11869 #ifdef HAS_SYMLINK
11870
11871 #if __CRTL_VER == 80200000
11872 /* This missed getting in to the DECC SDK for 8.2 */
11873 char *realpath(const char *file_name, char * resolved_name, ...);
11874 #endif
11875
11876 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
11877 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
11878  * The perl fallback routine to provide realpath() is not as efficient
11879  * on OpenVMS.
11880  */
11881 static char *
11882 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11883 {
11884     return realpath(filespec, outbuf);
11885 }
11886
11887 /*}}}*/
11888 /* External entry points */
11889 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11890 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
11891 #else
11892 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11893 { return NULL; }
11894 #endif
11895
11896
11897 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11898 /* case_tolerant */
11899
11900 /*{{{int do_vms_case_tolerant(void)*/
11901 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
11902  * controlled by a process setting.
11903  */
11904 int do_vms_case_tolerant(void)
11905 {
11906     return vms_process_case_tolerant;
11907 }
11908 /*}}}*/
11909 /* External entry points */
11910 int Perl_vms_case_tolerant(void)
11911 { return do_vms_case_tolerant(); }
11912 #else
11913 int Perl_vms_case_tolerant(void)
11914 { return vms_process_case_tolerant; }
11915 #endif
11916
11917
11918  /* Start of DECC RTL Feature handling */
11919
11920 static int sys_trnlnm
11921    (const char * logname,
11922     char * value,
11923     int value_len)
11924 {
11925     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
11926     const unsigned long attr = LNM$M_CASE_BLIND;
11927     struct dsc$descriptor_s name_dsc;
11928     int status;
11929     unsigned short result;
11930     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
11931                                 {0, 0, 0, 0}};
11932
11933     name_dsc.dsc$w_length = strlen(logname);
11934     name_dsc.dsc$a_pointer = (char *)logname;
11935     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11936     name_dsc.dsc$b_class = DSC$K_CLASS_S;
11937
11938     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
11939
11940     if ($VMS_STATUS_SUCCESS(status)) {
11941
11942          /* Null terminate and return the string */
11943         /*--------------------------------------*/
11944         value[result] = 0;
11945     }
11946
11947     return status;
11948 }
11949
11950 static int sys_crelnm
11951    (const char * logname,
11952     const char * value)
11953 {
11954     int ret_val;
11955     const char * proc_table = "LNM$PROCESS_TABLE";
11956     struct dsc$descriptor_s proc_table_dsc;
11957     struct dsc$descriptor_s logname_dsc;
11958     struct itmlst_3 item_list[2];
11959
11960     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
11961     proc_table_dsc.dsc$w_length = strlen(proc_table);
11962     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11963     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
11964
11965     logname_dsc.dsc$a_pointer = (char *) logname;
11966     logname_dsc.dsc$w_length = strlen(logname);
11967     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11968     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
11969
11970     item_list[0].buflen = strlen(value);
11971     item_list[0].itmcode = LNM$_STRING;
11972     item_list[0].bufadr = (char *)value;
11973     item_list[0].retlen = NULL;
11974
11975     item_list[1].buflen = 0;
11976     item_list[1].itmcode = 0;
11977
11978     ret_val = sys$crelnm
11979                        (NULL,
11980                         (const struct dsc$descriptor_s *)&proc_table_dsc,
11981                         (const struct dsc$descriptor_s *)&logname_dsc,
11982                         NULL,
11983                         (const struct item_list_3 *) item_list);
11984
11985     return ret_val;
11986 }
11987
11988 /* C RTL Feature settings */
11989
11990 static int set_features
11991    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
11992     int (* cli_routine)(void),  /* Not documented */
11993     void *image_info)           /* Not documented */
11994 {
11995     int status;
11996     int s;
11997     int dflt;
11998     char* str;
11999     char val_str[10];
12000 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12001     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12002     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12003     unsigned long case_perm;
12004     unsigned long case_image;
12005 #endif
12006
12007     /* Allow an exception to bring Perl into the VMS debugger */
12008     vms_debug_on_exception = 0;
12009     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12010     if ($VMS_STATUS_SUCCESS(status)) {
12011        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12012          vms_debug_on_exception = 1;
12013        else
12014          vms_debug_on_exception = 0;
12015     }
12016
12017     /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
12018     vms_vtf7_filenames = 0;
12019     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12020     if ($VMS_STATUS_SUCCESS(status)) {
12021        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12022          vms_vtf7_filenames = 1;
12023        else
12024          vms_vtf7_filenames = 0;
12025     }
12026
12027     /* Dectect running under GNV Bash or other UNIX like shell */
12028 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12029     gnv_unix_shell = 0;
12030     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12031     if ($VMS_STATUS_SUCCESS(status)) {
12032        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12033          gnv_unix_shell = 1;
12034          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12035          set_feature_default("DECC$EFS_CHARSET", 1);
12036          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12037          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12038          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12039          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12040        }
12041        else
12042          gnv_unix_shell = 0;
12043     }
12044 #endif
12045
12046     /* hacks to see if known bugs are still present for testing */
12047
12048     /* Readdir is returning filenames in VMS syntax always */
12049     decc_bug_readdir_efs1 = 1;
12050     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12051     if ($VMS_STATUS_SUCCESS(status)) {
12052        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12053          decc_bug_readdir_efs1 = 1;
12054        else
12055          decc_bug_readdir_efs1 = 0;
12056     }
12057
12058     /* PCP mode requires creating /dev/null special device file */
12059     decc_bug_devnull = 0;
12060     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12061     if ($VMS_STATUS_SUCCESS(status)) {
12062        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12063           decc_bug_devnull = 1;
12064        else
12065           decc_bug_devnull = 0;
12066     }
12067
12068     /* fgetname returning a VMS name in UNIX mode */
12069     decc_bug_fgetname = 1;
12070     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12071     if ($VMS_STATUS_SUCCESS(status)) {
12072       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12073         decc_bug_fgetname = 1;
12074       else
12075         decc_bug_fgetname = 0;
12076     }
12077
12078     /* UNIX directory names with no paths are broken in a lot of places */
12079     decc_dir_barename = 1;
12080     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12081     if ($VMS_STATUS_SUCCESS(status)) {
12082       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12083         decc_dir_barename = 1;
12084       else
12085         decc_dir_barename = 0;
12086     }
12087
12088 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12089     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12090     if (s >= 0) {
12091         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12092         if (decc_disable_to_vms_logname_translation < 0)
12093             decc_disable_to_vms_logname_translation = 0;
12094     }
12095
12096     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12097     if (s >= 0) {
12098         decc_efs_case_preserve = decc$feature_get_value(s, 1);
12099         if (decc_efs_case_preserve < 0)
12100             decc_efs_case_preserve = 0;
12101     }
12102
12103     s = decc$feature_get_index("DECC$EFS_CHARSET");
12104     if (s >= 0) {
12105         decc_efs_charset = decc$feature_get_value(s, 1);
12106         if (decc_efs_charset < 0)
12107             decc_efs_charset = 0;
12108     }
12109
12110     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12111     if (s >= 0) {
12112         decc_filename_unix_report = decc$feature_get_value(s, 1);
12113         if (decc_filename_unix_report > 0)
12114             decc_filename_unix_report = 1;
12115         else
12116             decc_filename_unix_report = 0;
12117     }
12118
12119     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12120     if (s >= 0) {
12121         decc_filename_unix_only = decc$feature_get_value(s, 1);
12122         if (decc_filename_unix_only > 0) {
12123             decc_filename_unix_only = 1;
12124         }
12125         else {
12126             decc_filename_unix_only = 0;
12127         }
12128     }
12129
12130     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12131     if (s >= 0) {
12132         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12133         if (decc_filename_unix_no_version < 0)
12134             decc_filename_unix_no_version = 0;
12135     }
12136
12137     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12138     if (s >= 0) {
12139         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12140         if (decc_readdir_dropdotnotype < 0)
12141             decc_readdir_dropdotnotype = 0;
12142     }
12143
12144     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12145     if ($VMS_STATUS_SUCCESS(status)) {
12146         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12147         if (s >= 0) {
12148             dflt = decc$feature_get_value(s, 4);
12149             if (dflt > 0) {
12150                 decc_disable_posix_root = decc$feature_get_value(s, 1);
12151                 if (decc_disable_posix_root <= 0) {
12152                     decc$feature_set_value(s, 1, 1);
12153                     decc_disable_posix_root = 1;
12154                 }
12155             }
12156             else {
12157                 /* Traditionally Perl assumes this is off */
12158                 decc_disable_posix_root = 1;
12159                 decc$feature_set_value(s, 1, 1);
12160             }
12161         }
12162     }
12163
12164 #if __CRTL_VER >= 80200000
12165     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12166     if (s >= 0) {
12167         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12168         if (decc_posix_compliant_pathnames < 0)
12169             decc_posix_compliant_pathnames = 0;
12170         if (decc_posix_compliant_pathnames > 4)
12171             decc_posix_compliant_pathnames = 0;
12172     }
12173
12174 #endif
12175 #else
12176     status = sys_trnlnm
12177         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12178     if ($VMS_STATUS_SUCCESS(status)) {
12179         val_str[0] = _toupper(val_str[0]);
12180         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12181            decc_disable_to_vms_logname_translation = 1;
12182         }
12183     }
12184
12185 #ifndef __VAX
12186     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12187     if ($VMS_STATUS_SUCCESS(status)) {
12188         val_str[0] = _toupper(val_str[0]);
12189         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12190            decc_efs_case_preserve = 1;
12191         }
12192     }
12193 #endif
12194
12195     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12196     if ($VMS_STATUS_SUCCESS(status)) {
12197         val_str[0] = _toupper(val_str[0]);
12198         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12199            decc_filename_unix_report = 1;
12200         }
12201     }
12202     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12203     if ($VMS_STATUS_SUCCESS(status)) {
12204         val_str[0] = _toupper(val_str[0]);
12205         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12206            decc_filename_unix_only = 1;
12207            decc_filename_unix_report = 1;
12208         }
12209     }
12210     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12211     if ($VMS_STATUS_SUCCESS(status)) {
12212         val_str[0] = _toupper(val_str[0]);
12213         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12214            decc_filename_unix_no_version = 1;
12215         }
12216     }
12217     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12218     if ($VMS_STATUS_SUCCESS(status)) {
12219         val_str[0] = _toupper(val_str[0]);
12220         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12221            decc_readdir_dropdotnotype = 1;
12222         }
12223     }
12224 #endif
12225
12226 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12227
12228      /* Report true case tolerance */
12229     /*----------------------------*/
12230     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12231     if (!$VMS_STATUS_SUCCESS(status))
12232         case_perm = PPROP$K_CASE_BLIND;
12233     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12234     if (!$VMS_STATUS_SUCCESS(status))
12235         case_image = PPROP$K_CASE_BLIND;
12236     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12237         (case_image == PPROP$K_CASE_SENSITIVE))
12238         vms_process_case_tolerant = 0;
12239
12240 #endif
12241
12242
12243     /* CRTL can be initialized past this point, but not before. */
12244 /*    DECC$CRTL_INIT(); */
12245
12246     return SS$_NORMAL;
12247 }
12248
12249 #ifdef __DECC
12250 /* DECC dependent attributes */
12251 #if __DECC_VER < 60560002
12252 #define relative
12253 #define not_executable
12254 #else
12255 #define relative ,rel
12256 #define not_executable ,noexe
12257 #endif
12258 #pragma nostandard
12259 #pragma extern_model save
12260 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12261 #endif
12262         const __align (LONGWORD) int spare[8] = {0};
12263 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
12264 /*                        NOWRT, LONG */
12265 #ifdef __DECC
12266 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
12267         nowrt,noshr relative not_executable
12268 #endif
12269 const long vms_cc_features = (const long)set_features;
12270
12271 /*
12272 ** Force a reference to LIB$INITIALIZE to ensure it
12273 ** exists in the image.
12274 */
12275 int lib$initialize(void);
12276 #ifdef __DECC
12277 #pragma extern_model strict_refdef
12278 #endif
12279     int lib_init_ref = (int) lib$initialize;
12280
12281 #ifdef __DECC
12282 #pragma extern_model restore
12283 #pragma standard
12284 #endif
12285
12286 /*  End of vms.c */