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