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         int trnlen;
1361         strncpy(lnm, key, keylen);
1362         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1363         sv = newSVpvn(eqv, strlen(eqv));
1364       }
1365       else {
1366         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1367       }
1368
1369       SvTAINTED_on(sv);
1370       hv_store(envhv,key,keylen,sv,hash);
1371       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1372     }
1373     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1374       /* get the PPFs for this process, not the subprocess */
1375       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1376       char eqv[LNM$C_NAMLENGTH+1];
1377       int trnlen, i;
1378       for (i = 0; ppfs[i]; i++) {
1379         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1380         sv = newSVpv(eqv,trnlen);
1381         SvTAINTED_on(sv);
1382         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1383       }
1384     }
1385   }
1386   primed = 1;
1387   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1388   if (buf) Safefree(buf);
1389   if (seenhv) SvREFCNT_dec(seenhv);
1390   MUTEX_UNLOCK(&primenv_mutex);
1391   return;
1392
1393 }  /* end of prime_env_iter */
1394 /*}}}*/
1395
1396
1397 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1398 /* Define or delete an element in the same "environment" as
1399  * vmstrnenv().  If an element is to be deleted, it's removed from
1400  * the first place it's found.  If it's to be set, it's set in the
1401  * place designated by the first element of the table vector.
1402  * Like setenv() returns 0 for success, non-zero on error.
1403  */
1404 int
1405 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1406 {
1407     const char *cp1;
1408     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1409     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1410     int nseg = 0, j;
1411     unsigned long int retsts, usermode = PSL$C_USER;
1412     struct itmlst_3 *ile, *ilist;
1413     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1414                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1415                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1416     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1417     $DESCRIPTOR(local,"_LOCAL");
1418
1419     if (!lnm) {
1420         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1421         return SS$_IVLOGNAM;
1422     }
1423
1424     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1425       *cp2 = _toupper(*cp1);
1426       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1427         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1428         return SS$_IVLOGNAM;
1429       }
1430     }
1431     lnmdsc.dsc$w_length = cp1 - lnm;
1432     if (!tabvec || !*tabvec) tabvec = env_tables;
1433
1434     if (!eqv) {  /* we're deleting n element */
1435       for (curtab = 0; tabvec[curtab]; curtab++) {
1436         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1437         int i;
1438           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1439             if ((cp1 = strchr(environ[i],'=')) &&
1440                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1441                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1442 #ifdef HAS_SETENV
1443               return setenv(lnm,"",1) ? vaxc$errno : 0;
1444             }
1445           }
1446           ivenv = 1; retsts = SS$_NOLOGNAM;
1447 #else
1448               if (ckWARN(WARN_INTERNAL))
1449                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1450               ivenv = 1; retsts = SS$_NOSUCHPGM;
1451               break;
1452             }
1453           }
1454 #endif
1455         }
1456         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1457                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1458           unsigned int symtype;
1459           if (tabvec[curtab]->dsc$w_length == 12 &&
1460               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1461               !str$case_blind_compare(&tmpdsc,&local))
1462             symtype = LIB$K_CLI_LOCAL_SYM;
1463           else symtype = LIB$K_CLI_GLOBAL_SYM;
1464           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1465           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1466           if (retsts == LIB$_NOSUCHSYM) continue;
1467           break;
1468         }
1469         else if (!ivlnm) {
1470           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1471           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1472           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1473           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1474           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1475         }
1476       }
1477     }
1478     else {  /* we're defining a value */
1479       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1480 #ifdef HAS_SETENV
1481         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1482 #else
1483         if (ckWARN(WARN_INTERNAL))
1484           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1485         retsts = SS$_NOSUCHPGM;
1486 #endif
1487       }
1488       else {
1489         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1490         eqvdsc.dsc$w_length  = strlen(eqv);
1491         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1492             !str$case_blind_compare(&tmpdsc,&clisym)) {
1493           unsigned int symtype;
1494           if (tabvec[0]->dsc$w_length == 12 &&
1495               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1496                !str$case_blind_compare(&tmpdsc,&local))
1497             symtype = LIB$K_CLI_LOCAL_SYM;
1498           else symtype = LIB$K_CLI_GLOBAL_SYM;
1499           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1500         }
1501         else {
1502           if (!*eqv) eqvdsc.dsc$w_length = 1;
1503           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1504
1505             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1506             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1507               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1508                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1509               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1510               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1511             }
1512
1513             Newx(ilist,nseg+1,struct itmlst_3);
1514             ile = ilist;
1515             if (!ile) {
1516               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1517               return SS$_INSFMEM;
1518             }
1519             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1520
1521             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1522               ile->itmcode = LNM$_STRING;
1523               ile->bufadr = c;
1524               if ((j+1) == nseg) {
1525                 ile->buflen = strlen(c);
1526                 /* in case we are truncating one that's too long */
1527                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1528               }
1529               else {
1530                 ile->buflen = LNM$C_NAMLENGTH;
1531               }
1532             }
1533
1534             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1535             Safefree (ilist);
1536           }
1537           else {
1538             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1539           }
1540         }
1541       }
1542     }
1543     if (!(retsts & 1)) {
1544       switch (retsts) {
1545         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1546         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1547           set_errno(EVMSERR); break;
1548         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1549         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1550           set_errno(EINVAL); break;
1551         case SS$_NOPRIV:
1552           set_errno(EACCES); break;
1553         default:
1554           _ckvmssts(retsts);
1555           set_errno(EVMSERR);
1556        }
1557        set_vaxc_errno(retsts);
1558        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1559     }
1560     else {
1561       /* We reset error values on success because Perl does an hv_fetch()
1562        * before each hv_store(), and if the thing we're setting didn't
1563        * previously exist, we've got a leftover error message.  (Of course,
1564        * this fails in the face of
1565        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1566        * in that the error reported in $! isn't spurious,
1567        * but it's right more often than not.)
1568        */
1569       set_errno(0); set_vaxc_errno(retsts);
1570       return 0;
1571     }
1572
1573 }  /* end of vmssetenv() */
1574 /*}}}*/
1575
1576 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1577 /* This has to be a function since there's a prototype for it in proto.h */
1578 void
1579 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1580 {
1581     if (lnm && *lnm) {
1582       int len = strlen(lnm);
1583       if  (len == 7) {
1584         char uplnm[8];
1585         int i;
1586         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1587         if (!strcmp(uplnm,"DEFAULT")) {
1588           if (eqv && *eqv) my_chdir(eqv);
1589           return;
1590         }
1591     }
1592 #ifndef RTL_USES_UTC
1593     if (len == 6 || len == 2) {
1594       char uplnm[7];
1595       int i;
1596       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1597       uplnm[len] = '\0';
1598       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1599       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1600     }
1601 #endif
1602   }
1603   (void) vmssetenv(lnm,eqv,NULL);
1604 }
1605 /*}}}*/
1606
1607 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1608 /*  vmssetuserlnm
1609  *  sets a user-mode logical in the process logical name table
1610  *  used for redirection of sys$error
1611  */
1612 void
1613 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1614 {
1615     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1616     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1617     unsigned long int iss, attr = LNM$M_CONFINE;
1618     unsigned char acmode = PSL$C_USER;
1619     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1620                                  {0, 0, 0, 0}};
1621     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1622     d_name.dsc$w_length = strlen(name);
1623
1624     lnmlst[0].buflen = strlen(eqv);
1625     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1626
1627     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1628     if (!(iss&1)) lib$signal(iss);
1629 }
1630 /*}}}*/
1631
1632
1633 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1634 /* my_crypt - VMS password hashing
1635  * my_crypt() provides an interface compatible with the Unix crypt()
1636  * C library function, and uses sys$hash_password() to perform VMS
1637  * password hashing.  The quadword hashed password value is returned
1638  * as a NUL-terminated 8 character string.  my_crypt() does not change
1639  * the case of its string arguments; in order to match the behavior
1640  * of LOGINOUT et al., alphabetic characters in both arguments must
1641  *  be upcased by the caller.
1642  *
1643  * - fix me to call ACM services when available
1644  */
1645 char *
1646 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1647 {
1648 #   ifndef UAI$C_PREFERRED_ALGORITHM
1649 #     define UAI$C_PREFERRED_ALGORITHM 127
1650 #   endif
1651     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1652     unsigned short int salt = 0;
1653     unsigned long int sts;
1654     struct const_dsc {
1655         unsigned short int dsc$w_length;
1656         unsigned char      dsc$b_type;
1657         unsigned char      dsc$b_class;
1658         const char *       dsc$a_pointer;
1659     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1660        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1661     struct itmlst_3 uailst[3] = {
1662         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1663         { sizeof salt, UAI$_SALT,    &salt, 0},
1664         { 0,           0,            NULL,  NULL}};
1665     static char hash[9];
1666
1667     usrdsc.dsc$w_length = strlen(usrname);
1668     usrdsc.dsc$a_pointer = usrname;
1669     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1670       switch (sts) {
1671         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1672           set_errno(EACCES);
1673           break;
1674         case RMS$_RNF:
1675           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1676           break;
1677         default:
1678           set_errno(EVMSERR);
1679       }
1680       set_vaxc_errno(sts);
1681       if (sts != RMS$_RNF) return NULL;
1682     }
1683
1684     txtdsc.dsc$w_length = strlen(textpasswd);
1685     txtdsc.dsc$a_pointer = textpasswd;
1686     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1687       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1688     }
1689
1690     return (char *) hash;
1691
1692 }  /* end of my_crypt() */
1693 /*}}}*/
1694
1695
1696 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1697 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1698 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1699
1700 /* fixup barenames that are directories for internal use.
1701  * There have been problems with the consistent handling of UNIX
1702  * style directory names when routines are presented with a name that
1703  * has no directory delimitors at all.  So this routine will eventually
1704  * fix the issue.
1705  */
1706 static char * fixup_bare_dirnames(const char * name)
1707 {
1708   if (decc_disable_to_vms_logname_translation) {
1709 /* fix me */
1710   }
1711   return NULL;
1712 }
1713
1714 /* mp_do_kill_file
1715  * A little hack to get around a bug in some implemenation of remove()
1716  * that do not know how to delete a directory
1717  *
1718  * Delete any file to which user has control access, regardless of whether
1719  * delete access is explicitly allowed.
1720  * Limitations: User must have write access to parent directory.
1721  *              Does not block signals or ASTs; if interrupted in midstream
1722  *              may leave file with an altered ACL.
1723  * HANDLE WITH CARE!
1724  */
1725 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1726 static int
1727 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1728 {
1729     char *vmsname, *rspec;
1730     char *remove_name;
1731     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1732     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1733     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1734     struct myacedef {
1735       unsigned char myace$b_length;
1736       unsigned char myace$b_type;
1737       unsigned short int myace$w_flags;
1738       unsigned long int myace$l_access;
1739       unsigned long int myace$l_ident;
1740     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1741                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1742       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1743      struct itmlst_3
1744        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1745                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1746        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1747        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1748        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1749        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1750
1751     /* Expand the input spec using RMS, since the CRTL remove() and
1752      * system services won't do this by themselves, so we may miss
1753      * a file "hiding" behind a logical name or search list. */
1754     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1755     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1756
1757     if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1758       PerlMem_free(vmsname);
1759       return -1;
1760     }
1761
1762     if (decc_posix_compliant_pathnames) {
1763       /* In POSIX mode, we prefer to remove the UNIX name */
1764       rspec = vmsname;
1765       remove_name = (char *)name;
1766     }
1767     else {
1768       rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1769       if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1770       if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1771         PerlMem_free(rspec);
1772         PerlMem_free(vmsname);
1773         return -1;
1774       }
1775       PerlMem_free(vmsname);
1776       remove_name = rspec;
1777     }
1778
1779 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1780     if (dirflag != 0) {
1781         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1782           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1783           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1784
1785           do_pathify_dirspec(name, remove_name, 0, NULL);
1786           if (!rmdir(remove_name)) {
1787
1788             PerlMem_free(remove_name);
1789             PerlMem_free(rspec);
1790             return 0;   /* Can we just get rid of it? */
1791           }
1792         }
1793         else {
1794           if (!rmdir(remove_name)) {
1795             PerlMem_free(rspec);
1796             return 0;   /* Can we just get rid of it? */
1797           }
1798         }
1799     }
1800     else
1801 #endif
1802       if (!remove(remove_name)) {
1803         PerlMem_free(rspec);
1804         return 0;   /* Can we just get rid of it? */
1805       }
1806
1807     /* If not, can changing protections help? */
1808     if (vaxc$errno != RMS$_PRV) {
1809       PerlMem_free(rspec);
1810       return -1;
1811     }
1812
1813     /* No, so we get our own UIC to use as a rights identifier,
1814      * and the insert an ACE at the head of the ACL which allows us
1815      * to delete the file.
1816      */
1817     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1818     fildsc.dsc$w_length = strlen(rspec);
1819     fildsc.dsc$a_pointer = rspec;
1820     cxt = 0;
1821     newace.myace$l_ident = oldace.myace$l_ident;
1822     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1823       switch (aclsts) {
1824         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1825           set_errno(ENOENT); break;
1826         case RMS$_DIR:
1827           set_errno(ENOTDIR); break;
1828         case RMS$_DEV:
1829           set_errno(ENODEV); break;
1830         case RMS$_SYN: case SS$_INVFILFOROP:
1831           set_errno(EINVAL); break;
1832         case RMS$_PRV:
1833           set_errno(EACCES); break;
1834         default:
1835           _ckvmssts(aclsts);
1836       }
1837       set_vaxc_errno(aclsts);
1838       PerlMem_free(rspec);
1839       return -1;
1840     }
1841     /* Grab any existing ACEs with this identifier in case we fail */
1842     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1843     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1844                     || fndsts == SS$_NOMOREACE ) {
1845       /* Add the new ACE . . . */
1846       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1847         goto yourroom;
1848
1849 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1850       if (dirflag != 0)
1851         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1852           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1853           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1854
1855           do_pathify_dirspec(name, remove_name, 0, NULL);
1856           rmsts = rmdir(remove_name);
1857           PerlMem_free(remove_name);
1858         }
1859         else {
1860         rmsts = rmdir(remove_name);
1861         }
1862       else
1863 #endif
1864         rmsts = remove(remove_name);
1865       if (rmsts) {
1866         /* We blew it - dir with files in it, no write priv for
1867          * parent directory, etc.  Put things back the way they were. */
1868         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1869           goto yourroom;
1870         if (fndsts & 1) {
1871           addlst[0].bufadr = &oldace;
1872           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1873             goto yourroom;
1874         }
1875       }
1876     }
1877
1878     yourroom:
1879     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1880     /* We just deleted it, so of course it's not there.  Some versions of
1881      * VMS seem to return success on the unlock operation anyhow (after all
1882      * the unlock is successful), but others don't.
1883      */
1884     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1885     if (aclsts & 1) aclsts = fndsts;
1886     if (!(aclsts & 1)) {
1887       set_errno(EVMSERR);
1888       set_vaxc_errno(aclsts);
1889       PerlMem_free(rspec);
1890       return -1;
1891     }
1892
1893     PerlMem_free(rspec);
1894     return rmsts;
1895
1896 }  /* end of kill_file() */
1897 /*}}}*/
1898
1899
1900 /*{{{int do_rmdir(char *name)*/
1901 int
1902 Perl_do_rmdir(pTHX_ const char *name)
1903 {
1904     char dirfile[NAM$C_MAXRSS+1];
1905     int retval;
1906     Stat_t st;
1907
1908     if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1909     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1910     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1911     return retval;
1912
1913 }  /* end of do_rmdir */
1914 /*}}}*/
1915
1916 /* kill_file
1917  * Delete any file to which user has control access, regardless of whether
1918  * delete access is explicitly allowed.
1919  * Limitations: User must have write access to parent directory.
1920  *              Does not block signals or ASTs; if interrupted in midstream
1921  *              may leave file with an altered ACL.
1922  * HANDLE WITH CARE!
1923  */
1924 /*{{{int kill_file(char *name)*/
1925 int
1926 Perl_kill_file(pTHX_ const char *name)
1927 {
1928     char rspec[NAM$C_MAXRSS+1];
1929     char *tspec;
1930     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1931     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1932     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1933     struct myacedef {
1934       unsigned char myace$b_length;
1935       unsigned char myace$b_type;
1936       unsigned short int myace$w_flags;
1937       unsigned long int myace$l_access;
1938       unsigned long int myace$l_ident;
1939     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1940                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1941       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1942      struct itmlst_3
1943        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1944                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1945        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1946        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1947        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1948        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1949
1950     /* Expand the input spec using RMS, since the CRTL remove() and
1951      * system services won't do this by themselves, so we may miss
1952      * a file "hiding" behind a logical name or search list. */
1953     tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1954     if (tspec == NULL) return -1;
1955     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1956     /* If not, can changing protections help? */
1957     if (vaxc$errno != RMS$_PRV) return -1;
1958
1959     /* No, so we get our own UIC to use as a rights identifier,
1960      * and the insert an ACE at the head of the ACL which allows us
1961      * to delete the file.
1962      */
1963     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1964     fildsc.dsc$w_length = strlen(rspec);
1965     fildsc.dsc$a_pointer = rspec;
1966     cxt = 0;
1967     newace.myace$l_ident = oldace.myace$l_ident;
1968     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1969       switch (aclsts) {
1970         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1971           set_errno(ENOENT); break;
1972         case RMS$_DIR:
1973           set_errno(ENOTDIR); break;
1974         case RMS$_DEV:
1975           set_errno(ENODEV); break;
1976         case RMS$_SYN: case SS$_INVFILFOROP:
1977           set_errno(EINVAL); break;
1978         case RMS$_PRV:
1979           set_errno(EACCES); break;
1980         default:
1981           _ckvmssts(aclsts);
1982       }
1983       set_vaxc_errno(aclsts);
1984       return -1;
1985     }
1986     /* Grab any existing ACEs with this identifier in case we fail */
1987     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1988     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1989                     || fndsts == SS$_NOMOREACE ) {
1990       /* Add the new ACE . . . */
1991       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1992         goto yourroom;
1993       if ((rmsts = remove(name))) {
1994         /* We blew it - dir with files in it, no write priv for
1995          * parent directory, etc.  Put things back the way they were. */
1996         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1997           goto yourroom;
1998         if (fndsts & 1) {
1999           addlst[0].bufadr = &oldace;
2000           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2001             goto yourroom;
2002         }
2003       }
2004     }
2005
2006     yourroom:
2007     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2008     /* We just deleted it, so of course it's not there.  Some versions of
2009      * VMS seem to return success on the unlock operation anyhow (after all
2010      * the unlock is successful), but others don't.
2011      */
2012     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2013     if (aclsts & 1) aclsts = fndsts;
2014     if (!(aclsts & 1)) {
2015       set_errno(EVMSERR);
2016       set_vaxc_errno(aclsts);
2017       return -1;
2018     }
2019
2020     return rmsts;
2021
2022 }  /* end of kill_file() */
2023 /*}}}*/
2024
2025
2026 /*{{{int my_mkdir(char *,Mode_t)*/
2027 int
2028 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2029 {
2030   STRLEN dirlen = strlen(dir);
2031
2032   /* zero length string sometimes gives ACCVIO */
2033   if (dirlen == 0) return -1;
2034
2035   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2036    * null file name/type.  However, it's commonplace under Unix,
2037    * so we'll allow it for a gain in portability.
2038    */
2039   if (dir[dirlen-1] == '/') {
2040     char *newdir = savepvn(dir,dirlen-1);
2041     int ret = mkdir(newdir,mode);
2042     Safefree(newdir);
2043     return ret;
2044   }
2045   else return mkdir(dir,mode);
2046 }  /* end of my_mkdir */
2047 /*}}}*/
2048
2049 /*{{{int my_chdir(char *)*/
2050 int
2051 Perl_my_chdir(pTHX_ const char *dir)
2052 {
2053   STRLEN dirlen = strlen(dir);
2054
2055   /* zero length string sometimes gives ACCVIO */
2056   if (dirlen == 0) return -1;
2057   const char *dir1;
2058
2059   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2060    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2061    * so that existing scripts do not need to be changed.
2062    */
2063   dir1 = dir;
2064   while ((dirlen > 0) && (*dir1 == ' ')) {
2065     dir1++;
2066     dirlen--;
2067   }
2068
2069   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2070    * that implies
2071    * null file name/type.  However, it's commonplace under Unix,
2072    * so we'll allow it for a gain in portability.
2073    *
2074    * - Preview- '/' will be valid soon on VMS
2075    */
2076   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2077     char *newdir = savepvn(dir1,dirlen-1);
2078     int ret = chdir(newdir);
2079     Safefree(newdir);
2080     return ret;
2081   }
2082   else return chdir(dir1);
2083 }  /* end of my_chdir */
2084 /*}}}*/
2085
2086
2087 /*{{{FILE *my_tmpfile()*/
2088 FILE *
2089 my_tmpfile(void)
2090 {
2091   FILE *fp;
2092   char *cp;
2093
2094   if ((fp = tmpfile())) return fp;
2095
2096   cp = PerlMem_malloc(L_tmpnam+24);
2097   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2098
2099   if (decc_filename_unix_only == 0)
2100     strcpy(cp,"Sys$Scratch:");
2101   else
2102     strcpy(cp,"/tmp/");
2103   tmpnam(cp+strlen(cp));
2104   strcat(cp,".Perltmp");
2105   fp = fopen(cp,"w+","fop=dlt");
2106   PerlMem_free(cp);
2107   return fp;
2108 }
2109 /*}}}*/
2110
2111
2112 #ifndef HOMEGROWN_POSIX_SIGNALS
2113 /*
2114  * The C RTL's sigaction fails to check for invalid signal numbers so we
2115  * help it out a bit.  The docs are correct, but the actual routine doesn't
2116  * do what the docs say it will.
2117  */
2118 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2119 int
2120 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2121                    struct sigaction* oact)
2122 {
2123   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2124         SETERRNO(EINVAL, SS$_INVARG);
2125         return -1;
2126   }
2127   return sigaction(sig, act, oact);
2128 }
2129 /*}}}*/
2130 #endif
2131
2132 #ifdef KILL_BY_SIGPRC
2133 #include <errnodef.h>
2134
2135 /* We implement our own kill() using the undocumented system service
2136    sys$sigprc for one of two reasons:
2137
2138    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2139    target process to do a sys$exit, which usually can't be handled
2140    gracefully...certainly not by Perl and the %SIG{} mechanism.
2141
2142    2.) If the kill() in the CRTL can't be called from a signal
2143    handler without disappearing into the ether, i.e., the signal
2144    it purportedly sends is never trapped. Still true as of VMS 7.3.
2145
2146    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2147    in the target process rather than calling sys$exit.
2148
2149    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2150    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2151    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2152    with condition codes C$_SIG0+nsig*8, catching the exception on the
2153    target process and resignaling with appropriate arguments.
2154
2155    But we don't have that VMS 7.0+ exception handler, so if you
2156    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2157
2158    Also note that SIGTERM is listed in the docs as being "unimplemented",
2159    yet always seems to be signaled with a VMS condition code of 4 (and
2160    correctly handled for that code).  So we hardwire it in.
2161
2162    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2163    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2164    than signalling with an unrecognized (and unhandled by CRTL) code.
2165 */
2166
2167 #define _MY_SIG_MAX 28
2168
2169 static unsigned int
2170 Perl_sig_to_vmscondition_int(int sig)
2171 {
2172     static unsigned int sig_code[_MY_SIG_MAX+1] =
2173     {
2174         0,                  /*  0 ZERO     */
2175         SS$_HANGUP,         /*  1 SIGHUP   */
2176         SS$_CONTROLC,       /*  2 SIGINT   */
2177         SS$_CONTROLY,       /*  3 SIGQUIT  */
2178         SS$_RADRMOD,        /*  4 SIGILL   */
2179         SS$_BREAK,          /*  5 SIGTRAP  */
2180         SS$_OPCCUS,         /*  6 SIGABRT  */
2181         SS$_COMPAT,         /*  7 SIGEMT   */
2182 #ifdef __VAX
2183         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2184 #else
2185         SS$_HPARITH,        /*  8 SIGFPE AXP */
2186 #endif
2187         SS$_ABORT,          /*  9 SIGKILL  */
2188         SS$_ACCVIO,         /* 10 SIGBUS   */
2189         SS$_ACCVIO,         /* 11 SIGSEGV  */
2190         SS$_BADPARAM,       /* 12 SIGSYS   */
2191         SS$_NOMBX,          /* 13 SIGPIPE  */
2192         SS$_ASTFLT,         /* 14 SIGALRM  */
2193         4,                  /* 15 SIGTERM  */
2194         0,                  /* 16 SIGUSR1  */
2195         0,                  /* 17 SIGUSR2  */
2196         0,                  /* 18 */
2197         0,                  /* 19 */
2198         0,                  /* 20 SIGCHLD  */
2199         0,                  /* 21 SIGCONT  */
2200         0,                  /* 22 SIGSTOP  */
2201         0,                  /* 23 SIGTSTP  */
2202         0,                  /* 24 SIGTTIN  */
2203         0,                  /* 25 SIGTTOU  */
2204         0,                  /* 26 */
2205         0,                  /* 27 */
2206         0                   /* 28 SIGWINCH  */
2207     };
2208
2209 #if __VMS_VER >= 60200000
2210     static int initted = 0;
2211     if (!initted) {
2212         initted = 1;
2213         sig_code[16] = C$_SIGUSR1;
2214         sig_code[17] = C$_SIGUSR2;
2215 #if __CRTL_VER >= 70000000
2216         sig_code[20] = C$_SIGCHLD;
2217 #endif
2218 #if __CRTL_VER >= 70300000
2219         sig_code[28] = C$_SIGWINCH;
2220 #endif
2221     }
2222 #endif
2223
2224     if (sig < _SIG_MIN) return 0;
2225     if (sig > _MY_SIG_MAX) return 0;
2226     return sig_code[sig];
2227 }
2228
2229 unsigned int
2230 Perl_sig_to_vmscondition(int sig)
2231 {
2232 #ifdef SS$_DEBUG
2233     if (vms_debug_on_exception != 0)
2234         lib$signal(SS$_DEBUG);
2235 #endif
2236     return Perl_sig_to_vmscondition_int(sig);
2237 }
2238
2239
2240 int
2241 Perl_my_kill(int pid, int sig)
2242 {
2243     dTHX;
2244     int iss;
2245     unsigned int code;
2246     int sys$sigprc(unsigned int *pidadr,
2247                      struct dsc$descriptor_s *prcname,
2248                      unsigned int code);
2249
2250      /* sig 0 means validate the PID */
2251     /*------------------------------*/
2252     if (sig == 0) {
2253         const unsigned long int jpicode = JPI$_PID;
2254         pid_t ret_pid;
2255         int status;
2256         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2257         if ($VMS_STATUS_SUCCESS(status))
2258            return 0;
2259         switch (status) {
2260         case SS$_NOSUCHNODE:
2261         case SS$_UNREACHABLE:
2262         case SS$_NONEXPR:
2263            errno = ESRCH;
2264            break;
2265         case SS$_NOPRIV:
2266            errno = EPERM;
2267            break;
2268         default:
2269            errno = EVMSERR;
2270         }
2271         vaxc$errno=status;
2272         return -1;
2273     }
2274
2275     code = Perl_sig_to_vmscondition_int(sig);
2276
2277     if (!code) {
2278         SETERRNO(EINVAL, SS$_BADPARAM);
2279         return -1;
2280     }
2281
2282     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2283      * signals are to be sent to multiple processes.
2284      *  pid = 0 - all processes in group except ones that the system exempts
2285      *  pid = -1 - all processes except ones that the system exempts
2286      *  pid = -n - all processes in group (abs(n)) except ...
2287      * For now, just report as not supported.
2288      */
2289
2290     if (pid <= 0) {
2291         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2292         return -1;
2293     }
2294
2295     iss = sys$sigprc((unsigned int *)&pid,0,code);
2296     if (iss&1) return 0;
2297
2298     switch (iss) {
2299       case SS$_NOPRIV:
2300         set_errno(EPERM);  break;
2301       case SS$_NONEXPR:
2302       case SS$_NOSUCHNODE:
2303       case SS$_UNREACHABLE:
2304         set_errno(ESRCH);  break;
2305       case SS$_INSFMEM:
2306         set_errno(ENOMEM); break;
2307       default:
2308         _ckvmssts(iss);
2309         set_errno(EVMSERR);
2310     }
2311     set_vaxc_errno(iss);
2312
2313     return -1;
2314 }
2315 #endif
2316
2317 /* Routine to convert a VMS status code to a UNIX status code.
2318 ** More tricky than it appears because of conflicting conventions with
2319 ** existing code.
2320 **
2321 ** VMS status codes are a bit mask, with the least significant bit set for
2322 ** success.
2323 **
2324 ** Special UNIX status of EVMSERR indicates that no translation is currently
2325 ** available, and programs should check the VMS status code.
2326 **
2327 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2328 ** decoding.
2329 */
2330
2331 #ifndef C_FACILITY_NO
2332 #define C_FACILITY_NO 0x350000
2333 #endif
2334 #ifndef DCL_IVVERB
2335 #define DCL_IVVERB 0x38090
2336 #endif
2337
2338 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2339 {
2340 int facility;
2341 int fac_sp;
2342 int msg_no;
2343 int msg_status;
2344 int unix_status;
2345
2346   /* Assume the best or the worst */
2347   if (vms_status & STS$M_SUCCESS)
2348     unix_status = 0;
2349   else
2350     unix_status = EVMSERR;
2351
2352   msg_status = vms_status & ~STS$M_CONTROL;
2353
2354   facility = vms_status & STS$M_FAC_NO;
2355   fac_sp = vms_status & STS$M_FAC_SP;
2356   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2357
2358   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2359     switch(msg_no) {
2360     case SS$_NORMAL:
2361         unix_status = 0;
2362         break;
2363     case SS$_ACCVIO:
2364         unix_status = EFAULT;
2365         break;
2366     case SS$_DEVOFFLINE:
2367         unix_status = EBUSY;
2368         break;
2369     case SS$_CLEARED:
2370         unix_status = ENOTCONN;
2371         break;
2372     case SS$_IVCHAN:
2373     case SS$_IVLOGNAM:
2374     case SS$_BADPARAM:
2375     case SS$_IVLOGTAB:
2376     case SS$_NOLOGNAM:
2377     case SS$_NOLOGTAB:
2378     case SS$_INVFILFOROP:
2379     case SS$_INVARG:
2380     case SS$_NOSUCHID:
2381     case SS$_IVIDENT:
2382         unix_status = EINVAL;
2383         break;
2384     case SS$_UNSUPPORTED:
2385         unix_status = ENOTSUP;
2386         break;
2387     case SS$_FILACCERR:
2388     case SS$_NOGRPPRV:
2389     case SS$_NOSYSPRV:
2390         unix_status = EACCES;
2391         break;
2392     case SS$_DEVICEFULL:
2393         unix_status = ENOSPC;
2394         break;
2395     case SS$_NOSUCHDEV:
2396         unix_status = ENODEV;
2397         break;
2398     case SS$_NOSUCHFILE:
2399     case SS$_NOSUCHOBJECT:
2400         unix_status = ENOENT;
2401         break;
2402     case SS$_ABORT:                                 /* Fatal case */
2403     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2404     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2405         unix_status = EINTR;
2406         break;
2407     case SS$_BUFFEROVF:
2408         unix_status = E2BIG;
2409         break;
2410     case SS$_INSFMEM:
2411         unix_status = ENOMEM;
2412         break;
2413     case SS$_NOPRIV:
2414         unix_status = EPERM;
2415         break;
2416     case SS$_NOSUCHNODE:
2417     case SS$_UNREACHABLE:
2418         unix_status = ESRCH;
2419         break;
2420     case SS$_NONEXPR:
2421         unix_status = ECHILD;
2422         break;
2423     default:
2424         if ((facility == 0) && (msg_no < 8)) {
2425           /* These are not real VMS status codes so assume that they are
2426           ** already UNIX status codes
2427           */
2428           unix_status = msg_no;
2429           break;
2430         }
2431     }
2432   }
2433   else {
2434     /* Translate a POSIX exit code to a UNIX exit code */
2435     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2436         unix_status = (msg_no & 0x07F8) >> 3;
2437     }
2438     else {
2439
2440          /* Documented traditional behavior for handling VMS child exits */
2441         /*--------------------------------------------------------------*/
2442         if (child_flag != 0) {
2443
2444              /* Success / Informational return 0 */
2445             /*----------------------------------*/
2446             if (msg_no & STS$K_SUCCESS)
2447                 return 0;
2448
2449              /* Warning returns 1 */
2450             /*-------------------*/
2451             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2452                 return 1;
2453
2454              /* Everything else pass through the severity bits */
2455             /*------------------------------------------------*/
2456             return (msg_no & STS$M_SEVERITY);
2457         }
2458
2459          /* Normal VMS status to ERRNO mapping attempt */
2460         /*--------------------------------------------*/
2461         switch(msg_status) {
2462         /* case RMS$_EOF: */ /* End of File */
2463         case RMS$_FNF:  /* File Not Found */
2464         case RMS$_DNF:  /* Dir Not Found */
2465                 unix_status = ENOENT;
2466                 break;
2467         case RMS$_RNF:  /* Record Not Found */
2468                 unix_status = ESRCH;
2469                 break;
2470         case RMS$_DIR:
2471                 unix_status = ENOTDIR;
2472                 break;
2473         case RMS$_DEV:
2474                 unix_status = ENODEV;
2475                 break;
2476         case RMS$_IFI:
2477         case RMS$_FAC:
2478         case RMS$_ISI:
2479                 unix_status = EBADF;
2480                 break;
2481         case RMS$_FEX:
2482                 unix_status = EEXIST;
2483                 break;
2484         case RMS$_SYN:
2485         case RMS$_FNM:
2486         case LIB$_INVSTRDES:
2487         case LIB$_INVARG:
2488         case LIB$_NOSUCHSYM:
2489         case LIB$_INVSYMNAM:
2490         case DCL_IVVERB:
2491                 unix_status = EINVAL;
2492                 break;
2493         case CLI$_BUFOVF:
2494         case RMS$_RTB:
2495         case CLI$_TKNOVF:
2496         case CLI$_RSLOVF:
2497                 unix_status = E2BIG;
2498                 break;
2499         case RMS$_PRV:  /* No privilege */
2500         case RMS$_ACC:  /* ACP file access failed */
2501         case RMS$_WLK:  /* Device write locked */
2502                 unix_status = EACCES;
2503                 break;
2504         /* case RMS$_NMF: */  /* No more files */
2505         }
2506     }
2507   }
2508
2509   return unix_status;
2510 }
2511
2512 /* Try to guess at what VMS error status should go with a UNIX errno
2513  * value.  This is hard to do as there could be many possible VMS
2514  * error statuses that caused the errno value to be set.
2515  */
2516
2517 int Perl_unix_status_to_vms(int unix_status)
2518 {
2519 int test_unix_status;
2520
2521      /* Trivial cases first */
2522     /*---------------------*/
2523     if (unix_status == EVMSERR)
2524         return vaxc$errno;
2525
2526      /* Is vaxc$errno sane? */
2527     /*---------------------*/
2528     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2529     if (test_unix_status == unix_status)
2530         return vaxc$errno;
2531
2532      /* If way out of range, must be VMS code already */
2533     /*-----------------------------------------------*/
2534     if (unix_status > EVMSERR)
2535         return unix_status;
2536
2537      /* If out of range, punt */
2538     /*-----------------------*/
2539     if (unix_status > __ERRNO_MAX)
2540         return SS$_ABORT;
2541
2542
2543      /* Ok, now we have to do it the hard way. */
2544     /*----------------------------------------*/
2545     switch(unix_status) {
2546     case 0:     return SS$_NORMAL;
2547     case EPERM: return SS$_NOPRIV;
2548     case ENOENT: return SS$_NOSUCHOBJECT;
2549     case ESRCH: return SS$_UNREACHABLE;
2550     case EINTR: return SS$_ABORT;
2551     /* case EIO: */
2552     /* case ENXIO:  */
2553     case E2BIG: return SS$_BUFFEROVF;
2554     /* case ENOEXEC */
2555     case EBADF: return RMS$_IFI;
2556     case ECHILD: return SS$_NONEXPR;
2557     /* case EAGAIN */
2558     case ENOMEM: return SS$_INSFMEM;
2559     case EACCES: return SS$_FILACCERR;
2560     case EFAULT: return SS$_ACCVIO;
2561     /* case ENOTBLK */
2562     case EBUSY: return SS$_DEVOFFLINE;
2563     case EEXIST: return RMS$_FEX;
2564     /* case EXDEV */
2565     case ENODEV: return SS$_NOSUCHDEV;
2566     case ENOTDIR: return RMS$_DIR;
2567     /* case EISDIR */
2568     case EINVAL: return SS$_INVARG;
2569     /* case ENFILE */
2570     /* case EMFILE */
2571     /* case ENOTTY */
2572     /* case ETXTBSY */
2573     /* case EFBIG */
2574     case ENOSPC: return SS$_DEVICEFULL;
2575     case ESPIPE: return LIB$_INVARG;
2576     /* case EROFS: */
2577     /* case EMLINK: */
2578     /* case EPIPE: */
2579     /* case EDOM */
2580     case ERANGE: return LIB$_INVARG;
2581     /* case EWOULDBLOCK */
2582     /* case EINPROGRESS */
2583     /* case EALREADY */
2584     /* case ENOTSOCK */
2585     /* case EDESTADDRREQ */
2586     /* case EMSGSIZE */
2587     /* case EPROTOTYPE */
2588     /* case ENOPROTOOPT */
2589     /* case EPROTONOSUPPORT */
2590     /* case ESOCKTNOSUPPORT */
2591     /* case EOPNOTSUPP */
2592     /* case EPFNOSUPPORT */
2593     /* case EAFNOSUPPORT */
2594     /* case EADDRINUSE */
2595     /* case EADDRNOTAVAIL */
2596     /* case ENETDOWN */
2597     /* case ENETUNREACH */
2598     /* case ENETRESET */
2599     /* case ECONNABORTED */
2600     /* case ECONNRESET */
2601     /* case ENOBUFS */
2602     /* case EISCONN */
2603     case ENOTCONN: return SS$_CLEARED;
2604     /* case ESHUTDOWN */
2605     /* case ETOOMANYREFS */
2606     /* case ETIMEDOUT */
2607     /* case ECONNREFUSED */
2608     /* case ELOOP */
2609     /* case ENAMETOOLONG */
2610     /* case EHOSTDOWN */
2611     /* case EHOSTUNREACH */
2612     /* case ENOTEMPTY */
2613     /* case EPROCLIM */
2614     /* case EUSERS  */
2615     /* case EDQUOT  */
2616     /* case ENOMSG  */
2617     /* case EIDRM */
2618     /* case EALIGN */
2619     /* case ESTALE */
2620     /* case EREMOTE */
2621     /* case ENOLCK */
2622     /* case ENOSYS */
2623     /* case EFTYPE */
2624     /* case ECANCELED */
2625     /* case EFAIL */
2626     /* case EINPROG */
2627     case ENOTSUP:
2628         return SS$_UNSUPPORTED;
2629     /* case EDEADLK */
2630     /* case ENWAIT */
2631     /* case EILSEQ */
2632     /* case EBADCAT */
2633     /* case EBADMSG */
2634     /* case EABANDONED */
2635     default:
2636         return SS$_ABORT; /* punt */
2637     }
2638
2639   return SS$_ABORT; /* Should not get here */
2640 }
2641
2642
2643 /* default piping mailbox size */
2644 #define PERL_BUFSIZ        512
2645
2646
2647 static void
2648 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2649 {
2650   unsigned long int mbxbufsiz;
2651   static unsigned long int syssize = 0;
2652   unsigned long int dviitm = DVI$_DEVNAM;
2653   char csize[LNM$C_NAMLENGTH+1];
2654   int sts;
2655
2656   if (!syssize) {
2657     unsigned long syiitm = SYI$_MAXBUF;
2658     /*
2659      * Get the SYSGEN parameter MAXBUF
2660      *
2661      * If the logical 'PERL_MBX_SIZE' is defined
2662      * use the value of the logical instead of PERL_BUFSIZ, but
2663      * keep the size between 128 and MAXBUF.
2664      *
2665      */
2666     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2667   }
2668
2669   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2670       mbxbufsiz = atoi(csize);
2671   } else {
2672       mbxbufsiz = PERL_BUFSIZ;
2673   }
2674   if (mbxbufsiz < 128) mbxbufsiz = 128;
2675   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2676
2677   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2678
2679   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2680   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2681
2682 }  /* end of create_mbx() */
2683
2684
2685 /*{{{  my_popen and my_pclose*/
2686
2687 typedef struct _iosb           IOSB;
2688 typedef struct _iosb*         pIOSB;
2689 typedef struct _pipe           Pipe;
2690 typedef struct _pipe*         pPipe;
2691 typedef struct pipe_details    Info;
2692 typedef struct pipe_details*  pInfo;
2693 typedef struct _srqp            RQE;
2694 typedef struct _srqp*          pRQE;
2695 typedef struct _tochildbuf      CBuf;
2696 typedef struct _tochildbuf*    pCBuf;
2697
2698 struct _iosb {
2699     unsigned short status;
2700     unsigned short count;
2701     unsigned long  dvispec;
2702 };
2703
2704 #pragma member_alignment save
2705 #pragma nomember_alignment quadword
2706 struct _srqp {          /* VMS self-relative queue entry */
2707     unsigned long qptr[2];
2708 };
2709 #pragma member_alignment restore
2710 static RQE  RQE_ZERO = {0,0};
2711
2712 struct _tochildbuf {
2713     RQE             q;
2714     int             eof;
2715     unsigned short  size;
2716     char            *buf;
2717 };
2718
2719 struct _pipe {
2720     RQE            free;
2721     RQE            wait;
2722     int            fd_out;
2723     unsigned short chan_in;
2724     unsigned short chan_out;
2725     char          *buf;
2726     unsigned int   bufsize;
2727     IOSB           iosb;
2728     IOSB           iosb2;
2729     int           *pipe_done;
2730     int            retry;
2731     int            type;
2732     int            shut_on_empty;
2733     int            need_wake;
2734     pPipe         *home;
2735     pInfo          info;
2736     pCBuf          curr;
2737     pCBuf          curr2;
2738 #if defined(PERL_IMPLICIT_CONTEXT)
2739     void            *thx;           /* Either a thread or an interpreter */
2740                                     /* pointer, depending on how we're built */
2741 #endif
2742 };
2743
2744
2745 struct pipe_details
2746 {
2747     pInfo           next;
2748     PerlIO *fp;  /* file pointer to pipe mailbox */
2749     int useFILE; /* using stdio, not perlio */
2750     int pid;   /* PID of subprocess */
2751     int mode;  /* == 'r' if pipe open for reading */
2752     int done;  /* subprocess has completed */
2753     int waiting; /* waiting for completion/closure */
2754     int             closing;        /* my_pclose is closing this pipe */
2755     unsigned long   completion;     /* termination status of subprocess */
2756     pPipe           in;             /* pipe in to sub */
2757     pPipe           out;            /* pipe out of sub */
2758     pPipe           err;            /* pipe of sub's sys$error */
2759     int             in_done;        /* true when in pipe finished */
2760     int             out_done;
2761     int             err_done;
2762 };
2763
2764 struct exit_control_block
2765 {
2766     struct exit_control_block *flink;
2767     unsigned long int   (*exit_routine)();
2768     unsigned long int arg_count;
2769     unsigned long int *status_address;
2770     unsigned long int exit_status;
2771 };
2772
2773 typedef struct _closed_pipes    Xpipe;
2774 typedef struct _closed_pipes*  pXpipe;
2775
2776 struct _closed_pipes {
2777     int             pid;            /* PID of subprocess */
2778     unsigned long   completion;     /* termination status of subprocess */
2779 };
2780 #define NKEEPCLOSED 50
2781 static Xpipe closed_list[NKEEPCLOSED];
2782 static int   closed_index = 0;
2783 static int   closed_num = 0;
2784
2785 #define RETRY_DELAY     "0 ::0.20"
2786 #define MAX_RETRY              50
2787
2788 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2789 static unsigned long mypid;
2790 static unsigned long delaytime[2];
2791
2792 static pInfo open_pipes = NULL;
2793 static $DESCRIPTOR(nl_desc, "NL:");
2794
2795 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2796
2797
2798
2799 static unsigned long int
2800 pipe_exit_routine(pTHX)
2801 {
2802     pInfo info;
2803     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2804     int sts, did_stuff, need_eof, j;
2805
2806     /*
2807         flush any pending i/o
2808     */
2809     info = open_pipes;
2810     while (info) {
2811         if (info->fp) {
2812            if (!info->useFILE)
2813                PerlIO_flush(info->fp);   /* first, flush data */
2814            else
2815                fflush((FILE *)info->fp);
2816         }
2817         info = info->next;
2818     }
2819
2820     /*
2821      next we try sending an EOF...ignore if doesn't work, make sure we
2822      don't hang
2823     */
2824     did_stuff = 0;
2825     info = open_pipes;
2826
2827     while (info) {
2828       int need_eof;
2829       _ckvmssts_noperl(sys$setast(0));
2830       if (info->in && !info->in->shut_on_empty) {
2831         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2832                           0, 0, 0, 0, 0, 0));
2833         info->waiting = 1;
2834         did_stuff = 1;
2835       }
2836       _ckvmssts_noperl(sys$setast(1));
2837       info = info->next;
2838     }
2839
2840     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2841
2842     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2843         int nwait = 0;
2844
2845         info = open_pipes;
2846         while (info) {
2847           _ckvmssts_noperl(sys$setast(0));
2848           if (info->waiting && info->done)
2849                 info->waiting = 0;
2850           nwait += info->waiting;
2851           _ckvmssts_noperl(sys$setast(1));
2852           info = info->next;
2853         }
2854         if (!nwait) break;
2855         sleep(1);
2856     }
2857
2858     did_stuff = 0;
2859     info = open_pipes;
2860     while (info) {
2861       _ckvmssts_noperl(sys$setast(0));
2862       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2863         sts = sys$forcex(&info->pid,0,&abort);
2864         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2865         did_stuff = 1;
2866       }
2867       _ckvmssts_noperl(sys$setast(1));
2868       info = info->next;
2869     }
2870
2871     /* again, wait for effect */
2872
2873     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2874         int nwait = 0;
2875
2876         info = open_pipes;
2877         while (info) {
2878           _ckvmssts_noperl(sys$setast(0));
2879           if (info->waiting && info->done)
2880                 info->waiting = 0;
2881           nwait += info->waiting;
2882           _ckvmssts_noperl(sys$setast(1));
2883           info = info->next;
2884         }
2885         if (!nwait) break;
2886         sleep(1);
2887     }
2888
2889     info = open_pipes;
2890     while (info) {
2891       _ckvmssts_noperl(sys$setast(0));
2892       if (!info->done) {  /* We tried to be nice . . . */
2893         sts = sys$delprc(&info->pid,0);
2894         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2895         info->done = 1;  /* sys$delprc is as done as we're going to get. */
2896       }
2897       _ckvmssts_noperl(sys$setast(1));
2898       info = info->next;
2899     }
2900
2901     while(open_pipes) {
2902       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2903       else if (!(sts & 1)) retsts = sts;
2904     }
2905     return retsts;
2906 }
2907
2908 static struct exit_control_block pipe_exitblock =
2909        {(struct exit_control_block *) 0,
2910         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2911
2912 static void pipe_mbxtofd_ast(pPipe p);
2913 static void pipe_tochild1_ast(pPipe p);
2914 static void pipe_tochild2_ast(pPipe p);
2915
2916 static void
2917 popen_completion_ast(pInfo info)
2918 {
2919   pInfo i = open_pipes;
2920   int iss;
2921   int sts;
2922   pXpipe x;
2923
2924   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2925   closed_list[closed_index].pid = info->pid;
2926   closed_list[closed_index].completion = info->completion;
2927   closed_index++;
2928   if (closed_index == NKEEPCLOSED)
2929     closed_index = 0;
2930   closed_num++;
2931
2932   while (i) {
2933     if (i == info) break;
2934     i = i->next;
2935   }
2936   if (!i) return;       /* unlinked, probably freed too */
2937
2938   info->done = TRUE;
2939
2940 /*
2941     Writing to subprocess ...
2942             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2943
2944             chan_out may be waiting for "done" flag, or hung waiting
2945             for i/o completion to child...cancel the i/o.  This will
2946             put it into "snarf mode" (done but no EOF yet) that discards
2947             input.
2948
2949     Output from subprocess (stdout, stderr) needs to be flushed and
2950     shut down.   We try sending an EOF, but if the mbx is full the pipe
2951     routine should still catch the "shut_on_empty" flag, telling it to
2952     use immediate-style reads so that "mbx empty" -> EOF.
2953
2954
2955 */
2956   if (info->in && !info->in_done) {               /* only for mode=w */
2957         if (info->in->shut_on_empty && info->in->need_wake) {
2958             info->in->need_wake = FALSE;
2959             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2960         } else {
2961             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2962         }
2963   }
2964
2965   if (info->out && !info->out_done) {             /* were we also piping output? */
2966       info->out->shut_on_empty = TRUE;
2967       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2968       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2969       _ckvmssts_noperl(iss);
2970   }
2971
2972   if (info->err && !info->err_done) {        /* we were piping stderr */
2973         info->err->shut_on_empty = TRUE;
2974         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2975         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2976         _ckvmssts_noperl(iss);
2977   }
2978   _ckvmssts_noperl(sys$setef(pipe_ef));
2979
2980 }
2981
2982 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2983 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2984
2985 /*
2986     we actually differ from vmstrnenv since we use this to
2987     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2988     are pointing to the same thing
2989 */
2990
2991 static unsigned short
2992 popen_translate(pTHX_ char *logical, char *result)
2993 {
2994     int iss;
2995     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2996     $DESCRIPTOR(d_log,"");
2997     struct _il3 {
2998         unsigned short length;
2999         unsigned short code;
3000         char *         buffer_addr;
3001         unsigned short *retlenaddr;
3002     } itmlst[2];
3003     unsigned short l, ifi;
3004
3005     d_log.dsc$a_pointer = logical;
3006     d_log.dsc$w_length  = strlen(logical);
3007
3008     itmlst[0].code = LNM$_STRING;
3009     itmlst[0].length = 255;
3010     itmlst[0].buffer_addr = result;
3011     itmlst[0].retlenaddr = &l;
3012
3013     itmlst[1].code = 0;
3014     itmlst[1].length = 0;
3015     itmlst[1].buffer_addr = 0;
3016     itmlst[1].retlenaddr = 0;
3017
3018     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3019     if (iss == SS$_NOLOGNAM) {
3020         iss = SS$_NORMAL;
3021         l = 0;
3022     }
3023     if (!(iss&1)) lib$signal(iss);
3024     result[l] = '\0';
3025 /*
3026     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3027     strip it off and return the ifi, if any
3028 */
3029     ifi  = 0;
3030     if (result[0] == 0x1b && result[1] == 0x00) {
3031         memmove(&ifi,result+2,2);
3032         strcpy(result,result+4);
3033     }
3034     return ifi;     /* this is the RMS internal file id */
3035 }
3036
3037 static void pipe_infromchild_ast(pPipe p);
3038
3039 /*
3040     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3041     inside an AST routine without worrying about reentrancy and which Perl
3042     memory allocator is being used.
3043
3044     We read data and queue up the buffers, then spit them out one at a
3045     time to the output mailbox when the output mailbox is ready for one.
3046
3047 */
3048 #define INITIAL_TOCHILDQUEUE  2
3049
3050 static pPipe
3051 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3052 {
3053     pPipe p;
3054     pCBuf b;
3055     char mbx1[64], mbx2[64];
3056     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3057                                       DSC$K_CLASS_S, mbx1},
3058                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3059                                       DSC$K_CLASS_S, mbx2};
3060     unsigned int dviitm = DVI$_DEVBUFSIZ;
3061     int j, n;
3062
3063     n = sizeof(Pipe);
3064     _ckvmssts(lib$get_vm(&n, &p));
3065
3066     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3067     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3068     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3069
3070     p->buf           = 0;
3071     p->shut_on_empty = FALSE;
3072     p->need_wake     = FALSE;
3073     p->type          = 0;
3074     p->retry         = 0;
3075     p->iosb.status   = SS$_NORMAL;
3076     p->iosb2.status  = SS$_NORMAL;
3077     p->free          = RQE_ZERO;
3078     p->wait          = RQE_ZERO;
3079     p->curr          = 0;
3080     p->curr2         = 0;
3081     p->info          = 0;
3082 #ifdef PERL_IMPLICIT_CONTEXT
3083     p->thx           = aTHX;
3084 #endif
3085
3086     n = sizeof(CBuf) + p->bufsize;
3087
3088     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3089         _ckvmssts(lib$get_vm(&n, &b));
3090         b->buf = (char *) b + sizeof(CBuf);
3091         _ckvmssts(lib$insqhi(b, &p->free));
3092     }
3093
3094     pipe_tochild2_ast(p);
3095     pipe_tochild1_ast(p);
3096     strcpy(wmbx, mbx1);
3097     strcpy(rmbx, mbx2);
3098     return p;
3099 }
3100
3101 /*  reads the MBX Perl is writing, and queues */
3102
3103 static void
3104 pipe_tochild1_ast(pPipe p)
3105 {
3106     pCBuf b = p->curr;
3107     int iss = p->iosb.status;
3108     int eof = (iss == SS$_ENDOFFILE);
3109     int sts;
3110 #ifdef PERL_IMPLICIT_CONTEXT
3111     pTHX = p->thx;
3112 #endif
3113
3114     if (p->retry) {
3115         if (eof) {
3116             p->shut_on_empty = TRUE;
3117             b->eof     = TRUE;
3118             _ckvmssts(sys$dassgn(p->chan_in));
3119         } else  {
3120             _ckvmssts(iss);
3121         }
3122
3123         b->eof  = eof;
3124         b->size = p->iosb.count;
3125         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3126         if (p->need_wake) {
3127             p->need_wake = FALSE;
3128             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3129         }
3130     } else {
3131         p->retry = 1;   /* initial call */
3132     }
3133
3134     if (eof) {                  /* flush the free queue, return when done */
3135         int n = sizeof(CBuf) + p->bufsize;
3136         while (1) {
3137             iss = lib$remqti(&p->free, &b);
3138             if (iss == LIB$_QUEWASEMP) return;
3139             _ckvmssts(iss);
3140             _ckvmssts(lib$free_vm(&n, &b));
3141         }
3142     }
3143
3144     iss = lib$remqti(&p->free, &b);
3145     if (iss == LIB$_QUEWASEMP) {
3146         int n = sizeof(CBuf) + p->bufsize;
3147         _ckvmssts(lib$get_vm(&n, &b));
3148         b->buf = (char *) b + sizeof(CBuf);
3149     } else {
3150        _ckvmssts(iss);
3151     }
3152
3153     p->curr = b;
3154     iss = sys$qio(0,p->chan_in,
3155              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3156              &p->iosb,
3157              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3158     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3159     _ckvmssts(iss);
3160 }
3161
3162
3163 /* writes queued buffers to output, waits for each to complete before
3164    doing the next */
3165
3166 static void
3167 pipe_tochild2_ast(pPipe p)
3168 {
3169     pCBuf b = p->curr2;
3170     int iss = p->iosb2.status;
3171     int n = sizeof(CBuf) + p->bufsize;
3172     int done = (p->info && p->info->done) ||
3173               iss == SS$_CANCEL || iss == SS$_ABORT;
3174 #if defined(PERL_IMPLICIT_CONTEXT)
3175     pTHX = p->thx;
3176 #endif
3177
3178     do {
3179         if (p->type) {         /* type=1 has old buffer, dispose */
3180             if (p->shut_on_empty) {
3181                 _ckvmssts(lib$free_vm(&n, &b));
3182             } else {
3183                 _ckvmssts(lib$insqhi(b, &p->free));
3184             }
3185             p->type = 0;
3186         }
3187
3188         iss = lib$remqti(&p->wait, &b);
3189         if (iss == LIB$_QUEWASEMP) {
3190             if (p->shut_on_empty) {
3191                 if (done) {
3192                     _ckvmssts(sys$dassgn(p->chan_out));
3193                     *p->pipe_done = TRUE;
3194                     _ckvmssts(sys$setef(pipe_ef));
3195                 } else {
3196                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3197                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3198                 }
3199                 return;
3200             }
3201             p->need_wake = TRUE;
3202             return;
3203         }
3204         _ckvmssts(iss);
3205         p->type = 1;
3206     } while (done);
3207
3208
3209     p->curr2 = b;
3210     if (b->eof) {
3211         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3212             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3213     } else {
3214         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3215             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3216     }
3217
3218     return;
3219
3220 }
3221
3222
3223 static pPipe
3224 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3225 {
3226     pPipe p;
3227     char mbx1[64], mbx2[64];
3228     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3229                                       DSC$K_CLASS_S, mbx1},
3230                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3231                                       DSC$K_CLASS_S, mbx2};
3232     unsigned int dviitm = DVI$_DEVBUFSIZ;
3233
3234     int n = sizeof(Pipe);
3235     _ckvmssts(lib$get_vm(&n, &p));
3236     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3237     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3238
3239     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3240     n = p->bufsize * sizeof(char);
3241     _ckvmssts(lib$get_vm(&n, &p->buf));
3242     p->shut_on_empty = FALSE;
3243     p->info   = 0;
3244     p->type   = 0;
3245     p->iosb.status = SS$_NORMAL;
3246 #if defined(PERL_IMPLICIT_CONTEXT)
3247     p->thx = aTHX;
3248 #endif
3249     pipe_infromchild_ast(p);
3250
3251     strcpy(wmbx, mbx1);
3252     strcpy(rmbx, mbx2);
3253     return p;
3254 }
3255
3256 static void
3257 pipe_infromchild_ast(pPipe p)
3258 {
3259     int iss = p->iosb.status;
3260     int eof = (iss == SS$_ENDOFFILE);
3261     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3262     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3263 #if defined(PERL_IMPLICIT_CONTEXT)
3264     pTHX = p->thx;
3265 #endif
3266
3267     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3268         _ckvmssts(sys$dassgn(p->chan_out));
3269         p->chan_out = 0;
3270     }
3271
3272     /* read completed:
3273             input shutdown if EOF from self (done or shut_on_empty)
3274             output shutdown if closing flag set (my_pclose)
3275             send data/eof from child or eof from self
3276             otherwise, re-read (snarf of data from child)
3277     */
3278
3279     if (p->type == 1) {
3280         p->type = 0;
3281         if (myeof && p->chan_in) {                  /* input shutdown */
3282             _ckvmssts(sys$dassgn(p->chan_in));
3283             p->chan_in = 0;
3284         }
3285
3286         if (p->chan_out) {
3287             if (myeof || kideof) {      /* pass EOF to parent */
3288                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3289                               pipe_infromchild_ast, p,
3290                               0, 0, 0, 0, 0, 0));
3291                 return;
3292             } else if (eof) {       /* eat EOF --- fall through to read*/
3293
3294             } else {                /* transmit data */
3295                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3296                               pipe_infromchild_ast,p,
3297                               p->buf, p->iosb.count, 0, 0, 0, 0));
3298                 return;
3299             }
3300         }
3301     }
3302
3303     /*  everything shut? flag as done */
3304
3305     if (!p->chan_in && !p->chan_out) {
3306         *p->pipe_done = TRUE;
3307         _ckvmssts(sys$setef(pipe_ef));
3308         return;
3309     }
3310
3311     /* write completed (or read, if snarfing from child)
3312             if still have input active,
3313                queue read...immediate mode if shut_on_empty so we get EOF if empty
3314             otherwise,
3315                check if Perl reading, generate EOFs as needed
3316     */
3317
3318     if (p->type == 0) {
3319         p->type = 1;
3320         if (p->chan_in) {
3321             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3322                           pipe_infromchild_ast,p,
3323                           p->buf, p->bufsize, 0, 0, 0, 0);
3324             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3325             _ckvmssts(iss);
3326         } else {           /* send EOFs for extra reads */
3327             p->iosb.status = SS$_ENDOFFILE;
3328             p->iosb.dvispec = 0;
3329             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3330                       0, 0, 0,
3331                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3332         }
3333     }
3334 }
3335
3336 static pPipe
3337 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3338 {
3339     pPipe p;
3340     char mbx[64];
3341     unsigned long dviitm = DVI$_DEVBUFSIZ;
3342     struct stat s;
3343     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3344                                       DSC$K_CLASS_S, mbx};
3345     int n = sizeof(Pipe);
3346
3347     /* things like terminals and mbx's don't need this filter */
3348     if (fd && fstat(fd,&s) == 0) {
3349         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3350         char device[65];
3351         unsigned short dev_len;
3352         struct dsc$descriptor_s d_dev;
3353         char * cptr;
3354         struct item_list_3 items[3];
3355         int status;
3356         unsigned short dvi_iosb[4];
3357
3358         cptr = getname(fd, out, 1);
3359         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3360         d_dev.dsc$a_pointer = out;
3361         d_dev.dsc$w_length = strlen(out);
3362         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3363         d_dev.dsc$b_class = DSC$K_CLASS_S;
3364
3365         items[0].len = 4;
3366         items[0].code = DVI$_DEVCHAR;
3367         items[0].bufadr = &devchar;
3368         items[0].retadr = NULL;
3369         items[1].len = 64;
3370         items[1].code = DVI$_FULLDEVNAM;
3371         items[1].bufadr = device;
3372         items[1].retadr = &dev_len;
3373         items[2].len = 0;
3374         items[2].code = 0;
3375
3376         status = sys$getdviw
3377                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3378         _ckvmssts(status);
3379         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3380             device[dev_len] = 0;
3381
3382             if (!(devchar & DEV$M_DIR)) {
3383                 strcpy(out, device);
3384                 return 0;
3385             }
3386         }
3387     }
3388
3389     _ckvmssts(lib$get_vm(&n, &p));
3390     p->fd_out = dup(fd);
3391     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3392     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3393     n = (p->bufsize+1) * sizeof(char);
3394     _ckvmssts(lib$get_vm(&n, &p->buf));
3395     p->shut_on_empty = FALSE;
3396     p->retry = 0;
3397     p->info  = 0;
3398     strcpy(out, mbx);
3399
3400     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3401                   pipe_mbxtofd_ast, p,
3402                   p->buf, p->bufsize, 0, 0, 0, 0));
3403
3404     return p;
3405 }
3406
3407 static void
3408 pipe_mbxtofd_ast(pPipe p)
3409 {
3410     int iss = p->iosb.status;
3411     int done = p->info->done;
3412     int iss2;
3413     int eof = (iss == SS$_ENDOFFILE);
3414     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3415     int err = !(iss&1) && !eof;
3416 #if defined(PERL_IMPLICIT_CONTEXT)
3417     pTHX = p->thx;
3418 #endif
3419
3420     if (done && myeof) {               /* end piping */
3421         close(p->fd_out);
3422         sys$dassgn(p->chan_in);
3423         *p->pipe_done = TRUE;
3424         _ckvmssts(sys$setef(pipe_ef));
3425         return;
3426     }
3427
3428     if (!err && !eof) {             /* good data to send to file */
3429         p->buf[p->iosb.count] = '\n';
3430         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3431         if (iss2 < 0) {
3432             p->retry++;
3433             if (p->retry < MAX_RETRY) {
3434                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3435                 return;
3436             }
3437         }
3438         p->retry = 0;
3439     } else if (err) {
3440         _ckvmssts(iss);
3441     }
3442
3443
3444     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3445           pipe_mbxtofd_ast, p,
3446           p->buf, p->bufsize, 0, 0, 0, 0);
3447     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3448     _ckvmssts(iss);
3449 }
3450
3451
3452 typedef struct _pipeloc     PLOC;
3453 typedef struct _pipeloc*   pPLOC;
3454
3455 struct _pipeloc {
3456     pPLOC   next;
3457     char    dir[NAM$C_MAXRSS+1];
3458 };
3459 static pPLOC  head_PLOC = 0;
3460
3461 void
3462 free_pipelocs(pTHX_ void *head)
3463 {
3464     pPLOC p, pnext;
3465     pPLOC *pHead = (pPLOC *)head;
3466
3467     p = *pHead;
3468     while (p) {
3469         pnext = p->next;
3470         PerlMem_free(p);
3471         p = pnext;
3472     }
3473     *pHead = 0;
3474 }
3475
3476 static void
3477 store_pipelocs(pTHX)
3478 {
3479     int    i;
3480     pPLOC  p;
3481     AV    *av = 0;
3482     SV    *dirsv;
3483     GV    *gv;
3484     char  *dir, *x;
3485     char  *unixdir;
3486     char  temp[NAM$C_MAXRSS+1];
3487     STRLEN n_a;
3488
3489     if (head_PLOC)
3490         free_pipelocs(aTHX_ &head_PLOC);
3491
3492 /*  the . directory from @INC comes last */
3493
3494     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3495     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3496     p->next = head_PLOC;
3497     head_PLOC = p;
3498     strcpy(p->dir,"./");
3499
3500 /*  get the directory from $^X */
3501
3502     unixdir = PerlMem_malloc(VMS_MAXRSS);
3503     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3504
3505 #ifdef PERL_IMPLICIT_CONTEXT
3506     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3507 #else
3508     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3509 #endif
3510         strcpy(temp, PL_origargv[0]);
3511         x = strrchr(temp,']');
3512         if (x == NULL) {
3513         x = strrchr(temp,'>');
3514           if (x == NULL) {
3515             /* It could be a UNIX path */
3516             x = strrchr(temp,'/');
3517           }
3518         }
3519         if (x)
3520           x[1] = '\0';
3521         else {
3522           /* Got a bare name, so use default directory */
3523           temp[0] = '.';
3524           temp[1] = '\0';
3525         }
3526
3527         if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3528             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3529             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3530             p->next = head_PLOC;
3531             head_PLOC = p;
3532             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3533             p->dir[NAM$C_MAXRSS] = '\0';
3534         }
3535     }
3536
3537 /*  reverse order of @INC entries, skip "." since entered above */
3538
3539 #ifdef PERL_IMPLICIT_CONTEXT
3540     if (aTHX)
3541 #endif
3542     if (PL_incgv) av = GvAVn(PL_incgv);
3543
3544     for (i = 0; av && i <= AvFILL(av); i++) {
3545         dirsv = *av_fetch(av,i,TRUE);
3546
3547         if (SvROK(dirsv)) continue;
3548         dir = SvPVx(dirsv,n_a);
3549         if (strcmp(dir,".") == 0) continue;
3550         if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3551             continue;
3552
3553         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3554         p->next = head_PLOC;
3555         head_PLOC = p;
3556         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3557         p->dir[NAM$C_MAXRSS] = '\0';
3558     }
3559
3560 /* most likely spot (ARCHLIB) put first in the list */
3561
3562 #ifdef ARCHLIB_EXP
3563     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3564         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3565         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3566         p->next = head_PLOC;
3567         head_PLOC = p;
3568         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3569         p->dir[NAM$C_MAXRSS] = '\0';
3570     }
3571 #endif
3572     PerlMem_free(unixdir);
3573 }
3574
3575 static I32
3576 Perl_cando_by_name_int
3577    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3578 #if !defined(PERL_IMPLICIT_CONTEXT)
3579 #define cando_by_name_int               Perl_cando_by_name_int
3580 #else
3581 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3582 #endif
3583
3584 static char *
3585 find_vmspipe(pTHX)
3586 {
3587     static int   vmspipe_file_status = 0;
3588     static char  vmspipe_file[NAM$C_MAXRSS+1];
3589
3590     /* already found? Check and use ... need read+execute permission */
3591
3592     if (vmspipe_file_status == 1) {
3593         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3594          && cando_by_name_int
3595            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3596             return vmspipe_file;
3597         }
3598         vmspipe_file_status = 0;
3599     }
3600
3601     /* scan through stored @INC, $^X */
3602
3603     if (vmspipe_file_status == 0) {
3604         char file[NAM$C_MAXRSS+1];
3605         pPLOC  p = head_PLOC;
3606
3607         while (p) {
3608             char * exp_res;
3609             int dirlen;
3610             strcpy(file, p->dir);
3611             dirlen = strlen(file);
3612             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3613             file[NAM$C_MAXRSS] = '\0';
3614             p = p->next;
3615
3616             exp_res = do_rmsexpand
3617                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3618             if (!exp_res) continue;
3619
3620             if (cando_by_name_int
3621                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3622              && cando_by_name_int
3623                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3624                 vmspipe_file_status = 1;
3625                 return vmspipe_file;
3626             }
3627         }
3628         vmspipe_file_status = -1;   /* failed, use tempfiles */
3629     }
3630
3631     return 0;
3632 }
3633
3634 static FILE *
3635 vmspipe_tempfile(pTHX)
3636 {
3637     char file[NAM$C_MAXRSS+1];
3638     FILE *fp;
3639     static int index = 0;
3640     Stat_t s0, s1;
3641     int cmp_result;
3642
3643     /* create a tempfile */
3644
3645     /* we can't go from   W, shr=get to  R, shr=get without
3646        an intermediate vulnerable state, so don't bother trying...
3647
3648        and lib$spawn doesn't shr=put, so have to close the write
3649
3650        So... match up the creation date/time and the FID to
3651        make sure we're dealing with the same file
3652
3653     */
3654
3655     index++;
3656     if (!decc_filename_unix_only) {
3657       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3658       fp = fopen(file,"w");
3659       if (!fp) {
3660         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3661         fp = fopen(file,"w");
3662         if (!fp) {
3663             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3664             fp = fopen(file,"w");
3665         }
3666       }
3667      }
3668      else {
3669       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3670       fp = fopen(file,"w");
3671       if (!fp) {
3672         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3673         fp = fopen(file,"w");
3674         if (!fp) {
3675           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3676           fp = fopen(file,"w");
3677         }
3678       }
3679     }
3680     if (!fp) return 0;  /* we're hosed */
3681
3682     fprintf(fp,"$! 'f$verify(0)'\n");
3683     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3684     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3685     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3686     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3687     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3688     fprintf(fp,"$ perl_del    = \"delete\"\n");
3689     fprintf(fp,"$ pif         = \"if\"\n");
3690     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3691     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3692     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3693     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3694     fprintf(fp,"$!  --- build command line to get max possible length\n");
3695     fprintf(fp,"$c=perl_popen_cmd0\n");
3696     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3697     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3698     fprintf(fp,"$x=perl_popen_cmd3\n");
3699     fprintf(fp,"$c=c+x\n");
3700     fprintf(fp,"$ perl_on\n");
3701     fprintf(fp,"$ 'c'\n");
3702     fprintf(fp,"$ perl_status = $STATUS\n");
3703     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3704     fprintf(fp,"$ perl_exit 'perl_status'\n");
3705     fsync(fileno(fp));
3706
3707     fgetname(fp, file, 1);
3708     fstat(fileno(fp), (struct stat *)&s0);
3709     fclose(fp);
3710
3711     if (decc_filename_unix_only)
3712         do_tounixspec(file, file, 0, NULL);
3713     fp = fopen(file,"r","shr=get");
3714     if (!fp) return 0;
3715     fstat(fileno(fp), (struct stat *)&s1);
3716
3717     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3718     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3719         fclose(fp);
3720         return 0;
3721     }
3722
3723     return fp;
3724 }
3725
3726
3727
3728 static PerlIO *
3729 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3730 {
3731     static int handler_set_up = FALSE;
3732     unsigned long int sts, flags = CLI$M_NOWAIT;
3733     /* The use of a GLOBAL table (as was done previously) rendered
3734      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3735      * environment.  Hence we've switched to LOCAL symbol table.
3736      */
3737     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3738     int j, wait = 0, n;
3739     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3740     char *in, *out, *err, mbx[512];
3741     FILE *tpipe = 0;
3742     char tfilebuf[NAM$C_MAXRSS+1];
3743     pInfo info = NULL;
3744     char cmd_sym_name[20];
3745     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3746                                       DSC$K_CLASS_S, symbol};
3747     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3748                                       DSC$K_CLASS_S, 0};
3749     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3750                                       DSC$K_CLASS_S, cmd_sym_name};
3751     struct dsc$descriptor_s *vmscmd;
3752     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3753     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3754     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3755
3756     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
3757
3758     /* once-per-program initialization...
3759        note that the SETAST calls and the dual test of pipe_ef
3760        makes sure that only the FIRST thread through here does
3761        the initialization...all other threads wait until it's
3762        done.
3763
3764        Yeah, uglier than a pthread call, it's got all the stuff inline
3765        rather than in a separate routine.
3766     */
3767
3768     if (!pipe_ef) {
3769         _ckvmssts(sys$setast(0));
3770         if (!pipe_ef) {
3771             unsigned long int pidcode = JPI$_PID;
3772             $DESCRIPTOR(d_delay, RETRY_DELAY);
3773             _ckvmssts(lib$get_ef(&pipe_ef));
3774             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3775             _ckvmssts(sys$bintim(&d_delay, delaytime));
3776         }
3777         if (!handler_set_up) {
3778           _ckvmssts(sys$dclexh(&pipe_exitblock));
3779           handler_set_up = TRUE;
3780         }
3781         _ckvmssts(sys$setast(1));
3782     }
3783
3784     /* see if we can find a VMSPIPE.COM */
3785
3786     tfilebuf[0] = '@';
3787     vmspipe = find_vmspipe(aTHX);
3788     if (vmspipe) {
3789         strcpy(tfilebuf+1,vmspipe);
3790     } else {        /* uh, oh...we're in tempfile hell */
3791         tpipe = vmspipe_tempfile(aTHX);
3792         if (!tpipe) {       /* a fish popular in Boston */
3793             if (ckWARN(WARN_PIPE)) {
3794                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3795             }
3796         return Nullfp;
3797         }
3798         fgetname(tpipe,tfilebuf+1,1);
3799     }
3800     vmspipedsc.dsc$a_pointer = tfilebuf;
3801     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
3802
3803     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3804     if (!(sts & 1)) {
3805       switch (sts) {
3806         case RMS$_FNF:  case RMS$_DNF:
3807           set_errno(ENOENT); break;
3808         case RMS$_DIR:
3809           set_errno(ENOTDIR); break;
3810         case RMS$_DEV:
3811           set_errno(ENODEV); break;
3812         case RMS$_PRV:
3813           set_errno(EACCES); break;
3814         case RMS$_SYN:
3815           set_errno(EINVAL); break;
3816         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3817           set_errno(E2BIG); break;
3818         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3819           _ckvmssts(sts); /* fall through */
3820         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3821           set_errno(EVMSERR);
3822       }
3823       set_vaxc_errno(sts);
3824       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3825         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3826       }
3827       *psts = sts;
3828       return Nullfp;
3829     }
3830     n = sizeof(Info);
3831     _ckvmssts(lib$get_vm(&n, &info));
3832
3833     strcpy(mode,in_mode);
3834     info->mode = *mode;
3835     info->done = FALSE;
3836     info->completion = 0;
3837     info->closing    = FALSE;
3838     info->in         = 0;
3839     info->out        = 0;
3840     info->err        = 0;
3841     info->fp         = Nullfp;
3842     info->useFILE    = 0;
3843     info->waiting    = 0;
3844     info->in_done    = TRUE;
3845     info->out_done   = TRUE;
3846     info->err_done   = TRUE;
3847
3848     in = PerlMem_malloc(VMS_MAXRSS);
3849     if (in == NULL) _ckvmssts(SS$_INSFMEM);
3850     out = PerlMem_malloc(VMS_MAXRSS);
3851     if (out == NULL) _ckvmssts(SS$_INSFMEM);
3852     err = PerlMem_malloc(VMS_MAXRSS);
3853     if (err == NULL) _ckvmssts(SS$_INSFMEM);
3854
3855     in[0] = out[0] = err[0] = '\0';
3856
3857     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
3858         info->useFILE = 1;
3859         strcpy(p,p+1);
3860     }
3861     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
3862         wait = 1;
3863         strcpy(p,p+1);
3864     }
3865
3866     if (*mode == 'r') {             /* piping from subroutine */
3867
3868         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3869         if (info->out) {
3870             info->out->pipe_done = &info->out_done;
3871             info->out_done = FALSE;
3872             info->out->info = info;
3873         }
3874         if (!info->useFILE) {
3875         info->fp  = PerlIO_open(mbx, mode);
3876         } else {
3877             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3878             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3879         }
3880
3881         if (!info->fp && info->out) {
3882             sys$cancel(info->out->chan_out);
3883
3884             while (!info->out_done) {
3885                 int done;
3886                 _ckvmssts(sys$setast(0));
3887                 done = info->out_done;
3888                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3889                 _ckvmssts(sys$setast(1));
3890                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3891             }
3892
3893             if (info->out->buf) {
3894                 n = info->out->bufsize * sizeof(char);
3895                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3896             }
3897             n = sizeof(Pipe);
3898             _ckvmssts(lib$free_vm(&n, &info->out));
3899             n = sizeof(Info);
3900             _ckvmssts(lib$free_vm(&n, &info));
3901             *psts = RMS$_FNF;
3902             return Nullfp;
3903         }
3904
3905         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3906         if (info->err) {
3907             info->err->pipe_done = &info->err_done;
3908             info->err_done = FALSE;
3909             info->err->info = info;
3910         }
3911
3912     } else if (*mode == 'w') {      /* piping to subroutine */
3913
3914         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3915         if (info->out) {
3916             info->out->pipe_done = &info->out_done;
3917             info->out_done = FALSE;
3918             info->out->info = info;
3919         }
3920
3921         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3922         if (info->err) {
3923             info->err->pipe_done = &info->err_done;
3924             info->err_done = FALSE;
3925             info->err->info = info;
3926         }
3927
3928         info->in = pipe_tochild_setup(aTHX_ in,mbx);
3929         if (!info->useFILE) {
3930             info->fp  = PerlIO_open(mbx, mode);
3931         } else {
3932             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3933             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3934         }
3935
3936         if (info->in) {
3937             info->in->pipe_done = &info->in_done;
3938             info->in_done = FALSE;
3939             info->in->info = info;
3940         }
3941
3942         /* error cleanup */
3943         if (!info->fp && info->in) {
3944             info->done = TRUE;
3945             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3946                               0, 0, 0, 0, 0, 0, 0, 0));
3947
3948             while (!info->in_done) {
3949                 int done;
3950                 _ckvmssts(sys$setast(0));
3951                 done = info->in_done;
3952                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3953                 _ckvmssts(sys$setast(1));
3954                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3955             }
3956
3957             if (info->in->buf) {
3958                 n = info->in->bufsize * sizeof(char);
3959                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3960             }
3961             n = sizeof(Pipe);
3962             _ckvmssts(lib$free_vm(&n, &info->in));
3963             n = sizeof(Info);
3964             _ckvmssts(lib$free_vm(&n, &info));
3965             *psts = RMS$_FNF;
3966             return Nullfp;
3967         }
3968
3969
3970     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
3971         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3972         if (info->out) {
3973             info->out->pipe_done = &info->out_done;
3974             info->out_done = FALSE;
3975             info->out->info = info;
3976         }
3977
3978         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3979         if (info->err) {
3980             info->err->pipe_done = &info->err_done;
3981             info->err_done = FALSE;
3982             info->err->info = info;
3983         }
3984     }
3985
3986     symbol[MAX_DCL_SYMBOL] = '\0';
3987
3988     strncpy(symbol, in, MAX_DCL_SYMBOL);
3989     d_symbol.dsc$w_length = strlen(symbol);
3990     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3991
3992     strncpy(symbol, err, MAX_DCL_SYMBOL);
3993     d_symbol.dsc$w_length = strlen(symbol);
3994     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3995
3996     strncpy(symbol, out, MAX_DCL_SYMBOL);
3997     d_symbol.dsc$w_length = strlen(symbol);
3998     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3999
4000     /* Done with the names for the pipes */
4001     PerlMem_free(err);
4002     PerlMem_free(out);
4003     PerlMem_free(in);
4004
4005     p = vmscmd->dsc$a_pointer;
4006     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4007     if (*p == '$') p++;                         /* remove leading $ */
4008     while (*p == ' ' || *p == '\t') p++;
4009
4010     for (j = 0; j < 4; j++) {
4011         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4012         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4013
4014     strncpy(symbol, p, MAX_DCL_SYMBOL);
4015     d_symbol.dsc$w_length = strlen(symbol);
4016     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4017
4018         if (strlen(p) > MAX_DCL_SYMBOL) {
4019             p += MAX_DCL_SYMBOL;
4020         } else {
4021             p += strlen(p);
4022         }
4023     }
4024     _ckvmssts(sys$setast(0));
4025     info->next=open_pipes;  /* prepend to list */
4026     open_pipes=info;
4027     _ckvmssts(sys$setast(1));
4028     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4029      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4030      * have SYS$COMMAND if we need it.
4031      */
4032     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4033                       0, &info->pid, &info->completion,
4034                       0, popen_completion_ast,info,0,0,0));
4035
4036     /* if we were using a tempfile, close it now */
4037
4038     if (tpipe) fclose(tpipe);
4039
4040     /* once the subprocess is spawned, it has copied the symbols and
4041        we can get rid of ours */
4042
4043     for (j = 0; j < 4; j++) {
4044         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4045         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4046     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4047     }
4048     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4049     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4050     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4051     vms_execfree(vmscmd);
4052
4053 #ifdef PERL_IMPLICIT_CONTEXT
4054     if (aTHX)
4055 #endif
4056     PL_forkprocess = info->pid;
4057
4058     if (wait) {
4059          int done = 0;
4060          while (!done) {
4061              _ckvmssts(sys$setast(0));
4062              done = info->done;
4063              if (!done) _ckvmssts(sys$clref(pipe_ef));
4064              _ckvmssts(sys$setast(1));
4065              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4066          }
4067         *psts = info->completion;
4068 /* Caller thinks it is open and tries to close it. */
4069 /* This causes some problems, as it changes the error status */
4070 /*        my_pclose(info->fp); */
4071     } else {
4072         *psts = SS$_NORMAL;
4073     }
4074     return info->fp;
4075 }  /* end of safe_popen */
4076
4077
4078 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4079 PerlIO *
4080 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4081 {
4082     int sts;
4083     TAINT_ENV();
4084     TAINT_PROPER("popen");
4085     PERL_FLUSHALL_FOR_CHILD;
4086     return safe_popen(aTHX_ cmd,mode,&sts);
4087 }
4088
4089 /*}}}*/
4090
4091 /*{{{  I32 my_pclose(PerlIO *fp)*/
4092 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4093 {
4094     pInfo info, last = NULL;
4095     unsigned long int retsts;
4096     int done, iss, n;
4097
4098     for (info = open_pipes; info != NULL; last = info, info = info->next)
4099         if (info->fp == fp) break;
4100
4101     if (info == NULL) {  /* no such pipe open */
4102       set_errno(ECHILD); /* quoth POSIX */
4103       set_vaxc_errno(SS$_NONEXPR);
4104       return -1;
4105     }
4106
4107     /* If we were writing to a subprocess, insure that someone reading from
4108      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4109      * produce an EOF record in the mailbox.
4110      *
4111      *  well, at least sometimes it *does*, so we have to watch out for
4112      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4113      */
4114      if (info->fp) {
4115         if (!info->useFILE)
4116             PerlIO_flush(info->fp);   /* first, flush data */
4117         else
4118             fflush((FILE *)info->fp);
4119     }
4120
4121     _ckvmssts(sys$setast(0));
4122      info->closing = TRUE;
4123      done = info->done && info->in_done && info->out_done && info->err_done;
4124      /* hanging on write to Perl's input? cancel it */
4125      if (info->mode == 'r' && info->out && !info->out_done) {
4126         if (info->out->chan_out) {
4127             _ckvmssts(sys$cancel(info->out->chan_out));
4128             if (!info->out->chan_in) {   /* EOF generation, need AST */
4129                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4130             }
4131         }
4132      }
4133      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4134          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4135                            0, 0, 0, 0, 0, 0));
4136     _ckvmssts(sys$setast(1));
4137     if (info->fp) {
4138      if (!info->useFILE)
4139         PerlIO_close(info->fp);
4140      else
4141         fclose((FILE *)info->fp);
4142     }
4143      /*
4144         we have to wait until subprocess completes, but ALSO wait until all
4145         the i/o completes...otherwise we'll be freeing the "info" structure
4146         that the i/o ASTs could still be using...
4147      */
4148
4149      while (!done) {
4150          _ckvmssts(sys$setast(0));
4151          done = info->done && info->in_done && info->out_done && info->err_done;
4152          if (!done) _ckvmssts(sys$clref(pipe_ef));
4153          _ckvmssts(sys$setast(1));
4154          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4155      }
4156      retsts = info->completion;
4157
4158     /* remove from list of open pipes */
4159     _ckvmssts(sys$setast(0));
4160     if (last) last->next = info->next;
4161     else open_pipes = info->next;
4162     _ckvmssts(sys$setast(1));
4163
4164     /* free buffers and structures */
4165
4166     if (info->in) {
4167         if (info->in->buf) {
4168             n = info->in->bufsize * sizeof(char);
4169             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4170         }
4171         n = sizeof(Pipe);
4172         _ckvmssts(lib$free_vm(&n, &info->in));
4173     }
4174     if (info->out) {
4175         if (info->out->buf) {
4176             n = info->out->bufsize * sizeof(char);
4177             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4178         }
4179         n = sizeof(Pipe);
4180         _ckvmssts(lib$free_vm(&n, &info->out));
4181     }
4182     if (info->err) {
4183         if (info->err->buf) {
4184             n = info->err->bufsize * sizeof(char);
4185             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4186         }
4187         n = sizeof(Pipe);
4188         _ckvmssts(lib$free_vm(&n, &info->err));
4189     }
4190     n = sizeof(Info);
4191     _ckvmssts(lib$free_vm(&n, &info));
4192
4193     return retsts;
4194
4195 }  /* end of my_pclose() */
4196
4197 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4198   /* Roll our own prototype because we want this regardless of whether
4199    * _VMS_WAIT is defined.
4200    */
4201   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4202 #endif
4203 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4204    created with popen(); otherwise partially emulate waitpid() unless
4205    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4206    Also check processes not considered by the CRTL waitpid().
4207  */
4208 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4209 Pid_t
4210 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4211 {
4212     pInfo info;
4213     int done;
4214     int sts;
4215     int j;
4216
4217     if (statusp) *statusp = 0;
4218
4219     for (info = open_pipes; info != NULL; info = info->next)
4220         if (info->pid == pid) break;
4221
4222     if (info != NULL) {  /* we know about this child */
4223       while (!info->done) {
4224           _ckvmssts(sys$setast(0));
4225           done = info->done;
4226           if (!done) _ckvmssts(sys$clref(pipe_ef));
4227           _ckvmssts(sys$setast(1));
4228           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4229       }
4230
4231       if (statusp) *statusp = info->completion;
4232       return pid;
4233     }
4234
4235     /* child that already terminated? */
4236
4237     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4238         if (closed_list[j].pid == pid) {
4239             if (statusp) *statusp = closed_list[j].completion;
4240             return pid;
4241         }
4242     }
4243
4244     /* fall through if this child is not one of our own pipe children */
4245
4246 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4247
4248       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4249        * in 7.2 did we get a version that fills in the VMS completion
4250        * status as Perl has always tried to do.
4251        */
4252
4253       sts = __vms_waitpid( pid, statusp, flags );
4254
4255       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4256          return sts;
4257
4258       /* If the real waitpid tells us the child does not exist, we
4259        * fall through here to implement waiting for a child that
4260        * was created by some means other than exec() (say, spawned
4261        * from DCL) or to wait for a process that is not a subprocess
4262        * of the current process.
4263        */
4264
4265 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4266
4267     {
4268       $DESCRIPTOR(intdsc,"0 00:00:01");
4269       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4270       unsigned long int pidcode = JPI$_PID, mypid;
4271       unsigned long int interval[2];
4272       unsigned int jpi_iosb[2];
4273       struct itmlst_3 jpilist[2] = {
4274           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4275           {                      0,         0,                 0, 0}
4276       };
4277
4278       if (pid <= 0) {
4279         /* Sorry folks, we don't presently implement rooting around for
4280            the first child we can find, and we definitely don't want to
4281            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4282          */
4283         set_errno(ENOTSUP);
4284         return -1;
4285       }
4286
4287       /* Get the owner of the child so I can warn if it's not mine. If the
4288        * process doesn't exist or I don't have the privs to look at it,
4289        * I can go home early.
4290        */
4291       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4292       if (sts & 1) sts = jpi_iosb[0];
4293       if (!(sts & 1)) {
4294         switch (sts) {
4295             case SS$_NONEXPR:
4296                 set_errno(ECHILD);
4297                 break;
4298             case SS$_NOPRIV:
4299                 set_errno(EACCES);
4300                 break;
4301             default:
4302                 _ckvmssts(sts);
4303         }
4304         set_vaxc_errno(sts);
4305         return -1;
4306       }
4307
4308       if (ckWARN(WARN_EXEC)) {
4309         /* remind folks they are asking for non-standard waitpid behavior */
4310         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4311         if (ownerpid != mypid)
4312           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4313                       "waitpid: process %x is not a child of process %x",
4314                       pid,mypid);
4315       }
4316
4317       /* simply check on it once a second until it's not there anymore. */
4318
4319       _ckvmssts(sys$bintim(&intdsc,interval));
4320       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4321             _ckvmssts(sys$schdwk(0,0,interval,0));
4322             _ckvmssts(sys$hiber());
4323       }
4324       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4325
4326       _ckvmssts(sts);
4327       return pid;
4328     }
4329 }  /* end of waitpid() */
4330 /*}}}*/
4331 /*}}}*/
4332 /*}}}*/
4333
4334 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4335 char *
4336 my_gconvert(double val, int ndig, int trail, char *buf)
4337 {
4338   static char __gcvtbuf[DBL_DIG+1];
4339   char *loc;
4340
4341   loc = buf ? buf : __gcvtbuf;
4342
4343 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4344   if (val < 1) {
4345     sprintf(loc,"%.*g",ndig,val);
4346     return loc;
4347   }
4348 #endif
4349
4350   if (val) {
4351     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4352     return gcvt(val,ndig,loc);
4353   }
4354   else {
4355     loc[0] = '0'; loc[1] = '\0';
4356     return loc;
4357   }
4358
4359 }
4360 /*}}}*/
4361
4362 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4363 static int rms_free_search_context(struct FAB * fab)
4364 {
4365 struct NAM * nam;
4366
4367     nam = fab->fab$l_nam;
4368     nam->nam$b_nop |= NAM$M_SYNCHK;
4369     nam->nam$l_rlf = NULL;
4370     fab->fab$b_dns = 0;
4371     return sys$parse(fab, NULL, NULL);
4372 }
4373
4374 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4375 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4376 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4377 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4378 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4379 #define rms_nam_esll(nam) nam.nam$b_esl
4380 #define rms_nam_esl(nam) nam.nam$b_esl
4381 #define rms_nam_name(nam) nam.nam$l_name
4382 #define rms_nam_namel(nam) nam.nam$l_name
4383 #define rms_nam_type(nam) nam.nam$l_type
4384 #define rms_nam_typel(nam) nam.nam$l_type
4385 #define rms_nam_ver(nam) nam.nam$l_ver
4386 #define rms_nam_verl(nam) nam.nam$l_ver
4387 #define rms_nam_rsll(nam) nam.nam$b_rsl
4388 #define rms_nam_rsl(nam) nam.nam$b_rsl
4389 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4390 #define rms_set_fna(fab, nam, name, size) \
4391         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4392 #define rms_get_fna(fab, nam) fab.fab$l_fna
4393 #define rms_set_dna(fab, nam, name, size) \
4394         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4395 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4396 #define rms_set_esa(fab, nam, name, size) \
4397         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4398 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4399         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4400 #define rms_set_rsa(nam, name, size) \
4401         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4402 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4403         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4404 #define rms_nam_name_type_l_size(nam) \
4405         (nam.nam$b_name + nam.nam$b_type)
4406 #else
4407 static int rms_free_search_context(struct FAB * fab)
4408 {
4409 struct NAML * nam;
4410
4411     nam = fab->fab$l_naml;
4412     nam->naml$b_nop |= NAM$M_SYNCHK;
4413     nam->naml$l_rlf = NULL;
4414     nam->naml$l_long_defname_size = 0;
4415
4416     fab->fab$b_dns = 0;
4417     return sys$parse(fab, NULL, NULL);
4418 }
4419
4420 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4421 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4422 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4423 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4424 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4425 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4426 #define rms_nam_esl(nam) nam.naml$b_esl
4427 #define rms_nam_name(nam) nam.naml$l_name
4428 #define rms_nam_namel(nam) nam.naml$l_long_name
4429 #define rms_nam_type(nam) nam.naml$l_type
4430 #define rms_nam_typel(nam) nam.naml$l_long_type
4431 #define rms_nam_ver(nam) nam.naml$l_ver
4432 #define rms_nam_verl(nam) nam.naml$l_long_ver
4433 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4434 #define rms_nam_rsl(nam) nam.naml$b_rsl
4435 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4436 #define rms_set_fna(fab, nam, name, size) \
4437         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4438         nam.naml$l_long_filename_size = size; \
4439         nam.naml$l_long_filename = name;}
4440 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4441 #define rms_set_dna(fab, nam, name, size) \
4442         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4443         nam.naml$l_long_defname_size = size; \
4444         nam.naml$l_long_defname = name; }
4445 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4446 #define rms_set_esa(fab, nam, name, size) \
4447         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4448         nam.naml$l_long_expand_alloc = size; \
4449         nam.naml$l_long_expand = name; }
4450 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4451         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4452         nam.naml$l_long_expand = l_name; \
4453         nam.naml$l_long_expand_alloc = l_size; }
4454 #define rms_set_rsa(nam, name, size) \
4455         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4456         nam.naml$l_long_result = name; \
4457         nam.naml$l_long_result_alloc = size; }
4458 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4459         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4460         nam.naml$l_long_result = l_name; \
4461         nam.naml$l_long_result_alloc = l_size; }
4462 #define rms_nam_name_type_l_size(nam) \
4463         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4464 #endif
4465
4466
4467 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4468 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4469  * to expand file specification.  Allows for a single default file
4470  * specification and a simple mask of options.  If outbuf is non-NULL,
4471  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4472  * the resultant file specification is placed.  If outbuf is NULL, the
4473  * resultant file specification is placed into a static buffer.
4474  * The third argument, if non-NULL, is taken to be a default file
4475  * specification string.  The fourth argument is unused at present.
4476  * rmesexpand() returns the address of the resultant string if
4477  * successful, and NULL on error.
4478  *
4479  * New functionality for previously unused opts value:
4480  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4481  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
4482  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4483  */
4484 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4485
4486 static char *
4487 mp_do_rmsexpand
4488    (pTHX_ const char *filespec,
4489     char *outbuf,
4490     int ts,
4491     const char *defspec,
4492     unsigned opts,
4493     int * fs_utf8,
4494     int * dfs_utf8)
4495 {
4496   static char __rmsexpand_retbuf[VMS_MAXRSS];
4497   char * vmsfspec, *tmpfspec;
4498   char * esa, *cp, *out = NULL;
4499   char * tbuf;
4500   char * esal;
4501   char * outbufl;
4502   struct FAB myfab = cc$rms_fab;
4503   rms_setup_nam(mynam);
4504   STRLEN speclen;
4505   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4506   int sts;
4507
4508   /* temp hack until UTF8 is actually implemented */
4509   if (fs_utf8 != NULL)
4510     *fs_utf8 = 0;
4511
4512   if (!filespec || !*filespec) {
4513     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4514     return NULL;
4515   }
4516   if (!outbuf) {
4517     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4518     else    outbuf = __rmsexpand_retbuf;
4519   }
4520
4521   vmsfspec = NULL;
4522   tmpfspec = NULL;
4523   outbufl = NULL;
4524
4525   isunix = 0;
4526   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4527     isunix = is_unix_filespec(filespec);
4528     if (isunix) {
4529       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4530       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4531       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4532         PerlMem_free(vmsfspec);
4533         if (out)
4534            Safefree(out);
4535         return NULL;
4536       }
4537       filespec = vmsfspec;
4538
4539       /* Unless we are forcing to VMS format, a UNIX input means
4540        * UNIX output, and that requires long names to be used
4541        */
4542       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4543         opts |= PERL_RMSEXPAND_M_LONG;
4544       else {
4545         isunix = 0;
4546       }
4547     }
4548   }
4549
4550   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4551   rms_bind_fab_nam(myfab, mynam);
4552
4553   if (defspec && *defspec) {
4554     int t_isunix;
4555     t_isunix = is_unix_filespec(defspec);
4556     if (t_isunix) {
4557       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4558       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4559       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4560         PerlMem_free(tmpfspec);
4561         if (vmsfspec != NULL)
4562             PerlMem_free(vmsfspec);
4563         if (out)
4564            Safefree(out);
4565         return NULL;
4566       }
4567       defspec = tmpfspec;
4568     }
4569     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4570   }
4571
4572   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4573   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4574 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4575   esal = PerlMem_malloc(VMS_MAXRSS);
4576   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4577 #endif
4578   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4579
4580   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4581     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4582   }
4583   else {
4584 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4585     outbufl = PerlMem_malloc(VMS_MAXRSS);
4586     if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4587     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4588 #else
4589     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4590 #endif
4591   }
4592
4593 #ifdef NAM$M_NO_SHORT_UPCASE
4594   if (decc_efs_case_preserve)
4595     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4596 #endif
4597
4598   /* First attempt to parse as an existing file */
4599   retsts = sys$parse(&myfab,0,0);
4600   if (!(retsts & STS$K_SUCCESS)) {
4601
4602     /* Could not find the file, try as syntax only if error is not fatal */
4603     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4604     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4605       retsts = sys$parse(&myfab,0,0);
4606       if (retsts & STS$K_SUCCESS) goto expanded;
4607     }
4608
4609      /* Still could not parse the file specification */
4610     /*----------------------------------------------*/
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 if (retsts == RMS$_DEV) set_errno(ENODEV);
4624     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4625     else                         set_errno(EVMSERR);
4626     return NULL;
4627   }
4628   retsts = sys$search(&myfab,0,0);
4629   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4630     sts = rms_free_search_context(&myfab); /* Free search context */
4631     if (out) Safefree(out);
4632     if (tmpfspec != NULL)
4633         PerlMem_free(tmpfspec);
4634     if (vmsfspec != NULL)
4635         PerlMem_free(vmsfspec);
4636     if (outbufl != NULL)
4637         PerlMem_free(outbufl);
4638     PerlMem_free(esa);
4639     PerlMem_free(esal);
4640     set_vaxc_errno(retsts);
4641     if      (retsts == RMS$_PRV) set_errno(EACCES);
4642     else                         set_errno(EVMSERR);
4643     return NULL;
4644   }
4645
4646   /* If the input filespec contained any lowercase characters,
4647    * downcase the result for compatibility with Unix-minded code. */
4648   expanded:
4649   if (!decc_efs_case_preserve) {
4650     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4651       if (islower(*tbuf)) { haslower = 1; break; }
4652   }
4653
4654    /* Is a long or a short name expected */
4655   /*------------------------------------*/
4656   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4657     if (rms_nam_rsll(mynam)) {
4658         tbuf = outbuf;
4659         speclen = rms_nam_rsll(mynam);
4660     }
4661     else {
4662         tbuf = esal; /* Not esa */
4663         speclen = rms_nam_esll(mynam);
4664     }
4665   }
4666   else {
4667     if (rms_nam_rsl(mynam)) {
4668         tbuf = outbuf;
4669         speclen = rms_nam_rsl(mynam);
4670     }
4671     else {
4672         tbuf = esa; /* Not esal */
4673         speclen = rms_nam_esl(mynam);
4674     }
4675   }
4676   tbuf[speclen] = '\0';
4677
4678   /* Trim off null fields added by $PARSE
4679    * If type > 1 char, must have been specified in original or default spec
4680    * (not true for version; $SEARCH may have added version of existing file).
4681    */
4682   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4683   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4684     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4685              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4686   }
4687   else {
4688     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4689              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4690   }
4691   if (trimver || trimtype) {
4692     if (defspec && *defspec) {
4693       char *defesal = NULL;
4694       defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4695       if (defesal != NULL) {
4696         struct FAB deffab = cc$rms_fab;
4697         rms_setup_nam(defnam);
4698
4699         rms_bind_fab_nam(deffab, defnam);
4700
4701         /* Cast ok */
4702         rms_set_fna
4703             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4704
4705         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4706
4707         rms_clear_nam_nop(defnam);
4708         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4709 #ifdef NAM$M_NO_SHORT_UPCASE
4710         if (decc_efs_case_preserve)
4711           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4712 #endif
4713         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4714           if (trimver) {
4715              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4716           }
4717           if (trimtype) {
4718             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4719           }
4720         }
4721         PerlMem_free(defesal);
4722       }
4723     }
4724     if (trimver) {
4725       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4726         if (*(rms_nam_verl(mynam)) != '\"')
4727           speclen = rms_nam_verl(mynam) - tbuf;
4728       }
4729       else {
4730         if (*(rms_nam_ver(mynam)) != '\"')
4731           speclen = rms_nam_ver(mynam) - tbuf;
4732       }
4733     }
4734     if (trimtype) {
4735       /* If we didn't already trim version, copy down */
4736       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4737         if (speclen > rms_nam_verl(mynam) - tbuf)
4738           memmove
4739            (rms_nam_typel(mynam),
4740             rms_nam_verl(mynam),
4741             speclen - (rms_nam_verl(mynam) - tbuf));
4742           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4743       }
4744       else {
4745         if (speclen > rms_nam_ver(mynam) - tbuf)
4746           memmove
4747            (rms_nam_type(mynam),
4748             rms_nam_ver(mynam),
4749             speclen - (rms_nam_ver(mynam) - tbuf));
4750           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4751       }
4752     }
4753   }
4754
4755    /* Done with these copies of the input files */
4756   /*-------------------------------------------*/
4757   if (vmsfspec != NULL)
4758         PerlMem_free(vmsfspec);
4759   if (tmpfspec != NULL)
4760         PerlMem_free(tmpfspec);
4761
4762   /* If we just had a directory spec on input, $PARSE "helpfully"
4763    * adds an empty name and type for us */
4764   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4765     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4766         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
4767         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4768       speclen = rms_nam_namel(mynam) - tbuf;
4769   }
4770   else {
4771     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4772         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
4773         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4774       speclen = rms_nam_name(mynam) - tbuf;
4775   }
4776
4777   /* Posix format specifications must have matching quotes */
4778   if (speclen < (VMS_MAXRSS - 1)) {
4779     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
4780       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
4781         tbuf[speclen] = '\"';
4782         speclen++;
4783       }
4784     }
4785   }
4786   tbuf[speclen] = '\0';
4787   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
4788
4789   /* Have we been working with an expanded, but not resultant, spec? */
4790   /* Also, convert back to Unix syntax if necessary. */
4791
4792   if (!rms_nam_rsll(mynam)) {
4793     if (isunix) {
4794       if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
4795         if (out) Safefree(out);
4796         PerlMem_free(esal);
4797         PerlMem_free(esa);
4798         if (outbufl != NULL)
4799             PerlMem_free(outbufl);
4800         return NULL;
4801       }
4802     }
4803     else strcpy(outbuf,esa);
4804   }
4805   else if (isunix) {
4806     tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4807     if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4808     if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
4809         if (out) Safefree(out);
4810         PerlMem_free(esa);
4811         PerlMem_free(esal);
4812         PerlMem_free(tmpfspec);
4813         if (outbufl != NULL)
4814             PerlMem_free(outbufl);
4815         return NULL;
4816     }
4817     strcpy(outbuf,tmpfspec);
4818     PerlMem_free(tmpfspec);
4819   }
4820
4821   rms_set_rsal(mynam, NULL, 0, NULL, 0);
4822   sts = rms_free_search_context(&myfab); /* Free search context */
4823   PerlMem_free(esa);
4824   PerlMem_free(esal);
4825   if (outbufl != NULL)
4826      PerlMem_free(outbufl);
4827   return outbuf;
4828 }
4829 /*}}}*/
4830 /* External entry points */
4831 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4832 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
4833 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4834 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
4835 char *Perl_rmsexpand_utf8
4836   (pTHX_ const char *spec, char *buf, const char *def,
4837    unsigned opt, int * fs_utf8, int * dfs_utf8)
4838 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
4839 char *Perl_rmsexpand_utf8_ts
4840   (pTHX_ const char *spec, char *buf, const char *def,
4841    unsigned opt, int * fs_utf8, int * dfs_utf8)
4842 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
4843
4844
4845 /*
4846 ** The following routines are provided to make life easier when
4847 ** converting among VMS-style and Unix-style directory specifications.
4848 ** All will take input specifications in either VMS or Unix syntax. On
4849 ** failure, all return NULL.  If successful, the routines listed below
4850 ** return a pointer to a buffer containing the appropriately
4851 ** reformatted spec (and, therefore, subsequent calls to that routine
4852 ** will clobber the result), while the routines of the same names with
4853 ** a _ts suffix appended will return a pointer to a mallocd string
4854 ** containing the appropriately reformatted spec.
4855 ** In all cases, only explicit syntax is altered; no check is made that
4856 ** the resulting string is valid or that the directory in question
4857 ** actually exists.
4858 **
4859 **   fileify_dirspec() - convert a directory spec into the name of the
4860 **     directory file (i.e. what you can stat() to see if it's a dir).
4861 **     The style (VMS or Unix) of the result is the same as the style
4862 **     of the parameter passed in.
4863 **   pathify_dirspec() - convert a directory spec into a path (i.e.
4864 **     what you prepend to a filename to indicate what directory it's in).
4865 **     The style (VMS or Unix) of the result is the same as the style
4866 **     of the parameter passed in.
4867 **   tounixpath() - convert a directory spec into a Unix-style path.
4868 **   tovmspath() - convert a directory spec into a VMS-style path.
4869 **   tounixspec() - convert any file spec into a Unix-style file spec.
4870 **   tovmsspec() - convert any file spec into a VMS-style spec.
4871 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
4872 **
4873 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
4874 ** Permission is given to distribute this code as part of the Perl
4875 ** standard distribution under the terms of the GNU General Public
4876 ** License or the Perl Artistic License.  Copies of each may be
4877 ** found in the Perl standard distribution.
4878  */
4879
4880 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
4881 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
4882 {
4883     static char __fileify_retbuf[VMS_MAXRSS];
4884     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4885     char *retspec, *cp1, *cp2, *lastdir;
4886     char *trndir, *vmsdir;
4887     unsigned short int trnlnm_iter_count;
4888     int sts;
4889     if (utf8_fl != NULL)
4890         *utf8_fl = 0;
4891
4892     if (!dir || !*dir) {
4893       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4894     }
4895     dirlen = strlen(dir);
4896     while (dirlen && dir[dirlen-1] == '/') --dirlen;
4897     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4898       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4899         dir = "/sys$disk";
4900         dirlen = 9;
4901       }
4902       else
4903         dirlen = 1;
4904     }
4905     if (dirlen > (VMS_MAXRSS - 1)) {
4906       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4907       return NULL;
4908     }
4909     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
4910     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
4911     if (!strpbrk(dir+1,"/]>:")  &&
4912         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4913       strcpy(trndir,*dir == '/' ? dir + 1: dir);
4914       trnlnm_iter_count = 0;
4915       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4916         trnlnm_iter_count++;
4917         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4918       }
4919       dirlen = strlen(trndir);
4920     }
4921     else {
4922       strncpy(trndir,dir,dirlen);
4923       trndir[dirlen] = '\0';
4924     }
4925
4926     /* At this point we are done with *dir and use *trndir which is a
4927      * copy that can be modified.  *dir must not be modified.
4928      */
4929
4930     /* If we were handed a rooted logical name or spec, treat it like a
4931      * simple directory, so that
4932      *    $ Define myroot dev:[dir.]
4933      *    ... do_fileify_dirspec("myroot",buf,1) ...
4934      * does something useful.
4935      */
4936     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4937       trndir[--dirlen] = '\0';
4938       trndir[dirlen-1] = ']';
4939     }
4940     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4941       trndir[--dirlen] = '\0';
4942       trndir[dirlen-1] = '>';
4943     }
4944
4945     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4946       /* If we've got an explicit filename, we can just shuffle the string. */
4947       if (*(cp1+1)) hasfilename = 1;
4948       /* Similarly, we can just back up a level if we've got multiple levels
4949          of explicit directories in a VMS spec which ends with directories. */
4950       else {
4951         for (cp2 = cp1; cp2 > trndir; cp2--) {
4952           if (*cp2 == '.') {
4953             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4954 /* fix-me, can not scan EFS file specs backward like this */
4955               *cp2 = *cp1; *cp1 = '\0';
4956               hasfilename = 1;
4957               break;
4958             }
4959           }
4960           if (*cp2 == '[' || *cp2 == '<') break;
4961         }
4962       }
4963     }
4964
4965     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
4966     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
4967     cp1 = strpbrk(trndir,"]:>");
4968     if (hasfilename || !cp1) { /* Unix-style path or filename */
4969       if (trndir[0] == '.') {
4970         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4971           PerlMem_free(trndir);
4972           PerlMem_free(vmsdir);
4973           return do_fileify_dirspec("[]",buf,ts,NULL);
4974         }
4975         else if (trndir[1] == '.' &&
4976                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4977           PerlMem_free(trndir);
4978           PerlMem_free(vmsdir);
4979           return do_fileify_dirspec("[-]",buf,ts,NULL);
4980         }
4981       }
4982       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
4983         dirlen -= 1;                 /* to last element */
4984         lastdir = strrchr(trndir,'/');
4985       }
4986       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4987         /* If we have "/." or "/..", VMSify it and let the VMS code
4988          * below expand it, rather than repeating the code to handle
4989          * relative components of a filespec here */
4990         do {
4991           if (*(cp1+2) == '.') cp1++;
4992           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4993             char * ret_chr;
4994             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
4995                 PerlMem_free(trndir);
4996                 PerlMem_free(vmsdir);
4997                 return NULL;
4998             }
4999             if (strchr(vmsdir,'/') != NULL) {
5000               /* If do_tovmsspec() returned it, it must have VMS syntax
5001                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5002                * the time to check this here only so we avoid a recursion
5003                * loop; otherwise, gigo.
5004                */
5005               PerlMem_free(trndir);
5006               PerlMem_free(vmsdir);
5007               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5008               return NULL;
5009             }
5010             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5011                 PerlMem_free(trndir);
5012                 PerlMem_free(vmsdir);
5013                 return NULL;
5014             }
5015             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5016             PerlMem_free(trndir);
5017             PerlMem_free(vmsdir);
5018             return ret_chr;
5019           }
5020           cp1++;
5021         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5022         lastdir = strrchr(trndir,'/');
5023       }
5024       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5025         char * ret_chr;
5026         /* Ditto for specs that end in an MFD -- let the VMS code
5027          * figure out whether it's a real device or a rooted logical. */
5028
5029         /* This should not happen any more.  Allowing the fake /000000
5030          * in a UNIX pathname causes all sorts of problems when trying
5031          * to run in UNIX emulation.  So the VMS to UNIX conversions
5032          * now remove the fake /000000 directories.
5033          */
5034
5035         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5036         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5037             PerlMem_free(trndir);
5038             PerlMem_free(vmsdir);
5039             return NULL;
5040         }
5041         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5042             PerlMem_free(trndir);
5043             PerlMem_free(vmsdir);
5044             return NULL;
5045         }
5046         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5047         PerlMem_free(trndir);
5048         PerlMem_free(vmsdir);
5049         return ret_chr;
5050       }
5051       else {
5052
5053         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5054              !(lastdir = cp1 = strrchr(trndir,']')) &&
5055              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5056         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5057           int ver; char *cp3;
5058
5059           /* For EFS or ODS-5 look for the last dot */
5060           if (decc_efs_charset) {
5061               cp2 = strrchr(cp1,'.');
5062           }
5063           if (vms_process_case_tolerant) {
5064               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5065                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5066                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5067                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5068                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5069                             (ver || *cp3)))))) {
5070                   PerlMem_free(trndir);
5071                   PerlMem_free(vmsdir);
5072                   set_errno(ENOTDIR);
5073                   set_vaxc_errno(RMS$_DIR);
5074                   return NULL;
5075               }
5076           }
5077           else {
5078               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5079                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5080                   !*(cp2+3) || *(cp2+3) != 'R' ||
5081                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5082                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5083                             (ver || *cp3)))))) {
5084                  PerlMem_free(trndir);
5085                  PerlMem_free(vmsdir);
5086                  set_errno(ENOTDIR);
5087                  set_vaxc_errno(RMS$_DIR);
5088                  return NULL;
5089               }
5090           }
5091           dirlen = cp2 - trndir;
5092         }
5093       }
5094
5095       retlen = dirlen + 6;
5096       if (buf) retspec = buf;
5097       else if (ts) Newx(retspec,retlen+1,char);
5098       else retspec = __fileify_retbuf;
5099       memcpy(retspec,trndir,dirlen);
5100       retspec[dirlen] = '\0';
5101
5102       /* We've picked up everything up to the directory file name.
5103          Now just add the type and version, and we're set. */
5104       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5105         strcat(retspec,".dir;1");
5106       else
5107         strcat(retspec,".DIR;1");
5108       PerlMem_free(trndir);
5109       PerlMem_free(vmsdir);
5110       return retspec;
5111     }
5112     else {  /* VMS-style directory spec */
5113
5114       char *esa, term, *cp;
5115       unsigned long int sts, cmplen, haslower = 0;
5116       unsigned int nam_fnb;
5117       char * nam_type;
5118       struct FAB dirfab = cc$rms_fab;
5119       rms_setup_nam(savnam);
5120       rms_setup_nam(dirnam);
5121
5122       esa = PerlMem_malloc(VMS_MAXRSS + 1);
5123       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5124       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5125       rms_bind_fab_nam(dirfab, dirnam);
5126       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5127       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5128 #ifdef NAM$M_NO_SHORT_UPCASE
5129       if (decc_efs_case_preserve)
5130         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5131 #endif
5132
5133       for (cp = trndir; *cp; cp++)
5134         if (islower(*cp)) { haslower = 1; break; }
5135       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5136         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5137           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5138           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5139         }
5140         if (!sts) {
5141           PerlMem_free(esa);
5142           PerlMem_free(trndir);
5143           PerlMem_free(vmsdir);
5144           set_errno(EVMSERR);
5145           set_vaxc_errno(dirfab.fab$l_sts);
5146           return NULL;
5147         }
5148       }
5149       else {
5150         savnam = dirnam;
5151         /* Does the file really exist? */
5152         if (sys$search(&dirfab)& STS$K_SUCCESS) {
5153           /* Yes; fake the fnb bits so we'll check type below */
5154         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5155         }
5156         else { /* No; just work with potential name */
5157           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5158           else {
5159             int fab_sts;
5160             fab_sts = dirfab.fab$l_sts;
5161             sts = rms_free_search_context(&dirfab);
5162             PerlMem_free(esa);
5163             PerlMem_free(trndir);
5164             PerlMem_free(vmsdir);
5165             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
5166             return NULL;
5167           }
5168         }
5169       }
5170       esa[rms_nam_esll(dirnam)] = '\0';
5171       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5172         cp1 = strchr(esa,']');
5173         if (!cp1) cp1 = strchr(esa,'>');
5174         if (cp1) {  /* Should always be true */
5175           rms_nam_esll(dirnam) -= cp1 - esa - 1;
5176           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5177         }
5178       }
5179       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5180         /* Yep; check version while we're at it, if it's there. */
5181         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5182         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5183           /* Something other than .DIR[;1].  Bzzt. */
5184           sts = rms_free_search_context(&dirfab);
5185           PerlMem_free(esa);
5186           PerlMem_free(trndir);
5187           PerlMem_free(vmsdir);
5188           set_errno(ENOTDIR);
5189           set_vaxc_errno(RMS$_DIR);
5190           return NULL;
5191         }
5192       }
5193
5194       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5195         /* They provided at least the name; we added the type, if necessary, */
5196         if (buf) retspec = buf;                            /* in sys$parse() */
5197         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5198         else retspec = __fileify_retbuf;
5199         strcpy(retspec,esa);
5200         sts = rms_free_search_context(&dirfab);
5201         PerlMem_free(trndir);
5202         PerlMem_free(esa);
5203         PerlMem_free(vmsdir);
5204         return retspec;
5205       }
5206       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5207         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5208         *cp1 = '\0';
5209         rms_nam_esll(dirnam) -= 9;
5210       }
5211       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5212       if (cp1 == NULL) { /* should never happen */
5213         sts = rms_free_search_context(&dirfab);
5214         PerlMem_free(trndir);
5215         PerlMem_free(esa);
5216         PerlMem_free(vmsdir);
5217         return NULL;
5218       }
5219       term = *cp1;
5220       *cp1 = '\0';
5221       retlen = strlen(esa);
5222       cp1 = strrchr(esa,'.');
5223       /* ODS-5 directory specifications can have extra "." in them. */
5224       /* Fix-me, can not scan EFS file specifications backwards */
5225       while (cp1 != NULL) {
5226         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5227           break;
5228         else {
5229            cp1--;
5230            while ((cp1 > esa) && (*cp1 != '.'))
5231              cp1--;
5232         }
5233         if (cp1 == esa)
5234           cp1 = NULL;
5235       }
5236
5237       if ((cp1) != NULL) {
5238         /* There's more than one directory in the path.  Just roll back. */
5239         *cp1 = term;
5240         if (buf) retspec = buf;
5241         else if (ts) Newx(retspec,retlen+7,char);
5242         else retspec = __fileify_retbuf;
5243         strcpy(retspec,esa);
5244       }
5245       else {
5246         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5247           /* Go back and expand rooted logical name */
5248           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5249 #ifdef NAM$M_NO_SHORT_UPCASE
5250           if (decc_efs_case_preserve)
5251             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5252 #endif
5253           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5254             sts = rms_free_search_context(&dirfab);
5255             PerlMem_free(esa);
5256             PerlMem_free(trndir);
5257             PerlMem_free(vmsdir);
5258             set_errno(EVMSERR);
5259             set_vaxc_errno(dirfab.fab$l_sts);
5260             return NULL;
5261           }
5262           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5263           if (buf) retspec = buf;
5264           else if (ts) Newx(retspec,retlen+16,char);
5265           else retspec = __fileify_retbuf;
5266           cp1 = strstr(esa,"][");
5267           if (!cp1) cp1 = strstr(esa,"]<");
5268           dirlen = cp1 - esa;
5269           memcpy(retspec,esa,dirlen);
5270           if (!strncmp(cp1+2,"000000]",7)) {
5271             retspec[dirlen-1] = '\0';
5272             /* fix-me Not full ODS-5, just extra dots in directories for now */
5273             cp1 = retspec + dirlen - 1;
5274             while (cp1 > retspec)
5275             {
5276               if (*cp1 == '[')
5277                 break;
5278               if (*cp1 == '.') {
5279                 if (*(cp1-1) != '^')
5280                   break;
5281               }
5282               cp1--;
5283             }
5284             if (*cp1 == '.') *cp1 = ']';
5285             else {
5286               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5287               memmove(cp1+1,"000000]",7);
5288             }
5289           }
5290           else {
5291             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5292             retspec[retlen] = '\0';
5293             /* Convert last '.' to ']' */
5294             cp1 = retspec+retlen-1;
5295             while (*cp != '[') {
5296               cp1--;
5297               if (*cp1 == '.') {
5298                 /* Do not trip on extra dots in ODS-5 directories */
5299                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5300                 break;
5301               }
5302             }
5303             if (*cp1 == '.') *cp1 = ']';
5304             else {
5305               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5306               memmove(cp1+1,"000000]",7);
5307             }
5308           }
5309         }
5310         else {  /* This is a top-level dir.  Add the MFD to the path. */
5311           if (buf) retspec = buf;
5312           else if (ts) Newx(retspec,retlen+16,char);
5313           else retspec = __fileify_retbuf;
5314           cp1 = esa;
5315           cp2 = retspec;
5316           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5317           strcpy(cp2,":[000000]");
5318           cp1 += 2;
5319           strcpy(cp2+9,cp1);
5320         }
5321       }
5322       sts = rms_free_search_context(&dirfab);
5323       /* We've set up the string up through the filename.  Add the
5324          type and version, and we're done. */
5325       strcat(retspec,".DIR;1");
5326
5327       /* $PARSE may have upcased filespec, so convert output to lower
5328        * case if input contained any lowercase characters. */
5329       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5330       PerlMem_free(trndir);
5331       PerlMem_free(esa);
5332       PerlMem_free(vmsdir);
5333       return retspec;
5334     }
5335 }  /* end of do_fileify_dirspec() */
5336 /*}}}*/
5337 /* External entry points */
5338 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5339 { return do_fileify_dirspec(dir,buf,0,NULL); }
5340 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5341 { return do_fileify_dirspec(dir,buf,1,NULL); }
5342 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5343 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5344 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5345 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5346
5347 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5348 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5349 {
5350     static char __pathify_retbuf[VMS_MAXRSS];
5351     unsigned long int retlen;
5352     char *retpath, *cp1, *cp2, *trndir;
5353     unsigned short int trnlnm_iter_count;
5354     STRLEN trnlen;
5355     int sts;
5356     if (utf8_fl != NULL)
5357         *utf8_fl = 0;
5358
5359     if (!dir || !*dir) {
5360       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5361     }
5362
5363     trndir = PerlMem_malloc(VMS_MAXRSS);
5364     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5365     if (*dir) strcpy(trndir,dir);
5366     else getcwd(trndir,VMS_MAXRSS - 1);
5367
5368     trnlnm_iter_count = 0;
5369     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5370            && my_trnlnm(trndir,trndir,0)) {
5371       trnlnm_iter_count++;
5372       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5373       trnlen = strlen(trndir);
5374
5375       /* Trap simple rooted lnms, and return lnm:[000000] */
5376       if (!strcmp(trndir+trnlen-2,".]")) {
5377         if (buf) retpath = buf;
5378         else if (ts) Newx(retpath,strlen(dir)+10,char);
5379         else retpath = __pathify_retbuf;
5380         strcpy(retpath,dir);
5381         strcat(retpath,":[000000]");
5382         PerlMem_free(trndir);
5383         return retpath;
5384       }
5385     }
5386
5387     /* At this point we do not work with *dir, but the copy in
5388      * *trndir that is modifiable.
5389      */
5390
5391     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5392       if (*trndir == '.' && (*(trndir+1) == '\0' ||
5393                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5394         retlen = 2 + (*(trndir+1) != '\0');
5395       else {
5396         if ( !(cp1 = strrchr(trndir,'/')) &&
5397              !(cp1 = strrchr(trndir,']')) &&
5398              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5399         if ((cp2 = strchr(cp1,'.')) != NULL &&
5400             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
5401              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
5402               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5403               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5404           int ver; char *cp3;
5405
5406           /* For EFS or ODS-5 look for the last dot */
5407           if (decc_efs_charset) {
5408             cp2 = strrchr(cp1,'.');
5409           }
5410           if (vms_process_case_tolerant) {
5411               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5412                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5413                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5414                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5415                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5416                             (ver || *cp3)))))) {
5417                 PerlMem_free(trndir);
5418                 set_errno(ENOTDIR);
5419                 set_vaxc_errno(RMS$_DIR);
5420                 return NULL;
5421               }
5422           }
5423           else {
5424               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5425                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5426                   !*(cp2+3) || *(cp2+3) != 'R' ||
5427                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5428                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5429                             (ver || *cp3)))))) {
5430                 PerlMem_free(trndir);
5431                 set_errno(ENOTDIR);
5432                 set_vaxc_errno(RMS$_DIR);
5433                 return NULL;
5434               }
5435           }
5436           retlen = cp2 - trndir + 1;
5437         }
5438         else {  /* No file type present.  Treat the filename as a directory. */
5439           retlen = strlen(trndir) + 1;
5440         }
5441       }
5442       if (buf) retpath = buf;
5443       else if (ts) Newx(retpath,retlen+1,char);
5444       else retpath = __pathify_retbuf;
5445       strncpy(retpath, trndir, retlen-1);
5446       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5447         retpath[retlen-1] = '/';      /* with '/', add it. */
5448         retpath[retlen] = '\0';
5449       }
5450       else retpath[retlen-1] = '\0';
5451     }
5452     else {  /* VMS-style directory spec */
5453       char *esa, *cp;
5454       unsigned long int sts, cmplen, haslower;
5455       struct FAB dirfab = cc$rms_fab;
5456       int dirlen;
5457       rms_setup_nam(savnam);
5458       rms_setup_nam(dirnam);
5459
5460       /* If we've got an explicit filename, we can just shuffle the string. */
5461       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5462              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
5463         if ((cp2 = strchr(cp1,'.')) != NULL) {
5464           int ver; char *cp3;
5465           if (vms_process_case_tolerant) {
5466               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5467                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5468                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5469                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5470                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5471                             (ver || *cp3)))))) {
5472                PerlMem_free(trndir);
5473                set_errno(ENOTDIR);
5474                set_vaxc_errno(RMS$_DIR);
5475                return NULL;
5476              }
5477           }
5478           else {
5479               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5480                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5481                   !*(cp2+3) || *(cp2+3) != 'R' ||
5482                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5483                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5484                             (ver || *cp3)))))) {
5485                PerlMem_free(trndir);
5486                set_errno(ENOTDIR);
5487                set_vaxc_errno(RMS$_DIR);
5488                return NULL;
5489              }
5490           }
5491         }
5492         else {  /* No file type, so just draw name into directory part */
5493           for (cp2 = cp1; *cp2; cp2++) ;
5494         }
5495         *cp2 = *cp1;
5496         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5497         *cp1 = '.';
5498         /* We've now got a VMS 'path'; fall through */
5499       }
5500
5501       dirlen = strlen(trndir);
5502       if (trndir[dirlen-1] == ']' ||
5503           trndir[dirlen-1] == '>' ||
5504           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5505         if (buf) retpath = buf;
5506         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5507         else retpath = __pathify_retbuf;
5508         strcpy(retpath,trndir);
5509         PerlMem_free(trndir);
5510         return retpath;
5511       }
5512       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5513       esa = PerlMem_malloc(VMS_MAXRSS);
5514       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5515       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5516       rms_bind_fab_nam(dirfab, dirnam);
5517       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5518 #ifdef NAM$M_NO_SHORT_UPCASE
5519       if (decc_efs_case_preserve)
5520           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5521 #endif
5522
5523       for (cp = trndir; *cp; cp++)
5524         if (islower(*cp)) { haslower = 1; break; }
5525
5526       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5527         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5528           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5529           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5530         }
5531         if (!sts) {
5532           PerlMem_free(trndir);
5533           PerlMem_free(esa);
5534           set_errno(EVMSERR);
5535           set_vaxc_errno(dirfab.fab$l_sts);
5536           return NULL;
5537         }
5538       }
5539       else {
5540         savnam = dirnam;
5541         /* Does the file really exist? */
5542         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5543           if (dirfab.fab$l_sts != RMS$_FNF) {
5544             int sts1;
5545             sts1 = rms_free_search_context(&dirfab);
5546             PerlMem_free(trndir);
5547             PerlMem_free(esa);
5548             set_errno(EVMSERR);
5549             set_vaxc_errno(dirfab.fab$l_sts);
5550             return NULL;
5551           }
5552           dirnam = savnam; /* No; just work with potential name */
5553         }
5554       }
5555       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5556         /* Yep; check version while we're at it, if it's there. */
5557         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5558         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5559           int sts2;
5560           /* Something other than .DIR[;1].  Bzzt. */
5561           sts2 = rms_free_search_context(&dirfab);
5562           PerlMem_free(trndir);
5563           PerlMem_free(esa);
5564           set_errno(ENOTDIR);
5565           set_vaxc_errno(RMS$_DIR);
5566           return NULL;
5567         }
5568       }
5569       /* OK, the type was fine.  Now pull any file name into the
5570          directory path. */
5571       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5572       else {
5573         cp1 = strrchr(esa,'>');
5574         *(rms_nam_typel(dirnam)) = '>';
5575       }
5576       *cp1 = '.';
5577       *(rms_nam_typel(dirnam) + 1) = '\0';
5578       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5579       if (buf) retpath = buf;
5580       else if (ts) Newx(retpath,retlen,char);
5581       else retpath = __pathify_retbuf;
5582       strcpy(retpath,esa);
5583       PerlMem_free(esa);
5584       sts = rms_free_search_context(&dirfab);
5585       /* $PARSE may have upcased filespec, so convert output to lower
5586        * case if input contained any lowercase characters. */
5587       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5588     }
5589
5590     PerlMem_free(trndir);
5591     return retpath;
5592 }  /* end of do_pathify_dirspec() */
5593 /*}}}*/
5594 /* External entry points */
5595 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5596 { return do_pathify_dirspec(dir,buf,0,NULL); }
5597 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5598 { return do_pathify_dirspec(dir,buf,1,NULL); }
5599 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5600 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5601 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5602 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5603
5604 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5605 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5606 {
5607   static char __tounixspec_retbuf[VMS_MAXRSS];
5608   char *dirend, *rslt, *cp1, *cp3, *tmp;
5609   const char *cp2;
5610   int devlen, dirlen, retlen = VMS_MAXRSS;
5611   int expand = 1; /* guarantee room for leading and trailing slashes */
5612   unsigned short int trnlnm_iter_count;
5613   int cmp_rslt;
5614   if (utf8_fl != NULL)
5615     *utf8_fl = 0;
5616
5617   if (spec == NULL) return NULL;
5618   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5619   if (buf) rslt = buf;
5620   else if (ts) {
5621     Newx(rslt, VMS_MAXRSS, char);
5622   }
5623   else rslt = __tounixspec_retbuf;
5624
5625   /* New VMS specific format needs translation
5626    * glob passes filenames with trailing '\n' and expects this preserved.
5627    */
5628   if (decc_posix_compliant_pathnames) {
5629     if (strncmp(spec, "\"^UP^", 5) == 0) {
5630       char * uspec;
5631       char *tunix;
5632       int tunix_len;
5633       int nl_flag;
5634
5635       tunix = PerlMem_malloc(VMS_MAXRSS);
5636       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5637       strcpy(tunix, spec);
5638       tunix_len = strlen(tunix);
5639       nl_flag = 0;
5640       if (tunix[tunix_len - 1] == '\n') {
5641         tunix[tunix_len - 1] = '\"';
5642         tunix[tunix_len] = '\0';
5643         tunix_len--;
5644         nl_flag = 1;
5645       }
5646       uspec = decc$translate_vms(tunix);
5647       PerlMem_free(tunix);
5648       if ((int)uspec > 0) {
5649         strcpy(rslt,uspec);
5650         if (nl_flag) {
5651           strcat(rslt,"\n");
5652         }
5653         else {
5654           /* If we can not translate it, makemaker wants as-is */
5655           strcpy(rslt, spec);
5656         }
5657         return rslt;
5658       }
5659     }
5660   }
5661
5662   cmp_rslt = 0; /* Presume VMS */
5663   cp1 = strchr(spec, '/');
5664   if (cp1 == NULL)
5665     cmp_rslt = 0;
5666
5667     /* Look for EFS ^/ */
5668     if (decc_efs_charset) {
5669       while (cp1 != NULL) {
5670         cp2 = cp1 - 1;
5671         if (*cp2 != '^') {
5672           /* Found illegal VMS, assume UNIX */
5673           cmp_rslt = 1;
5674           break;
5675         }
5676       cp1++;
5677       cp1 = strchr(cp1, '/');
5678     }
5679   }
5680
5681   /* Look for "." and ".." */
5682   if (decc_filename_unix_report) {
5683     if (spec[0] == '.') {
5684       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5685         cmp_rslt = 1;
5686       }
5687       else {
5688         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5689           cmp_rslt = 1;
5690         }
5691       }
5692     }
5693   }
5694   /* This is already UNIX or at least nothing VMS understands */
5695   if (cmp_rslt) {
5696     strcpy(rslt,spec);
5697     return rslt;
5698   }
5699
5700   cp1 = rslt;
5701   cp2 = spec;
5702   dirend = strrchr(spec,']');
5703   if (dirend == NULL) dirend = strrchr(spec,'>');
5704   if (dirend == NULL) dirend = strchr(spec,':');
5705   if (dirend == NULL) {
5706     strcpy(rslt,spec);
5707     return rslt;
5708   }
5709
5710   /* Special case 1 - sys$posix_root = / */
5711 #if __CRTL_VER >= 70000000
5712   if (!decc_disable_posix_root) {
5713     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5714       *cp1 = '/';
5715       cp1++;
5716       cp2 = cp2 + 15;
5717       }
5718   }
5719 #endif
5720
5721   /* Special case 2 - Convert NLA0: to /dev/null */
5722 #if __CRTL_VER < 70000000
5723   cmp_rslt = strncmp(spec,"NLA0:", 5);
5724   if (cmp_rslt != 0)
5725      cmp_rslt = strncmp(spec,"nla0:", 5);
5726 #else
5727   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5728 #endif
5729   if (cmp_rslt == 0) {
5730     strcpy(rslt, "/dev/null");
5731     cp1 = cp1 + 9;
5732     cp2 = cp2 + 5;
5733     if (spec[6] != '\0') {
5734       cp1[9] == '/';
5735       cp1++;
5736       cp2++;
5737     }
5738   }
5739
5740    /* Also handle special case "SYS$SCRATCH:" */
5741 #if __CRTL_VER < 70000000
5742   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5743   if (cmp_rslt != 0)
5744      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5745 #else
5746   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5747 #endif
5748   tmp = PerlMem_malloc(VMS_MAXRSS);
5749   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
5750   if (cmp_rslt == 0) {
5751   int islnm;
5752
5753     islnm = my_trnlnm(tmp, "TMP", 0);
5754     if (!islnm) {
5755       strcpy(rslt, "/tmp");
5756       cp1 = cp1 + 4;
5757       cp2 = cp2 + 12;
5758       if (spec[12] != '\0') {
5759         cp1[4] == '/';
5760         cp1++;
5761         cp2++;
5762       }
5763     }
5764   }
5765
5766   if (*cp2 != '[' && *cp2 != '<') {
5767     *(cp1++) = '/';
5768   }
5769   else {  /* the VMS spec begins with directories */
5770     cp2++;
5771     if (*cp2 == ']' || *cp2 == '>') {
5772       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5773       PerlMem_free(tmp);
5774       return rslt;
5775     }
5776     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5777       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
5778         if (ts) Safefree(rslt);
5779         PerlMem_free(tmp);
5780         return NULL;
5781       }
5782       trnlnm_iter_count = 0;
5783       do {
5784         cp3 = tmp;
5785         while (*cp3 != ':' && *cp3) cp3++;
5786         *(cp3++) = '\0';
5787         if (strchr(cp3,']') != NULL) break;
5788         trnlnm_iter_count++;
5789         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5790       } while (vmstrnenv(tmp,tmp,0,fildev,0));
5791       if (ts && !buf &&
5792           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5793         retlen = devlen + dirlen;
5794         Renew(rslt,retlen+1+2*expand,char);
5795         cp1 = rslt;
5796       }
5797       cp3 = tmp;
5798       *(cp1++) = '/';
5799       while (*cp3) {
5800         *(cp1++) = *(cp3++);
5801         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
5802             PerlMem_free(tmp);
5803             return NULL; /* No room */
5804         }
5805       }
5806       *(cp1++) = '/';
5807     }
5808     if ((*cp2 == '^')) {
5809         /* EFS file escape, pass the next character as is */
5810         /* Fix me: HEX encoding for UNICODE not implemented */
5811         cp2++;
5812     }
5813     else if ( *cp2 == '.') {
5814       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5815         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5816         cp2 += 3;
5817       }
5818       else cp2++;
5819     }
5820   }
5821   PerlMem_free(tmp);
5822   for (; cp2 <= dirend; cp2++) {
5823     if ((*cp2 == '^')) {
5824         /* EFS file escape, pass the next character as is */
5825         /* Fix me: HEX encoding for UNICODE not implemented */
5826         cp2++;
5827         *(cp1++) = *cp2;
5828     }
5829     if (*cp2 == ':') {
5830       *(cp1++) = '/';
5831       if (*(cp2+1) == '[') cp2++;
5832     }
5833     else if (*cp2 == ']' || *cp2 == '>') {
5834       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5835     }
5836     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5837       *(cp1++) = '/';
5838       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5839         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5840                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5841         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5842             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5843       }
5844       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5845         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5846         cp2 += 2;
5847       }
5848     }
5849     else if (*cp2 == '-') {
5850       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5851         while (*cp2 == '-') {
5852           cp2++;
5853           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5854         }
5855         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5856           if (ts) Safefree(rslt);                        /* filespecs like */
5857           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
5858           return NULL;
5859         }
5860       }
5861       else *(cp1++) = *cp2;
5862     }
5863     else *(cp1++) = *cp2;
5864   }
5865   while (*cp2) *(cp1++) = *(cp2++);
5866   *cp1 = '\0';
5867
5868   /* This still leaves /000000/ when working with a
5869    * VMS device root or concealed root.
5870    */
5871   {
5872   int ulen;
5873   char * zeros;
5874
5875       ulen = strlen(rslt);
5876
5877       /* Get rid of "000000/ in rooted filespecs */
5878       if (ulen > 7) {
5879         zeros = strstr(rslt, "/000000/");
5880         if (zeros != NULL) {
5881           int mlen;
5882           mlen = ulen - (zeros - rslt) - 7;
5883           memmove(zeros, &zeros[7], mlen);
5884           ulen = ulen - 7;
5885           rslt[ulen] = '\0';
5886         }
5887       }
5888   }
5889
5890   return rslt;
5891
5892 }  /* end of do_tounixspec() */
5893 /*}}}*/
5894 /* External entry points */
5895 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
5896   { return do_tounixspec(spec,buf,0, NULL); }
5897 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
5898   { return do_tounixspec(spec,buf,1, NULL); }
5899 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
5900   { return do_tounixspec(spec,buf,0, utf8_fl); }
5901 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
5902   { return do_tounixspec(spec,buf,1, utf8_fl); }
5903
5904 #if __CRTL_VER >= 70200000 && !defined(__VAX)
5905
5906 /*
5907  This procedure is used to identify if a path is based in either
5908  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
5909  it returns the OpenVMS format directory for it.
5910
5911  It is expecting specifications of only '/' or '/xxxx/'
5912
5913  If a posix root does not exist, or 'xxxx' is not a directory
5914  in the posix root, it returns a failure.
5915
5916  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
5917
5918  It is used only internally by posix_to_vmsspec_hardway().
5919  */
5920
5921 static int posix_root_to_vms
5922   (char *vmspath, int vmspath_len,
5923    const char *unixpath,
5924    const int * utf8_fl) {
5925 int sts;
5926 struct FAB myfab = cc$rms_fab;
5927 struct NAML mynam = cc$rms_naml;
5928 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5929  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5930 char *esa;
5931 char *vms_delim;
5932 int dir_flag;
5933 int unixlen;
5934
5935     dir_flag = 0;
5936     unixlen = strlen(unixpath);
5937     if (unixlen == 0) {
5938       vmspath[0] = '\0';
5939       return RMS$_FNF;
5940     }
5941
5942 #if __CRTL_VER >= 80200000
5943   /* If not a posix spec already, convert it */
5944   if (decc_posix_compliant_pathnames) {
5945     if (strncmp(unixpath,"\"^UP^",5) != 0) {
5946       sprintf(vmspath,"\"^UP^%s\"",unixpath);
5947     }
5948     else {
5949       /* This is already a VMS specification, no conversion */
5950       unixlen--;
5951       strncpy(vmspath,unixpath, vmspath_len);
5952     }
5953   }
5954   else
5955 #endif
5956   {
5957   int path_len;
5958   int i,j;
5959
5960      /* Check to see if this is under the POSIX root */
5961      if (decc_disable_posix_root) {
5962         return RMS$_FNF;
5963      }
5964
5965      /* Skip leading / */
5966      if (unixpath[0] == '/') {
5967         unixpath++;
5968         unixlen--;
5969      }
5970
5971
5972      strcpy(vmspath,"SYS$POSIX_ROOT:");
5973
5974      /* If this is only the / , or blank, then... */
5975      if (unixpath[0] == '\0') {
5976         /* by definition, this is the answer */
5977         return SS$_NORMAL;
5978      }
5979
5980      /* Need to look up a directory */
5981      vmspath[15] = '[';
5982      vmspath[16] = '\0';
5983
5984      /* Copy and add '^' escape characters as needed */
5985      j = 16;
5986      i = 0;
5987      while (unixpath[i] != 0) {
5988      int k;
5989
5990         j += copy_expand_unix_filename_escape
5991             (&vmspath[j], &unixpath[i], &k, utf8_fl);
5992         i += k;
5993      }
5994
5995      path_len = strlen(vmspath);
5996      if (vmspath[path_len - 1] == '/')
5997         path_len--;
5998      vmspath[path_len] = ']';
5999      path_len++;
6000      vmspath[path_len] = '\0';
6001
6002   }
6003   vmspath[vmspath_len] = 0;
6004   if (unixpath[unixlen - 1] == '/')
6005   dir_flag = 1;
6006   esa = PerlMem_malloc(VMS_MAXRSS);
6007   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6008   myfab.fab$l_fna = vmspath;
6009   myfab.fab$b_fns = strlen(vmspath);
6010   myfab.fab$l_naml = &mynam;
6011   mynam.naml$l_esa = NULL;
6012   mynam.naml$b_ess = 0;
6013   mynam.naml$l_long_expand = esa;
6014   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6015   mynam.naml$l_rsa = NULL;
6016   mynam.naml$b_rss = 0;
6017   if (decc_efs_case_preserve)
6018     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6019 #ifdef NAML$M_OPEN_SPECIAL
6020   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6021 #endif
6022
6023   /* Set up the remaining naml fields */
6024   sts = sys$parse(&myfab);
6025
6026   /* It failed! Try again as a UNIX filespec */
6027   if (!(sts & 1)) {
6028     PerlMem_free(esa);
6029     return sts;
6030   }
6031
6032    /* get the Device ID and the FID */
6033    sts = sys$search(&myfab);
6034    /* on any failure, returned the POSIX ^UP^ filespec */
6035    if (!(sts & 1)) {
6036       PerlMem_free(esa);
6037       return sts;
6038    }
6039    specdsc.dsc$a_pointer = vmspath;
6040    specdsc.dsc$w_length = vmspath_len;
6041
6042    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6043    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6044    sts = lib$fid_to_name
6045       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6046
6047   /* on any failure, returned the POSIX ^UP^ filespec */
6048   if (!(sts & 1)) {
6049      /* This can happen if user does not have permission to read directories */
6050      if (strncmp(unixpath,"\"^UP^",5) != 0)
6051        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6052      else
6053        strcpy(vmspath, unixpath);
6054   }
6055   else {
6056     vmspath[specdsc.dsc$w_length] = 0;
6057
6058     /* Are we expecting a directory? */
6059     if (dir_flag != 0) {
6060     int i;
6061     char *eptr;
6062
6063       eptr = NULL;
6064
6065       i = specdsc.dsc$w_length - 1;
6066       while (i > 0) {
6067       int zercnt;
6068         zercnt = 0;
6069         /* Version must be '1' */
6070         if (vmspath[i--] != '1')
6071           break;
6072         /* Version delimiter is one of ".;" */
6073         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6074           break;
6075         i--;
6076         if (vmspath[i--] != 'R')
6077           break;
6078         if (vmspath[i--] != 'I')
6079           break;
6080         if (vmspath[i--] != 'D')
6081           break;
6082         if (vmspath[i--] != '.')
6083           break;
6084         eptr = &vmspath[i+1];
6085         while (i > 0) {
6086           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6087             if (vmspath[i-1] != '^') {
6088               if (zercnt != 6) {
6089                 *eptr = vmspath[i];
6090                 eptr[1] = '\0';
6091                 vmspath[i] = '.';
6092                 break;
6093               }
6094               else {
6095                 /* Get rid of 6 imaginary zero directory filename */
6096                 vmspath[i+1] = '\0';
6097               }
6098             }
6099           }
6100           if (vmspath[i] == '0')
6101             zercnt++;
6102           else
6103             zercnt = 10;
6104           i--;
6105         }
6106         break;
6107       }
6108     }
6109   }
6110   PerlMem_free(esa);
6111   return sts;
6112 }
6113
6114 /* /dev/mumble needs to be handled special.
6115    /dev/null becomes NLA0:, And there is the potential for other stuff
6116    like /dev/tty which may need to be mapped to something.
6117 */
6118
6119 static int
6120 slash_dev_special_to_vms
6121    (const char * unixptr,
6122     char * vmspath,
6123     int vmspath_len)
6124 {
6125 char * nextslash;
6126 int len;
6127 int cmp;
6128 int islnm;
6129
6130     unixptr += 4;
6131     nextslash = strchr(unixptr, '/');
6132     len = strlen(unixptr);
6133     if (nextslash != NULL)
6134         len = nextslash - unixptr;
6135     cmp = strncmp("null", unixptr, 5);
6136     if (cmp == 0) {
6137         if (vmspath_len >= 6) {
6138             strcpy(vmspath, "_NLA0:");
6139             return SS$_NORMAL;
6140         }
6141     }
6142 }
6143
6144
6145 /* The built in routines do not understand perl's special needs, so
6146     doing a manual conversion from UNIX to VMS
6147
6148     If the utf8_fl is not null and points to a non-zero value, then
6149     treat 8 bit characters as UTF-8.
6150
6151     The sequence starting with '$(' and ending with ')' will be passed
6152     through with out interpretation instead of being escaped.
6153
6154   */
6155 static int posix_to_vmsspec_hardway
6156   (char *vmspath, int vmspath_len,
6157    const char *unixpath,
6158    int dir_flag,
6159    int * utf8_fl) {
6160
6161 char *esa;
6162 const char *unixptr;
6163 const char *unixend;
6164 char *vmsptr;
6165 const char *lastslash;
6166 const char *lastdot;
6167 int unixlen;
6168 int vmslen;
6169 int dir_start;
6170 int dir_dot;
6171 int quoted;
6172 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6173 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6174
6175   if (utf8_fl != NULL)
6176     *utf8_fl = 0;
6177
6178   unixptr = unixpath;
6179   dir_dot = 0;
6180
6181   /* Ignore leading "/" characters */
6182   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6183     unixptr++;
6184   }
6185   unixlen = strlen(unixptr);
6186
6187   /* Do nothing with blank paths */
6188   if (unixlen == 0) {
6189     vmspath[0] = '\0';
6190     return SS$_NORMAL;
6191   }
6192
6193   quoted = 0;
6194   /* This could have a "^UP^ on the front */
6195   if (strncmp(unixptr,"\"^UP^",5) == 0) {
6196     quoted = 1;
6197     unixptr+= 5;
6198     unixlen-= 5;
6199   }
6200
6201   lastslash = strrchr(unixptr,'/');
6202   lastdot = strrchr(unixptr,'.');
6203   unixend = strrchr(unixptr,'\"');
6204   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6205     unixend = unixptr + unixlen;
6206   }
6207
6208   /* last dot is last dot or past end of string */
6209   if (lastdot == NULL)
6210     lastdot = unixptr + unixlen;
6211
6212   /* if no directories, set last slash to beginning of string */
6213   if (lastslash == NULL) {
6214     lastslash = unixptr;
6215   }
6216   else {
6217     /* Watch out for trailing "." after last slash, still a directory */
6218     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6219       lastslash = unixptr + unixlen;
6220     }
6221
6222     /* Watch out for traiing ".." after last slash, still a directory */
6223     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6224       lastslash = unixptr + unixlen;
6225     }
6226
6227     /* dots in directories are aways escaped */
6228     if (lastdot < lastslash)
6229       lastdot = unixptr + unixlen;
6230   }
6231
6232   /* if (unixptr < lastslash) then we are in a directory */
6233
6234   dir_start = 0;
6235
6236   vmsptr = vmspath;
6237   vmslen = 0;
6238
6239   /* Start with the UNIX path */
6240   if (*unixptr != '/') {
6241     /* relative paths */
6242
6243     /* If allowing logical names on relative pathnames, then handle here */
6244     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6245         !decc_posix_compliant_pathnames) {
6246     char * nextslash;
6247     int seg_len;
6248     char * trn;
6249     int islnm;
6250
6251         /* Find the next slash */
6252         nextslash = strchr(unixptr,'/');
6253
6254         esa = PerlMem_malloc(vmspath_len);
6255         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6256
6257         trn = PerlMem_malloc(VMS_MAXRSS);
6258         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6259
6260         if (nextslash != NULL) {
6261
6262             seg_len = nextslash - unixptr;
6263             strncpy(esa, unixptr, seg_len);
6264             esa[seg_len] = 0;
6265         }
6266         else {
6267             strcpy(esa, unixptr);
6268             seg_len = strlen(unixptr);
6269         }
6270         /* trnlnm(section) */
6271         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6272
6273         if (islnm) {
6274             /* Now fix up the directory */
6275
6276             /* Split up the path to find the components */
6277             sts = vms_split_path
6278                   (trn,
6279                    &v_spec,
6280                    &v_len,
6281                    &r_spec,
6282                    &r_len,
6283                    &d_spec,
6284                    &d_len,
6285                    &n_spec,
6286                    &n_len,
6287                    &e_spec,
6288                    &e_len,
6289                    &vs_spec,
6290                    &vs_len);
6291
6292             while (sts == 0) {
6293             char * strt;
6294             int cmp;
6295
6296                 /* A logical name must be a directory  or the full
6297                    specification.  It is only a full specification if
6298                    it is the only component */
6299                 if ((unixptr[seg_len] == '\0') ||
6300                     (unixptr[seg_len+1] == '\0')) {
6301
6302                     /* Is a directory being required? */
6303                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6304                         /* Not a logical name */
6305                         break;
6306                     }
6307
6308
6309                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6310                         /* This must be a directory */
6311                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6312                             strcpy(vmsptr, esa);
6313                             vmslen=strlen(vmsptr);
6314                             vmsptr[vmslen] = ':';
6315                             vmslen++;
6316                             vmsptr[vmslen] = '\0';
6317                             return SS$_NORMAL;
6318                         }
6319                     }
6320
6321                 }
6322
6323
6324                 /* must be dev/directory - ignore version */
6325                 if ((n_len + e_len) != 0)
6326                     break;
6327
6328                 /* transfer the volume */
6329                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6330                     strncpy(vmsptr, v_spec, v_len);
6331                     vmsptr += v_len;
6332                     vmsptr[0] = '\0';
6333                     vmslen += v_len;
6334                 }
6335
6336                 /* unroot the rooted directory */
6337                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6338                     r_spec[0] = '[';
6339                     r_spec[r_len - 1] = ']';
6340
6341                     /* This should not be there, but nothing is perfect */
6342                     if (r_len > 9) {
6343                         cmp = strcmp(&r_spec[1], "000000.");
6344                         if (cmp == 0) {
6345                             r_spec += 7;
6346                             r_spec[7] = '[';
6347                             r_len -= 7;
6348                             if (r_len == 2)
6349                                 r_len = 0;
6350                         }
6351                     }
6352                     if (r_len > 0) {
6353                         strncpy(vmsptr, r_spec, r_len);
6354                         vmsptr += r_len;
6355                         vmslen += r_len;
6356                         vmsptr[0] = '\0';
6357                     }
6358                 }
6359                 /* Bring over the directory. */
6360                 if ((d_len > 0) &&
6361                     ((d_len + vmslen) < vmspath_len)) {
6362                     d_spec[0] = '[';
6363                     d_spec[d_len - 1] = ']';
6364                     if (d_len > 9) {
6365                         cmp = strcmp(&d_spec[1], "000000.");
6366                         if (cmp == 0) {
6367                             d_spec += 7;
6368                             d_spec[7] = '[';
6369                             d_len -= 7;
6370                             if (d_len == 2)
6371                                 d_len = 0;
6372                         }
6373                     }
6374
6375                     if (r_len > 0) {
6376                         /* Remove the redundant root */
6377                         if (r_len > 0) {
6378                             /* remove the ][ */
6379                             vmsptr--;
6380                             vmslen--;
6381                             d_spec++;
6382                             d_len--;
6383                         }
6384                         strncpy(vmsptr, d_spec, d_len);
6385                             vmsptr += d_len;
6386                             vmslen += d_len;
6387                             vmsptr[0] = '\0';
6388                     }
6389                 }
6390                 break;
6391             }
6392         }
6393
6394         PerlMem_free(esa);
6395         PerlMem_free(trn);
6396     }
6397
6398     if (lastslash > unixptr) {
6399     int dotdir_seen;
6400
6401       /* skip leading ./ */
6402       dotdir_seen = 0;
6403       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6404         dotdir_seen = 1;
6405         unixptr++;
6406         unixptr++;
6407       }
6408
6409       /* Are we still in a directory? */
6410       if (unixptr <= lastslash) {
6411         *vmsptr++ = '[';
6412         vmslen = 1;
6413         dir_start = 1;
6414
6415         /* if not backing up, then it is relative forward. */
6416         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6417               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6418           *vmsptr++ = '.';
6419           vmslen++;
6420           dir_dot = 1;
6421           }
6422        }
6423        else {
6424          if (dotdir_seen) {
6425            /* Perl wants an empty directory here to tell the difference
6426             * between a DCL commmand and a filename
6427             */
6428           *vmsptr++ = '[';
6429           *vmsptr++ = ']';
6430           vmslen = 2;
6431         }
6432       }
6433     }
6434     else {
6435       /* Handle two special files . and .. */
6436       if (unixptr[0] == '.') {
6437         if (&unixptr[1] == unixend) {
6438           *vmsptr++ = '[';
6439           *vmsptr++ = ']';
6440           vmslen += 2;
6441           *vmsptr++ = '\0';
6442           return SS$_NORMAL;
6443         }
6444         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6445           *vmsptr++ = '[';
6446           *vmsptr++ = '-';
6447           *vmsptr++ = ']';
6448           vmslen += 3;
6449           *vmsptr++ = '\0';
6450           return SS$_NORMAL;
6451         }
6452       }
6453     }
6454   }
6455   else {        /* Absolute PATH handling */
6456   int sts;
6457   char * nextslash;
6458   int seg_len;
6459     /* Need to find out where root is */
6460
6461     /* In theory, this procedure should never get an absolute POSIX pathname
6462      * that can not be found on the POSIX root.
6463      * In practice, that can not be relied on, and things will show up
6464      * here that are a VMS device name or concealed logical name instead.
6465      * So to make things work, this procedure must be tolerant.
6466      */
6467     esa = PerlMem_malloc(vmspath_len);
6468     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6469
6470     sts = SS$_NORMAL;
6471     nextslash = strchr(&unixptr[1],'/');
6472     seg_len = 0;
6473     if (nextslash != NULL) {
6474     int cmp;
6475       seg_len = nextslash - &unixptr[1];
6476       strncpy(vmspath, unixptr, seg_len + 1);
6477       vmspath[seg_len+1] = 0;
6478       cmp = 1;
6479       if (seg_len == 3) {
6480         cmp = strncmp(vmspath, "dev", 4);
6481         if (cmp == 0) {
6482             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6483             if (sts = SS$_NORMAL)
6484                 return SS$_NORMAL;
6485         }
6486       }
6487       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6488     }
6489
6490     if ($VMS_STATUS_SUCCESS(sts)) {
6491       /* This is verified to be a real path */
6492
6493       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6494       if ($VMS_STATUS_SUCCESS(sts)) {
6495         strcpy(vmspath, esa);
6496         vmslen = strlen(vmspath);
6497         vmsptr = vmspath + vmslen;
6498         unixptr++;
6499         if (unixptr < lastslash) {
6500         char * rptr;
6501           vmsptr--;
6502           *vmsptr++ = '.';
6503           dir_start = 1;
6504           dir_dot = 1;
6505           if (vmslen > 7) {
6506           int cmp;
6507             rptr = vmsptr - 7;
6508             cmp = strcmp(rptr,"000000.");
6509             if (cmp == 0) {
6510               vmslen -= 7;
6511               vmsptr -= 7;
6512               vmsptr[1] = '\0';
6513             } /* removing 6 zeros */
6514           } /* vmslen < 7, no 6 zeros possible */
6515         } /* Not in a directory */
6516       } /* Posix root found */
6517       else {
6518         /* No posix root, fall back to default directory */
6519         strcpy(vmspath, "SYS$DISK:[");
6520         vmsptr = &vmspath[10];
6521         vmslen = 10;
6522         if (unixptr > lastslash) {
6523            *vmsptr = ']';
6524            vmsptr++;
6525            vmslen++;
6526         }
6527         else {
6528            dir_start = 1;
6529         }
6530       }
6531     } /* end of verified real path handling */
6532     else {
6533     int add_6zero;
6534     int islnm;
6535
6536       /* Ok, we have a device or a concealed root that is not in POSIX
6537        * or we have garbage.  Make the best of it.
6538        */
6539
6540       /* Posix to VMS destroyed this, so copy it again */
6541       strncpy(vmspath, &unixptr[1], seg_len);
6542       vmspath[seg_len] = 0;
6543       vmslen = seg_len;
6544       vmsptr = &vmsptr[vmslen];
6545       islnm = 0;
6546
6547       /* Now do we need to add the fake 6 zero directory to it? */
6548       add_6zero = 1;
6549       if ((*lastslash == '/') && (nextslash < lastslash)) {
6550         /* No there is another directory */
6551         add_6zero = 0;
6552       }
6553       else {
6554       int trnend;
6555       int cmp;
6556
6557         /* now we have foo:bar or foo:[000000]bar to decide from */
6558         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6559
6560         if (!islnm && !decc_posix_compliant_pathnames) {
6561
6562             cmp = strncmp("bin", vmspath, 4);
6563             if (cmp == 0) {
6564                 /* bin => SYS$SYSTEM: */
6565                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6566             }
6567             else {
6568                 /* tmp => SYS$SCRATCH: */
6569                 cmp = strncmp("tmp", vmspath, 4);
6570                 if (cmp == 0) {
6571                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6572                 }
6573             }
6574         }
6575
6576         trnend = islnm ? islnm - 1 : 0;
6577
6578         /* if this was a logical name, ']' or '>' must be present */
6579         /* if not a logical name, then assume a device and hope. */
6580         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6581
6582         /* if log name and trailing '.' then rooted - treat as device */
6583         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6584
6585         /* Fix me, if not a logical name, a device lookup should be
6586          * done to see if the device is file structured.  If the device
6587          * is not file structured, the 6 zeros should not be put on.
6588          *
6589          * As it is, perl is occasionally looking for dev:[000000]tty.
6590          * which looks a little strange.
6591          *
6592          * Not that easy to detect as "/dev" may be file structured with
6593          * special device files.
6594          */
6595
6596         if ((add_6zero == 0) && (*nextslash == '/') &&
6597             (&nextslash[1] == unixend)) {
6598           /* No real directory present */
6599           add_6zero = 1;
6600         }
6601       }
6602
6603       /* Put the device delimiter on */
6604       *vmsptr++ = ':';
6605       vmslen++;
6606       unixptr = nextslash;
6607       unixptr++;
6608
6609       /* Start directory if needed */
6610       if (!islnm || add_6zero) {
6611         *vmsptr++ = '[';
6612         vmslen++;
6613         dir_start = 1;
6614       }
6615
6616       /* add fake 000000] if needed */
6617       if (add_6zero) {
6618         *vmsptr++ = '0';
6619         *vmsptr++ = '0';
6620         *vmsptr++ = '0';
6621         *vmsptr++ = '0';
6622         *vmsptr++ = '0';
6623         *vmsptr++ = '0';
6624         *vmsptr++ = ']';
6625         vmslen += 7;
6626         dir_start = 0;
6627       }
6628
6629     } /* non-POSIX translation */
6630     PerlMem_free(esa);
6631   } /* End of relative/absolute path handling */
6632
6633   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6634   int dash_flag;
6635   int in_cnt;
6636   int out_cnt;
6637
6638     dash_flag = 0;
6639
6640     if (dir_start != 0) {
6641
6642       /* First characters in a directory are handled special */
6643       while ((*unixptr == '/') ||
6644              ((*unixptr == '.') &&
6645               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6646                 (&unixptr[1]==unixend)))) {
6647       int loop_flag;
6648
6649         loop_flag = 0;
6650
6651         /* Skip redundant / in specification */
6652         while ((*unixptr == '/') && (dir_start != 0)) {
6653           loop_flag = 1;
6654           unixptr++;
6655           if (unixptr == lastslash)
6656             break;
6657         }
6658         if (unixptr == lastslash)
6659           break;
6660
6661         /* Skip redundant ./ characters */
6662         while ((*unixptr == '.') &&
6663                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6664           loop_flag = 1;
6665           unixptr++;
6666           if (unixptr == lastslash)
6667             break;
6668           if (*unixptr == '/')
6669             unixptr++;
6670         }
6671         if (unixptr == lastslash)
6672           break;
6673
6674         /* Skip redundant ../ characters */
6675         while ((*unixptr == '.') && (unixptr[1] == '.') &&
6676              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6677           /* Set the backing up flag */
6678           loop_flag = 1;
6679           dir_dot = 0;
6680           dash_flag = 1;
6681           *vmsptr++ = '-';
6682           vmslen++;
6683           unixptr++; /* first . */
6684           unixptr++; /* second . */
6685           if (unixptr == lastslash)
6686             break;
6687           if (*unixptr == '/') /* The slash */
6688             unixptr++;
6689         }
6690         if (unixptr == lastslash)
6691           break;
6692
6693         /* To do: Perl expects /.../ to be translated to [...] on VMS */
6694         /* Not needed when VMS is pretending to be UNIX. */
6695
6696         /* Is this loop stuck because of too many dots? */
6697         if (loop_flag == 0) {
6698           /* Exit the loop and pass the rest through */
6699           break;
6700         }
6701       }
6702
6703       /* Are we done with directories yet? */
6704       if (unixptr >= lastslash) {
6705
6706         /* Watch out for trailing dots */
6707         if (dir_dot != 0) {
6708             vmslen --;
6709             vmsptr--;
6710         }
6711         *vmsptr++ = ']';
6712         vmslen++;
6713         dash_flag = 0;
6714         dir_start = 0;
6715         if (*unixptr == '/')
6716           unixptr++;
6717       }
6718       else {
6719         /* Have we stopped backing up? */
6720         if (dash_flag) {
6721           *vmsptr++ = '.';
6722           vmslen++;
6723           dash_flag = 0;
6724           /* dir_start continues to be = 1 */
6725         }
6726         if (*unixptr == '-') {
6727           *vmsptr++ = '^';
6728           *vmsptr++ = *unixptr++;
6729           vmslen += 2;
6730           dir_start = 0;
6731
6732           /* Now are we done with directories yet? */
6733           if (unixptr >= lastslash) {
6734
6735             /* Watch out for trailing dots */
6736             if (dir_dot != 0) {
6737               vmslen --;
6738               vmsptr--;
6739             }
6740
6741             *vmsptr++ = ']';
6742             vmslen++;
6743             dash_flag = 0;
6744             dir_start = 0;
6745           }
6746         }
6747       }
6748     }
6749
6750     /* All done? */
6751     if (unixptr >= unixend)
6752       break;
6753
6754     /* Normal characters - More EFS work probably needed */
6755     dir_start = 0;
6756     dir_dot = 0;
6757
6758     switch(*unixptr) {
6759     case '/':
6760         /* remove multiple / */
6761         while (unixptr[1] == '/') {
6762            unixptr++;
6763         }
6764         if (unixptr == lastslash) {
6765           /* Watch out for trailing dots */
6766           if (dir_dot != 0) {
6767             vmslen --;
6768             vmsptr--;
6769           }
6770           *vmsptr++ = ']';
6771         }
6772         else {
6773           dir_start = 1;
6774           *vmsptr++ = '.';
6775           dir_dot = 1;
6776
6777           /* To do: Perl expects /.../ to be translated to [...] on VMS */
6778           /* Not needed when VMS is pretending to be UNIX. */
6779
6780         }
6781         dash_flag = 0;
6782         if (unixptr != unixend)
6783           unixptr++;
6784         vmslen++;
6785         break;
6786     case '.':
6787         if ((unixptr < lastdot) || (unixptr < lastslash) ||
6788             (&unixptr[1] == unixend)) {
6789           *vmsptr++ = '^';
6790           *vmsptr++ = '.';
6791           vmslen += 2;
6792           unixptr++;
6793
6794           /* trailing dot ==> '^..' on VMS */
6795           if (unixptr == unixend) {
6796             *vmsptr++ = '.';
6797             vmslen++;
6798             unixptr++;
6799           }
6800           break;
6801         }
6802
6803         *vmsptr++ = *unixptr++;
6804         vmslen ++;
6805         break;
6806     case '"':
6807         if (quoted && (&unixptr[1] == unixend)) {
6808             unixptr++;
6809             break;
6810         }
6811         in_cnt = copy_expand_unix_filename_escape
6812                 (vmsptr, unixptr, &out_cnt, utf8_fl);
6813         vmsptr += out_cnt;
6814         unixptr += in_cnt;
6815         break;
6816     case '~':
6817     case ';':
6818     case '\\':
6819     case '?':
6820     case ' ':
6821     default:
6822         in_cnt = copy_expand_unix_filename_escape
6823                 (vmsptr, unixptr, &out_cnt, utf8_fl);
6824         vmsptr += out_cnt;
6825         unixptr += in_cnt;
6826         break;
6827     }
6828   }
6829
6830   /* Make sure directory is closed */
6831   if (unixptr == lastslash) {
6832     char *vmsptr2;
6833     vmsptr2 = vmsptr - 1;
6834
6835     if (*vmsptr2 != ']') {
6836       *vmsptr2--;
6837
6838       /* directories do not end in a dot bracket */
6839       if (*vmsptr2 == '.') {
6840         vmsptr2--;
6841
6842         /* ^. is allowed */
6843         if (*vmsptr2 != '^') {
6844           vmsptr--; /* back up over the dot */
6845         }
6846       }
6847       *vmsptr++ = ']';
6848     }
6849   }
6850   else {
6851     char *vmsptr2;
6852     /* Add a trailing dot if a file with no extension */
6853     vmsptr2 = vmsptr - 1;
6854     if ((vmslen > 1) &&
6855         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6856         (*vmsptr2 != ')') && (*lastdot != '.')) {
6857         *vmsptr++ = '.';
6858         vmslen++;
6859     }
6860   }
6861
6862   *vmsptr = '\0';
6863   return SS$_NORMAL;
6864 }
6865 #endif
6866
6867  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
6868 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
6869 {
6870 char * result;
6871 int utf8_flag;
6872
6873    /* If a UTF8 flag is being passed, honor it */
6874    utf8_flag = 0;
6875    if (utf8_fl != NULL) {
6876      utf8_flag = *utf8_fl;
6877     *utf8_fl = 0;
6878    }
6879
6880    if (utf8_flag) {
6881      /* If there is a possibility of UTF8, then if any UTF8 characters
6882         are present, then they must be converted to VTF-7
6883       */
6884      result = strcpy(rslt, path); /* FIX-ME */
6885    }
6886    else
6887      result = strcpy(rslt, path);
6888
6889    return result;
6890 }
6891
6892
6893 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
6894 static char *mp_do_tovmsspec
6895    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
6896   static char __tovmsspec_retbuf[VMS_MAXRSS];
6897   char *rslt, *dirend;
6898   char *lastdot;
6899   char *vms_delim;
6900   register char *cp1;
6901   const char *cp2;
6902   unsigned long int infront = 0, hasdir = 1;
6903   int rslt_len;
6904   int no_type_seen;
6905   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6906   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6907
6908   if (path == NULL) return NULL;
6909   rslt_len = VMS_MAXRSS-1;
6910   if (buf) rslt = buf;
6911   else if (ts) Newx(rslt, VMS_MAXRSS, char);
6912   else rslt = __tovmsspec_retbuf;
6913
6914   /* '.' and '..' are "[]" and "[-]" for a quick check */
6915   if (path[0] == '.') {
6916     if (path[1] == '\0') {
6917       strcpy(rslt,"[]");
6918       if (utf8_flag != NULL)
6919         *utf8_flag = 0;
6920       return rslt;
6921     }
6922     else {
6923       if (path[1] == '.' && path[2] == '\0') {
6924         strcpy(rslt,"[-]");
6925         if (utf8_flag != NULL)
6926            *utf8_flag = 0;
6927         return rslt;
6928       }
6929     }
6930   }
6931
6932    /* Posix specifications are now a native VMS format */
6933   /*--------------------------------------------------*/
6934 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6935   if (decc_posix_compliant_pathnames) {
6936     if (strncmp(path,"\"^UP^",5) == 0) {
6937       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
6938       return rslt;
6939     }
6940   }
6941 #endif
6942
6943   /* This is really the only way to see if this is already in VMS format */
6944   sts = vms_split_path
6945        (path,
6946         &v_spec,
6947         &v_len,
6948         &r_spec,
6949         &r_len,
6950         &d_spec,
6951         &d_len,
6952         &n_spec,
6953         &n_len,
6954         &e_spec,
6955         &e_len,
6956         &vs_spec,
6957         &vs_len);
6958   if (sts == 0) {
6959     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
6960        replacement, because the above parse just took care of most of
6961        what is needed to do vmspath when the specification is already
6962        in VMS format.
6963
6964        And if it is not already, it is easier to do the conversion as
6965        part of this routine than to call this routine and then work on
6966        the result.
6967      */
6968
6969     /* If VMS punctuation was found, it is already VMS format */
6970     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
6971       if (utf8_flag != NULL)
6972         *utf8_flag = 0;
6973       strcpy(rslt, path);
6974       return rslt;
6975     }
6976     /* Now, what to do with trailing "." cases where there is no
6977        extension?  If this is a UNIX specification, and EFS characters
6978        are enabled, then the trailing "." should be converted to a "^.".
6979        But if this was already a VMS specification, then it should be
6980        left alone.
6981
6982        So in the case of ambiguity, leave the specification alone.
6983      */
6984
6985
6986     /* If there is a possibility of UTF8, then if any UTF8 characters
6987         are present, then they must be converted to VTF-7
6988      */
6989     if (utf8_flag != NULL)
6990       *utf8_flag = 0;
6991     strcpy(rslt, path);
6992     return rslt;
6993   }
6994
6995   dirend = strrchr(path,'/');
6996
6997   if (dirend == NULL) {
6998      /* If we get here with no UNIX directory delimiters, then this is
6999         not a complete file specification, either garbage a UNIX glob
7000         specification that can not be converted to a VMS wildcard, or
7001         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7002         so apparently other programs expect this also.
7003
7004         utf8 flag setting needs to be preserved.
7005       */
7006       strcpy(rslt, path);
7007       return rslt;
7008   }
7009
7010 /* If POSIX mode active, handle the conversion */
7011 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7012   if (decc_efs_charset) {
7013     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7014     return rslt;
7015   }
7016 #endif
7017
7018   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7019     if (!*(dirend+2)) dirend +=2;
7020     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7021     if (decc_efs_charset == 0) {
7022       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7023     }
7024   }
7025
7026   cp1 = rslt;
7027   cp2 = path;
7028   lastdot = strrchr(cp2,'.');
7029   if (*cp2 == '/') {
7030     char *trndev;
7031     int islnm, rooted;
7032     STRLEN trnend;
7033
7034     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7035     if (!*(cp2+1)) {
7036       if (decc_disable_posix_root) {
7037         strcpy(rslt,"sys$disk:[000000]");
7038       }
7039       else {
7040         strcpy(rslt,"sys$posix_root:[000000]");
7041       }
7042       if (utf8_flag != NULL)
7043         *utf8_flag = 0;
7044       return rslt;
7045     }
7046     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7047     *cp1 = '\0';
7048     trndev = PerlMem_malloc(VMS_MAXRSS);
7049     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7050     islnm =  my_trnlnm(rslt,trndev,0);
7051
7052      /* DECC special handling */
7053     if (!islnm) {
7054       if (strcmp(rslt,"bin") == 0) {
7055         strcpy(rslt,"sys$system");
7056         cp1 = rslt + 10;
7057         *cp1 = 0;
7058         islnm =  my_trnlnm(rslt,trndev,0);
7059       }
7060       else if (strcmp(rslt,"tmp") == 0) {
7061         strcpy(rslt,"sys$scratch");
7062         cp1 = rslt + 11;
7063         *cp1 = 0;
7064         islnm =  my_trnlnm(rslt,trndev,0);
7065       }
7066       else if (!decc_disable_posix_root) {
7067         strcpy(rslt, "sys$posix_root");
7068         cp1 = rslt + 13;
7069         *cp1 = 0;
7070         cp2 = path;
7071         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7072         islnm =  my_trnlnm(rslt,trndev,0);
7073       }
7074       else if (strcmp(rslt,"dev") == 0) {
7075         if (strncmp(cp2,"/null", 5) == 0) {
7076           if ((cp2[5] == 0) || (cp2[5] == '/')) {
7077             strcpy(rslt,"NLA0");
7078             cp1 = rslt + 4;
7079             *cp1 = 0;
7080             cp2 = cp2 + 5;
7081             islnm =  my_trnlnm(rslt,trndev,0);
7082           }
7083         }
7084       }
7085     }
7086
7087     trnend = islnm ? strlen(trndev) - 1 : 0;
7088     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7089     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7090     /* If the first element of the path is a logical name, determine
7091      * whether it has to be translated so we can add more directories. */
7092     if (!islnm || rooted) {
7093       *(cp1++) = ':';
7094       *(cp1++) = '[';
7095       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7096       else cp2++;
7097     }
7098     else {
7099       if (cp2 != dirend) {
7100         strcpy(rslt,trndev);
7101         cp1 = rslt + trnend;
7102         if (*cp2 != 0) {
7103           *(cp1++) = '.';
7104           cp2++;
7105         }
7106       }
7107       else {
7108         if (decc_disable_posix_root) {
7109           *(cp1++) = ':';
7110           hasdir = 0;
7111         }
7112       }
7113     }
7114     PerlMem_free(trndev);
7115   }
7116   else {
7117     *(cp1++) = '[';
7118     if (*cp2 == '.') {
7119       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7120         cp2 += 2;         /* skip over "./" - it's redundant */
7121         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
7122       }
7123       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7124         *(cp1++) = '-';                                 /* "../" --> "-" */
7125         cp2 += 3;
7126       }
7127       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7128                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7129         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7130         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7131         cp2 += 4;
7132       }
7133       else if ((cp2 != lastdot) || (lastdot < dirend)) {
7134         /* Escape the extra dots in EFS file specifications */
7135         *(cp1++) = '^';
7136       }
7137       if (cp2 > dirend) cp2 = dirend;
7138     }
7139     else *(cp1++) = '.';
7140   }
7141   for (; cp2 < dirend; cp2++) {
7142     if (*cp2 == '/') {
7143       if (*(cp2-1) == '/') continue;
7144       if (*(cp1-1) != '.') *(cp1++) = '.';
7145       infront = 0;
7146     }
7147     else if (!infront && *cp2 == '.') {
7148       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7149       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
7150       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7151         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7152         else if (*(cp1-2) == '[') *(cp1-1) = '-';
7153         else {  /* back up over previous directory name */
7154           cp1--;
7155           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7156           if (*(cp1-1) == '[') {
7157             memcpy(cp1,"000000.",7);
7158             cp1 += 7;
7159           }
7160         }
7161         cp2 += 2;
7162         if (cp2 == dirend) break;
7163       }
7164       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7165                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7166         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7167         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7168         if (!*(cp2+3)) {
7169           *(cp1++) = '.';  /* Simulate trailing '/' */
7170           cp2 += 2;  /* for loop will incr this to == dirend */
7171         }
7172         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
7173       }
7174       else {
7175         if (decc_efs_charset == 0)
7176           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
7177         else {
7178           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
7179           *(cp1++) = '.';
7180         }
7181       }
7182     }
7183     else {
7184       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
7185       if (*cp2 == '.') {
7186         if (decc_efs_charset == 0)
7187           *(cp1++) = '_';
7188         else {
7189           *(cp1++) = '^';
7190           *(cp1++) = '.';
7191         }
7192       }
7193       else                  *(cp1++) =  *cp2;
7194       infront = 1;
7195     }
7196   }
7197   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7198   if (hasdir) *(cp1++) = ']';
7199   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
7200   /* fixme for ODS5 */
7201   no_type_seen = 0;
7202   if (cp2 > lastdot)
7203     no_type_seen = 1;
7204   while (*cp2) {
7205     switch(*cp2) {
7206     case '?':
7207         if (decc_efs_charset == 0)
7208           *(cp1++) = '%';
7209         else
7210           *(cp1++) = '?';
7211         cp2++;
7212     case ' ':
7213         *(cp1)++ = '^';
7214         *(cp1)++ = '_';
7215         cp2++;
7216         break;
7217     case '.':
7218         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7219             decc_readdir_dropdotnotype) {
7220           *(cp1)++ = '^';
7221           *(cp1)++ = '.';
7222           cp2++;
7223
7224           /* trailing dot ==> '^..' on VMS */
7225           if (*cp2 == '\0') {
7226             *(cp1++) = '.';
7227             no_type_seen = 0;
7228           }
7229         }
7230         else {
7231           *(cp1++) = *(cp2++);
7232           no_type_seen = 0;
7233         }
7234         break;
7235     case '$':
7236          /* This could be a macro to be passed through */
7237         *(cp1++) = *(cp2++);
7238         if (*cp2 == '(') {
7239         const char * save_cp2;
7240         char * save_cp1;
7241         int is_macro;
7242
7243             /* paranoid check */
7244             save_cp2 = cp2;
7245             save_cp1 = cp1;
7246             is_macro = 0;
7247
7248             /* Test through */
7249             *(cp1++) = *(cp2++);
7250             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7251                 *(cp1++) = *(cp2++);
7252                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7253                     *(cp1++) = *(cp2++);
7254                 }
7255                 if (*cp2 == ')') {
7256                     *(cp1++) = *(cp2++);
7257                     is_macro = 1;
7258                 }
7259             }
7260             if (is_macro == 0) {
7261                 /* Not really a macro - never mind */
7262                 cp2 = save_cp2;
7263                 cp1 = save_cp1;
7264             }
7265         }
7266         break;
7267     case '\"':
7268     case '~':
7269     case '`':
7270     case '!':
7271     case '#':
7272     case '%':
7273     case '^':
7274     case '&':
7275     case '(':
7276     case ')':
7277     case '=':
7278     case '+':
7279     case '\'':
7280     case '@':
7281     case '[':
7282     case ']':
7283     case '{':
7284     case '}':
7285     case ':':
7286     case '\\':
7287     case '|':
7288     case '<':
7289     case '>':
7290         *(cp1++) = '^';
7291         *(cp1++) = *(cp2++);
7292         break;
7293     case ';':
7294         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7295          * which is wrong.  UNIX notation should be ".dir." unless
7296          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7297          * changing this behavior could break more things at this time.
7298          * efs character set effectively does not allow "." to be a version
7299          * delimiter as a further complication about changing this.
7300          */
7301         if (decc_filename_unix_report != 0) {
7302           *(cp1++) = '^';
7303         }
7304         *(cp1++) = *(cp2++);
7305         break;
7306     default:
7307         *(cp1++) = *(cp2++);
7308     }
7309   }
7310   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7311   char *lcp1;
7312     lcp1 = cp1;
7313     lcp1--;
7314      /* Fix me for "^]", but that requires making sure that you do
7315       * not back up past the start of the filename
7316       */
7317     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7318       *cp1++ = '.';
7319   }
7320   *cp1 = '\0';
7321
7322   if (utf8_flag != NULL)
7323     *utf8_flag = 0;
7324   return rslt;
7325
7326 }  /* end of do_tovmsspec() */
7327 /*}}}*/
7328 /* External entry points */
7329 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7330   { return do_tovmsspec(path,buf,0,NULL); }
7331 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7332   { return do_tovmsspec(path,buf,1,NULL); }
7333 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7334   { return do_tovmsspec(path,buf,0,utf8_fl); }
7335 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7336   { return do_tovmsspec(path,buf,1,utf8_fl); }
7337
7338 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7339 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7340   static char __tovmspath_retbuf[VMS_MAXRSS];
7341   int vmslen;
7342   char *pathified, *vmsified, *cp;
7343
7344   if (path == NULL) return NULL;
7345   pathified = PerlMem_malloc(VMS_MAXRSS);
7346   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7347   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7348     PerlMem_free(pathified);
7349     return NULL;
7350   }
7351
7352   vmsified = NULL;
7353   if (buf == NULL)
7354      Newx(vmsified, VMS_MAXRSS, char);
7355   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7356     PerlMem_free(pathified);
7357     if (vmsified) Safefree(vmsified);
7358     return NULL;
7359   }
7360   PerlMem_free(pathified);
7361   if (buf) {
7362     return buf;
7363   }
7364   else if (ts) {
7365     vmslen = strlen(vmsified);
7366     Newx(cp,vmslen+1,char);
7367     memcpy(cp,vmsified,vmslen);
7368     cp[vmslen] = '\0';
7369     Safefree(vmsified);
7370     return cp;
7371   }
7372   else {
7373     strcpy(__tovmspath_retbuf,vmsified);
7374     Safefree(vmsified);
7375     return __tovmspath_retbuf;
7376   }
7377
7378 }  /* end of do_tovmspath() */
7379 /*}}}*/
7380 /* External entry points */
7381 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7382   { return do_tovmspath(path,buf,0, NULL); }
7383 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7384   { return do_tovmspath(path,buf,1, NULL); }
7385 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7386   { return do_tovmspath(path,buf,0,utf8_fl); }
7387 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7388   { return do_tovmspath(path,buf,1,utf8_fl); }
7389
7390
7391 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7392 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7393   static char __tounixpath_retbuf[VMS_MAXRSS];
7394   int unixlen;
7395   char *pathified, *unixified, *cp;
7396
7397   if (path == NULL) return NULL;
7398   pathified = PerlMem_malloc(VMS_MAXRSS);
7399   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7400   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7401     PerlMem_free(pathified);
7402     return NULL;
7403   }
7404
7405   unixified = NULL;
7406   if (buf == NULL) {
7407       Newx(unixified, VMS_MAXRSS, char);
7408   }
7409   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7410     PerlMem_free(pathified);
7411     if (unixified) Safefree(unixified);
7412     return NULL;
7413   }
7414   PerlMem_free(pathified);
7415   if (buf) {
7416     return buf;
7417   }
7418   else if (ts) {
7419     unixlen = strlen(unixified);
7420     Newx(cp,unixlen+1,char);
7421     memcpy(cp,unixified,unixlen);
7422     cp[unixlen] = '\0';
7423     Safefree(unixified);
7424     return cp;
7425   }
7426   else {
7427     strcpy(__tounixpath_retbuf,unixified);
7428     Safefree(unixified);
7429     return __tounixpath_retbuf;
7430   }
7431
7432 }  /* end of do_tounixpath() */
7433 /*}}}*/
7434 /* External entry points */
7435 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7436   { return do_tounixpath(path,buf,0,NULL); }
7437 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7438   { return do_tounixpath(path,buf,1,NULL); }
7439 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7440   { return do_tounixpath(path,buf,0,utf8_fl); }
7441 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7442   { return do_tounixpath(path,buf,1,utf8_fl); }
7443
7444 /*
7445  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
7446  *
7447  *****************************************************************************
7448  *                                                                           *
7449  *  Copyright (C) 1989-1994 by                                               *
7450  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
7451  *                                                                           *
7452  *  Permission is hereby  granted for the reproduction of this software,     *
7453  *  on condition that this copyright notice is included in the reproduction, *
7454  *  and that such reproduction is not for purposes of profit or material     *
7455  *  gain.                                                                    *
7456  *                                                                           *
7457  *  27-Aug-1994 Modified for inclusion in perl5                              *
7458  *              by Charles Bailey  bailey@newman.upenn.edu                   *
7459  *****************************************************************************
7460  */
7461
7462 /*
7463  * getredirection() is intended to aid in porting C programs
7464  * to VMS (Vax-11 C).  The native VMS environment does not support
7465  * '>' and '<' I/O redirection, or command line wild card expansion,
7466  * or a command line pipe mechanism using the '|' AND background
7467  * command execution '&'.  All of these capabilities are provided to any
7468  * C program which calls this procedure as the first thing in the
7469  * main program.
7470  * The piping mechanism will probably work with almost any 'filter' type
7471  * of program.  With suitable modification, it may useful for other
7472  * portability problems as well.
7473  *
7474  * Author:  Mark Pizzolato      mark@infocomm.com
7475  */
7476 struct list_item
7477     {
7478     struct list_item *next;
7479     char *value;
7480     };
7481
7482 static void add_item(struct list_item **head,
7483                      struct list_item **tail,
7484                      char *value,
7485                      int *count);
7486
7487 static void mp_expand_wild_cards(pTHX_ char *item,
7488                                 struct list_item **head,
7489                                 struct list_item **tail,
7490                                 int *count);
7491
7492 static int background_process(pTHX_ int argc, char **argv);
7493
7494 static void pipe_and_fork(pTHX_ char **cmargv);
7495
7496 /*{{{ void getredirection(int *ac, char ***av)*/
7497 static void
7498 mp_getredirection(pTHX_ int *ac, char ***av)
7499 /*
7500  * Process vms redirection arg's.  Exit if any error is seen.
7501  * If getredirection() processes an argument, it is erased
7502  * from the vector.  getredirection() returns a new argc and argv value.
7503  * In the event that a background command is requested (by a trailing "&"),
7504  * this routine creates a background subprocess, and simply exits the program.
7505  *
7506  * Warning: do not try to simplify the code for vms.  The code
7507  * presupposes that getredirection() is called before any data is
7508  * read from stdin or written to stdout.
7509  *
7510  * Normal usage is as follows:
7511  *
7512  *      main(argc, argv)
7513  *      int             argc;
7514  *      char            *argv[];
7515  *      {
7516  *              getredirection(&argc, &argv);
7517  *      }
7518  */
7519 {
7520     int                 argc = *ac;     /* Argument Count         */
7521     char                **argv = *av;   /* Argument Vector        */
7522     char                *ap;            /* Argument pointer       */
7523     int                 j;              /* argv[] index           */
7524     int                 item_count = 0; /* Count of Items in List */
7525     struct list_item    *list_head = 0; /* First Item in List       */
7526     struct list_item    *list_tail;     /* Last Item in List        */
7527     char                *in = NULL;     /* Input File Name          */
7528     char                *out = NULL;    /* Output File Name         */
7529     char                *outmode = "w"; /* Mode to Open Output File */
7530     char                *err = NULL;    /* Error File Name          */
7531     char                *errmode = "w"; /* Mode to Open Error File  */
7532     int                 cmargc = 0;     /* Piped Command Arg Count  */
7533     char                **cmargv = NULL;/* Piped Command Arg Vector */
7534
7535     /*
7536      * First handle the case where the last thing on the line ends with
7537      * a '&'.  This indicates the desire for the command to be run in a
7538      * subprocess, so we satisfy that desire.
7539      */
7540     ap = argv[argc-1];
7541     if (0 == strcmp("&", ap))
7542        exit(background_process(aTHX_ --argc, argv));
7543     if (*ap && '&' == ap[strlen(ap)-1])
7544         {
7545         ap[strlen(ap)-1] = '\0';
7546        exit(background_process(aTHX_ argc, argv));
7547         }
7548     /*
7549      * Now we handle the general redirection cases that involve '>', '>>',
7550      * '<', and pipes '|'.
7551      */
7552     for (j = 0; j < argc; ++j)
7553         {
7554         if (0 == strcmp("<", argv[j]))
7555             {
7556             if (j+1 >= argc)
7557                 {
7558                 fprintf(stderr,"No input file after < on command line");
7559                 exit(LIB$_WRONUMARG);
7560                 }
7561             in = argv[++j];
7562             continue;
7563             }
7564         if ('<' == *(ap = argv[j]))
7565             {
7566             in = 1 + ap;
7567             continue;
7568             }
7569         if (0 == strcmp(">", ap))
7570             {
7571             if (j+1 >= argc)
7572                 {
7573                 fprintf(stderr,"No output file after > on command line");
7574                 exit(LIB$_WRONUMARG);
7575                 }
7576             out = argv[++j];
7577             continue;
7578             }
7579         if ('>' == *ap)
7580             {
7581             if ('>' == ap[1])
7582                 {
7583                 outmode = "a";
7584                 if ('\0' == ap[2])
7585                     out = argv[++j];
7586                 else
7587                     out = 2 + ap;
7588                 }
7589             else
7590                 out = 1 + ap;
7591             if (j >= argc)
7592                 {
7593                 fprintf(stderr,"No output file after > or >> on command line");
7594                 exit(LIB$_WRONUMARG);
7595                 }
7596             continue;
7597             }
7598         if (('2' == *ap) && ('>' == ap[1]))
7599             {
7600             if ('>' == ap[2])
7601                 {
7602                 errmode = "a";
7603                 if ('\0' == ap[3])
7604                     err = argv[++j];
7605                 else
7606                     err = 3 + ap;
7607                 }
7608             else
7609                 if ('\0' == ap[2])
7610                     err = argv[++j];
7611                 else
7612                     err = 2 + ap;
7613             if (j >= argc)
7614                 {
7615                 fprintf(stderr,"No output file after 2> or 2>> on command line");
7616                 exit(LIB$_WRONUMARG);
7617                 }
7618             continue;
7619             }
7620         if (0 == strcmp("|", argv[j]))
7621             {
7622             if (j+1 >= argc)
7623                 {
7624                 fprintf(stderr,"No command into which to pipe on command line");
7625                 exit(LIB$_WRONUMARG);
7626                 }
7627             cmargc = argc-(j+1);
7628             cmargv = &argv[j+1];
7629             argc = j;
7630             continue;
7631             }
7632         if ('|' == *(ap = argv[j]))
7633             {
7634             ++argv[j];
7635             cmargc = argc-j;
7636             cmargv = &argv[j];
7637             argc = j;
7638             continue;
7639             }
7640         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7641         }
7642     /*
7643      * Allocate and fill in the new argument vector, Some Unix's terminate
7644      * the list with an extra null pointer.
7645      */
7646     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7647     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7648     *av = argv;
7649     for (j = 0; j < item_count; ++j, list_head = list_head->next)
7650         argv[j] = list_head->value;
7651     *ac = item_count;
7652     if (cmargv != NULL)
7653         {
7654         if (out != NULL)
7655             {
7656             fprintf(stderr,"'|' and '>' may not both be specified on command line");
7657             exit(LIB$_INVARGORD);
7658             }
7659         pipe_and_fork(aTHX_ cmargv);
7660         }
7661
7662     /* Check for input from a pipe (mailbox) */
7663
7664     if (in == NULL && 1 == isapipe(0))
7665         {
7666         char mbxname[L_tmpnam];
7667         long int bufsize;
7668         long int dvi_item = DVI$_DEVBUFSIZ;
7669         $DESCRIPTOR(mbxnam, "");
7670         $DESCRIPTOR(mbxdevnam, "");
7671
7672         /* Input from a pipe, reopen it in binary mode to disable       */
7673         /* carriage control processing.                                 */
7674
7675         fgetname(stdin, mbxname);
7676         mbxnam.dsc$a_pointer = mbxname;
7677         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7678         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7679         mbxdevnam.dsc$a_pointer = mbxname;
7680         mbxdevnam.dsc$w_length = sizeof(mbxname);
7681         dvi_item = DVI$_DEVNAM;
7682         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7683         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7684         set_errno(0);
7685         set_vaxc_errno(1);
7686         freopen(mbxname, "rb", stdin);
7687         if (errno != 0)
7688             {
7689             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7690             exit(vaxc$errno);
7691             }
7692         }
7693     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7694         {
7695         fprintf(stderr,"Can't open input file %s as stdin",in);
7696         exit(vaxc$errno);
7697         }
7698     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7699         {
7700         fprintf(stderr,"Can't open output file %s as stdout",out);
7701         exit(vaxc$errno);
7702         }
7703         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7704
7705     if (err != NULL) {
7706         if (strcmp(err,"&1") == 0) {
7707             dup2(fileno(stdout), fileno(stderr));
7708             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7709         } else {
7710         FILE *tmperr;
7711         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7712             {
7713             fprintf(stderr,"Can't open error file %s as stderr",err);
7714             exit(vaxc$errno);
7715             }
7716             fclose(tmperr);
7717            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7718                 {
7719                 exit(vaxc$errno);
7720                 }
7721             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7722         }
7723         }
7724 #ifdef ARGPROC_DEBUG
7725     PerlIO_printf(Perl_debug_log, "Arglist:\n");
7726     for (j = 0; j < *ac;  ++j)
7727         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7728 #endif
7729    /* Clear errors we may have hit expanding wildcards, so they don't
7730       show up in Perl's $! later */
7731    set_errno(0); set_vaxc_errno(1);
7732 }  /* end of getredirection() */
7733 /*}}}*/
7734
7735 static void add_item(struct list_item **head,
7736                      struct list_item **tail,
7737                      char *value,
7738                      int *count)
7739 {
7740     if (*head == 0)
7741         {
7742         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7743         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7744         *tail = *head;
7745         }
7746     else {
7747         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7748         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7749         *tail = (*tail)->next;
7750         }
7751     (*tail)->value = value;
7752     ++(*count);
7753 }
7754
7755 static void mp_expand_wild_cards(pTHX_ char *item,
7756                               struct list_item **head,
7757                               struct list_item **tail,
7758                               int *count)
7759 {
7760 int expcount = 0;
7761 unsigned long int context = 0;
7762 int isunix = 0;
7763 int item_len = 0;
7764 char *had_version;
7765 char *had_device;
7766 int had_directory;
7767 char *devdir,*cp;
7768 char *vmsspec;
7769 $DESCRIPTOR(filespec, "");
7770 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
7771 $DESCRIPTOR(resultspec, "");
7772 unsigned long int lff_flags = 0;
7773 int sts;
7774 int rms_sts;
7775
7776 #ifdef VMS_LONGNAME_SUPPORT
7777     lff_flags = LIB$M_FIL_LONG_NAMES;
7778 #endif
7779
7780     for (cp = item; *cp; cp++) {
7781         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
7782         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
7783     }
7784     if (!*cp || isspace(*cp))
7785         {
7786         add_item(head, tail, item, count);
7787         return;
7788         }
7789     else
7790         {
7791      /* "double quoted" wild card expressions pass as is */
7792      /* From DCL that means using e.g.:                  */
7793      /* perl program """perl.*"""                        */
7794      item_len = strlen(item);
7795      if ( '"' == *item && '"' == item[item_len-1] )
7796        {
7797        item++;
7798        item[item_len-2] = '\0';
7799        add_item(head, tail, item, count);
7800        return;
7801        }
7802      }
7803     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
7804     resultspec.dsc$b_class = DSC$K_CLASS_D;
7805     resultspec.dsc$a_pointer = NULL;
7806     vmsspec = PerlMem_malloc(VMS_MAXRSS);
7807     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7808     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
7809       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
7810     if (!isunix || !filespec.dsc$a_pointer)
7811       filespec.dsc$a_pointer = item;
7812     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
7813     /*
7814      * Only return version specs, if the caller specified a version
7815      */
7816     had_version = strchr(item, ';');
7817     /*
7818      * Only return device and directory specs, if the caller specifed either.
7819      */
7820     had_device = strchr(item, ':');
7821     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
7822
7823     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
7824                                  (&filespec, &resultspec, &context,
7825                                   &defaultspec, 0, &rms_sts, &lff_flags)))
7826         {
7827         char *string;
7828         char *c;
7829
7830         string = PerlMem_malloc(resultspec.dsc$w_length+1);
7831         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7832         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
7833         string[resultspec.dsc$w_length] = '\0';
7834         if (NULL == had_version)
7835             *(strrchr(string, ';')) = '\0';
7836         if ((!had_directory) && (had_device == NULL))
7837             {
7838             if (NULL == (devdir = strrchr(string, ']')))
7839                 devdir = strrchr(string, '>');
7840             strcpy(string, devdir + 1);
7841             }
7842         /*
7843          * Be consistent with what the C RTL has already done to the rest of
7844          * the argv items and lowercase all of these names.
7845          */
7846         if (!decc_efs_case_preserve) {
7847             for (c = string; *c; ++c)
7848             if (isupper(*c))
7849                 *c = tolower(*c);
7850         }
7851         if (isunix) trim_unixpath(string,item,1);
7852         add_item(head, tail, string, count);
7853         ++expcount;
7854     }
7855     PerlMem_free(vmsspec);
7856     if (sts != RMS$_NMF)
7857         {
7858         set_vaxc_errno(sts);
7859         switch (sts)
7860             {
7861             case RMS$_FNF: case RMS$_DNF:
7862                 set_errno(ENOENT); break;
7863             case RMS$_DIR:
7864                 set_errno(ENOTDIR); break;
7865             case RMS$_DEV:
7866                 set_errno(ENODEV); break;
7867             case RMS$_FNM: case RMS$_SYN:
7868                 set_errno(EINVAL); break;
7869             case RMS$_PRV:
7870                 set_errno(EACCES); break;
7871             default:
7872                 _ckvmssts_noperl(sts);
7873             }
7874         }
7875     if (expcount == 0)
7876         add_item(head, tail, item, count);
7877     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
7878     _ckvmssts_noperl(lib$find_file_end(&context));
7879 }
7880
7881 static int child_st[2];/* Event Flag set when child process completes   */
7882
7883 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
7884
7885 static unsigned long int exit_handler(int *status)
7886 {
7887 short iosb[4];
7888
7889     if (0 == child_st[0])
7890         {
7891 #ifdef ARGPROC_DEBUG
7892         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
7893 #endif
7894         fflush(stdout);     /* Have to flush pipe for binary data to    */
7895                             /* terminate properly -- <tp@mccall.com>    */
7896         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
7897         sys$dassgn(child_chan);
7898         fclose(stdout);
7899         sys$synch(0, child_st);
7900         }
7901     return(1);
7902 }
7903
7904 static void sig_child(int chan)
7905 {
7906 #ifdef ARGPROC_DEBUG
7907     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
7908 #endif
7909     if (child_st[0] == 0)
7910         child_st[0] = 1;
7911 }
7912
7913 static struct exit_control_block exit_block =
7914     {
7915     0,
7916     exit_handler,
7917     1,
7918     &exit_block.exit_status,
7919     0
7920     };
7921
7922 static void
7923 pipe_and_fork(pTHX_ char **cmargv)
7924 {
7925     PerlIO *fp;
7926     struct dsc$descriptor_s *vmscmd;
7927     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
7928     int sts, j, l, ismcr, quote, tquote = 0;
7929
7930     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
7931     vms_execfree(vmscmd);
7932
7933     j = l = 0;
7934     p = subcmd;
7935     q = cmargv[0];
7936     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
7937               && toupper(*(q+2)) == 'R' && !*(q+3);
7938
7939     while (q && l < MAX_DCL_LINE_LENGTH) {
7940         if (!*q) {
7941             if (j > 0 && quote) {
7942                 *p++ = '"';
7943                 l++;
7944             }
7945             q = cmargv[++j];
7946             if (q) {
7947                 if (ismcr && j > 1) quote = 1;
7948                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
7949                 *p++ = ' ';
7950                 l++;
7951                 if (quote || tquote) {
7952                     *p++ = '"';
7953                     l++;
7954                 }
7955             }
7956         } else {
7957             if ((quote||tquote) && *q == '"') {
7958                 *p++ = '"';
7959                 l++;
7960             }
7961             *p++ = *q++;
7962             l++;
7963         }
7964     }
7965     *p = '\0';
7966
7967     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7968     if (fp == Nullfp) {
7969         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7970     }
7971 }
7972
7973 static int background_process(pTHX_ int argc, char **argv)
7974 {
7975 char command[MAX_DCL_SYMBOL + 1] = "$";
7976 $DESCRIPTOR(value, "");
7977 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7978 static $DESCRIPTOR(null, "NLA0:");
7979 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7980 char pidstring[80];
7981 $DESCRIPTOR(pidstr, "");
7982 int pid;
7983 unsigned long int flags = 17, one = 1, retsts;
7984 int len;
7985
7986     strcat(command, argv[0]);
7987     len = strlen(command);
7988     while (--argc && (len < MAX_DCL_SYMBOL))
7989         {
7990         strcat(command, " \"");
7991         strcat(command, *(++argv));
7992         strcat(command, "\"");
7993         len = strlen(command);
7994         }
7995     value.dsc$a_pointer = command;
7996     value.dsc$w_length = strlen(value.dsc$a_pointer);
7997     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7998     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7999     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8000         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8001     }
8002     else {
8003         _ckvmssts_noperl(retsts);
8004     }
8005 #ifdef ARGPROC_DEBUG
8006     PerlIO_printf(Perl_debug_log, "%s\n", command);
8007 #endif
8008     sprintf(pidstring, "%08X", pid);
8009     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8010     pidstr.dsc$a_pointer = pidstring;
8011     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8012     lib$set_symbol(&pidsymbol, &pidstr);
8013     return(SS$_NORMAL);
8014 }
8015 /*}}}*/
8016 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8017
8018
8019 /* OS-specific initialization at image activation (not thread startup) */
8020 /* Older VAXC header files lack these constants */
8021 #ifndef JPI$_RIGHTS_SIZE
8022 #  define JPI$_RIGHTS_SIZE 817
8023 #endif
8024 #ifndef KGB$M_SUBSYSTEM
8025 #  define KGB$M_SUBSYSTEM 0x8
8026 #endif
8027
8028 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8029
8030 /*{{{void vms_image_init(int *, char ***)*/
8031 void
8032 vms_image_init(int *argcp, char ***argvp)
8033 {
8034   char eqv[LNM$C_NAMLENGTH+1] = "";
8035   unsigned int len, tabct = 8, tabidx = 0;
8036   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8037   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8038   unsigned short int dummy, rlen;
8039   struct dsc$descriptor_s **tabvec;
8040 #if defined(PERL_IMPLICIT_CONTEXT)
8041   pTHX = NULL;
8042 #endif
8043   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8044                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8045                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8046                                  {          0,                0,    0,      0} };
8047
8048 #ifdef KILL_BY_SIGPRC
8049     Perl_csighandler_init();
8050 #endif
8051
8052   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8053   _ckvmssts_noperl(iosb[0]);
8054   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8055     if (iprv[i]) {           /* Running image installed with privs? */
8056       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8057       will_taint = TRUE;
8058       break;
8059     }
8060   }
8061   /* Rights identifiers might trigger tainting as well. */
8062   if (!will_taint && (rlen || rsz)) {
8063     while (rlen < rsz) {
8064       /* We didn't get all the identifiers on the first pass.  Allocate a
8065        * buffer much larger than $GETJPI wants (rsz is size in bytes that
8066        * were needed to hold all identifiers at time of last call; we'll
8067        * allocate that many unsigned long ints), and go back and get 'em.
8068        * If it gave us less than it wanted to despite ample buffer space,
8069        * something's broken.  Is your system missing a system identifier?
8070        */
8071       if (rsz <= jpilist[1].buflen) {
8072          /* Perl_croak accvios when used this early in startup. */
8073          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8074                          rsz, (unsigned long) jpilist[1].buflen,
8075                          "Check your rights database for corruption.\n");
8076          exit(SS$_ABORT);
8077       }
8078       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8079       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8080       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8081       jpilist[1].buflen = rsz * sizeof(unsigned long int);
8082       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8083       _ckvmssts_noperl(iosb[0]);
8084     }
8085     mask = jpilist[1].bufadr;
8086     /* Check attribute flags for each identifier (2nd longword); protected
8087      * subsystem identifiers trigger tainting.
8088      */
8089     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8090       if (mask[i] & KGB$M_SUBSYSTEM) {
8091         will_taint = TRUE;
8092         break;
8093       }
8094     }
8095     if (mask != rlst) PerlMem_free(mask);
8096   }
8097
8098   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8099    * logical, some versions of the CRTL will add a phanthom /000000/
8100    * directory.  This needs to be removed.
8101    */
8102   if (decc_filename_unix_report) {
8103   char * zeros;
8104   int ulen;
8105     ulen = strlen(argvp[0][0]);
8106     if (ulen > 7) {
8107       zeros = strstr(argvp[0][0], "/000000/");
8108       if (zeros != NULL) {
8109         int mlen;
8110         mlen = ulen - (zeros - argvp[0][0]) - 7;
8111         memmove(zeros, &zeros[7], mlen);
8112         ulen = ulen - 7;
8113         argvp[0][0][ulen] = '\0';
8114       }
8115     }
8116     /* It also may have a trailing dot that needs to be removed otherwise
8117      * it will be converted to VMS mode incorrectly.
8118      */
8119     ulen--;
8120     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8121       argvp[0][0][ulen] = '\0';
8122   }
8123
8124   /* We need to use this hack to tell Perl it should run with tainting,
8125    * since its tainting flag may be part of the PL_curinterp struct, which
8126    * hasn't been allocated when vms_image_init() is called.
8127    */
8128   if (will_taint) {
8129     char **newargv, **oldargv;
8130     oldargv = *argvp;
8131     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8132     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8133     newargv[0] = oldargv[0];
8134     newargv[1] = PerlMem_malloc(3 * sizeof(char));
8135     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8136     strcpy(newargv[1], "-T");
8137     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8138     (*argcp)++;
8139     newargv[*argcp] = NULL;
8140     /* We orphan the old argv, since we don't know where it's come from,
8141      * so we don't know how to free it.
8142      */
8143     *argvp = newargv;
8144   }
8145   else {  /* Did user explicitly request tainting? */
8146     int i;
8147     char *cp, **av = *argvp;
8148     for (i = 1; i < *argcp; i++) {
8149       if (*av[i] != '-') break;
8150       for (cp = av[i]+1; *cp; cp++) {
8151         if (*cp == 'T') { will_taint = 1; break; }
8152         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8153                   strchr("DFIiMmx",*cp)) break;
8154       }
8155       if (will_taint) break;
8156     }
8157   }
8158
8159   for (tabidx = 0;
8160        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8161        tabidx++) {
8162     if (!tabidx) {
8163       tabvec = (struct dsc$descriptor_s **)
8164             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8165       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8166     }
8167     else if (tabidx >= tabct) {
8168       tabct += 8;
8169       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8170       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8171     }
8172     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8173     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8174     tabvec[tabidx]->dsc$w_length  = 0;
8175     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
8176     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
8177     tabvec[tabidx]->dsc$a_pointer = NULL;
8178     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8179   }
8180   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8181
8182   getredirection(argcp,argvp);
8183 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8184   {
8185 # include <reentrancy.h>
8186   decc$set_reentrancy(C$C_MULTITHREAD);
8187   }
8188 #endif
8189   return;
8190 }
8191 /*}}}*/
8192
8193
8194 /* trim_unixpath()
8195  * Trim Unix-style prefix off filespec, so it looks like what a shell
8196  * glob expansion would return (i.e. from specified prefix on, not
8197  * full path).  Note that returned filespec is Unix-style, regardless
8198  * of whether input filespec was VMS-style or Unix-style.
8199  *
8200  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8201  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
8202  * vector of options; at present, only bit 0 is used, and if set tells
8203  * trim unixpath to try the current default directory as a prefix when
8204  * presented with a possibly ambiguous ... wildcard.
8205  *
8206  * Returns !=0 on success, with trimmed filespec replacing contents of
8207  * fspec, and 0 on failure, with contents of fpsec unchanged.
8208  */
8209 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8210 int
8211 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8212 {
8213   char *unixified, *unixwild,
8214        *template, *base, *end, *cp1, *cp2;
8215   register int tmplen, reslen = 0, dirs = 0;
8216
8217   unixwild = PerlMem_malloc(VMS_MAXRSS);
8218   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8219   if (!wildspec || !fspec) return 0;
8220   template = unixwild;
8221   if (strpbrk(wildspec,"]>:") != NULL) {
8222     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8223         PerlMem_free(unixwild);
8224         return 0;
8225     }
8226   }
8227   else {
8228     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8229     unixwild[VMS_MAXRSS-1] = 0;
8230   }
8231   unixified = PerlMem_malloc(VMS_MAXRSS);
8232   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8233   if (strpbrk(fspec,"]>:") != NULL) {
8234     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8235         PerlMem_free(unixwild);
8236         PerlMem_free(unixified);
8237         return 0;
8238     }
8239     else base = unixified;
8240     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8241      * check to see that final result fits into (isn't longer than) fspec */
8242     reslen = strlen(fspec);
8243   }
8244   else base = fspec;
8245
8246   /* No prefix or absolute path on wildcard, so nothing to remove */
8247   if (!*template || *template == '/') {
8248     PerlMem_free(unixwild);
8249     if (base == fspec) {
8250         PerlMem_free(unixified);
8251         return 1;
8252     }
8253     tmplen = strlen(unixified);
8254     if (tmplen > reslen) {
8255         PerlMem_free(unixified);
8256         return 0;  /* not enough space */
8257     }
8258     /* Copy unixified resultant, including trailing NUL */
8259     memmove(fspec,unixified,tmplen+1);
8260     PerlMem_free(unixified);
8261     return 1;
8262   }
8263
8264   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
8265   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8266     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8267     for (cp1 = end ;cp1 >= base; cp1--)
8268       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8269         { cp1++; break; }
8270     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8271     PerlMem_free(unixified);
8272     PerlMem_free(unixwild);
8273     return 1;
8274   }
8275   else {
8276     char *tpl, *lcres;
8277     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8278     int ells = 1, totells, segdirs, match;
8279     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8280                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8281
8282     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8283     totells = ells;
8284     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8285     tpl = PerlMem_malloc(VMS_MAXRSS);
8286     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8287     if (ellipsis == template && opts & 1) {
8288       /* Template begins with an ellipsis.  Since we can't tell how many
8289        * directory names at the front of the resultant to keep for an
8290        * arbitrary starting point, we arbitrarily choose the current
8291        * default directory as a starting point.  If it's there as a prefix,
8292        * clip it off.  If not, fall through and act as if the leading
8293        * ellipsis weren't there (i.e. return shortest possible path that
8294        * could match template).
8295        */
8296       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8297           PerlMem_free(tpl);
8298           PerlMem_free(unixified);
8299           PerlMem_free(unixwild);
8300           return 0;
8301       }
8302       if (!decc_efs_case_preserve) {
8303         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8304           if (_tolower(*cp1) != _tolower(*cp2)) break;
8305       }
8306       segdirs = dirs - totells;  /* Min # of dirs we must have left */
8307       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8308       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8309         memmove(fspec,cp2+1,end - cp2);
8310         PerlMem_free(tpl);
8311         PerlMem_free(unixified);
8312         PerlMem_free(unixwild);
8313         return 1;
8314       }
8315     }
8316     /* First off, back up over constant elements at end of path */
8317     if (dirs) {
8318       for (front = end ; front >= base; front--)
8319          if (*front == '/' && !dirs--) { front++; break; }
8320     }
8321     lcres = PerlMem_malloc(VMS_MAXRSS);
8322     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8323     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8324          cp1++,cp2++) {
8325             if (!decc_efs_case_preserve) {
8326                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
8327             }
8328             else {
8329                 *cp2 = *cp1;
8330             }
8331     }
8332     if (cp1 != '\0') {
8333         PerlMem_free(tpl);
8334         PerlMem_free(unixified);
8335         PerlMem_free(unixwild);
8336         PerlMem_free(lcres);
8337         return 0;  /* Path too long. */
8338     }
8339     lcend = cp2;
8340     *cp2 = '\0';  /* Pick up with memcpy later */
8341     lcfront = lcres + (front - base);
8342     /* Now skip over each ellipsis and try to match the path in front of it. */
8343     while (ells--) {
8344       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8345         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
8346             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
8347       if (cp1 < template) break; /* template started with an ellipsis */
8348       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8349         ellipsis = cp1; continue;
8350       }
8351       wilddsc.dsc$a_pointer = tpl;
8352       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8353       nextell = cp1;
8354       for (segdirs = 0, cp2 = tpl;
8355            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8356            cp1++, cp2++) {
8357          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8358          else {
8359             if (!decc_efs_case_preserve) {
8360               *cp2 = _tolower(*cp1);  /* else lowercase for match */
8361             }
8362             else {
8363               *cp2 = *cp1;  /* else preserve case for match */
8364             }
8365          }
8366          if (*cp2 == '/') segdirs++;
8367       }
8368       if (cp1 != ellipsis - 1) {
8369           PerlMem_free(tpl);
8370           PerlMem_free(unixified);
8371           PerlMem_free(unixwild);
8372           PerlMem_free(lcres);
8373           return 0; /* Path too long */
8374       }
8375       /* Back up at least as many dirs as in template before matching */
8376       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8377         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8378       for (match = 0; cp1 > lcres;) {
8379         resdsc.dsc$a_pointer = cp1;
8380         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8381           match++;
8382           if (match == 1) lcfront = cp1;
8383         }
8384         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8385       }
8386       if (!match) {
8387         PerlMem_free(tpl);
8388         PerlMem_free(unixified);
8389         PerlMem_free(unixwild);
8390         PerlMem_free(lcres);
8391         return 0;  /* Can't find prefix ??? */
8392       }
8393       if (match > 1 && opts & 1) {
8394         /* This ... wildcard could cover more than one set of dirs (i.e.
8395          * a set of similar dir names is repeated).  If the template
8396          * contains more than 1 ..., upstream elements could resolve the
8397          * ambiguity, but it's not worth a full backtracking setup here.
8398          * As a quick heuristic, clip off the current default directory
8399          * if it's present to find the trimmed spec, else use the
8400          * shortest string that this ... could cover.
8401          */
8402         char def[NAM$C_MAXRSS+1], *st;
8403
8404         if (getcwd(def, sizeof def,0) == NULL) {
8405             Safefree(unixified);
8406             Safefree(unixwild);
8407             Safefree(lcres);
8408             Safefree(tpl);
8409             return 0;
8410         }
8411         if (!decc_efs_case_preserve) {
8412           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8413             if (_tolower(*cp1) != _tolower(*cp2)) break;
8414         }
8415         segdirs = dirs - totells;  /* Min # of dirs we must have left */
8416         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8417         if (*cp1 == '\0' && *cp2 == '/') {
8418           memmove(fspec,cp2+1,end - cp2);
8419           PerlMem_free(tpl);
8420           PerlMem_free(unixified);
8421           PerlMem_free(unixwild);
8422           PerlMem_free(lcres);
8423           return 1;
8424         }
8425         /* Nope -- stick with lcfront from above and keep going. */
8426       }
8427     }
8428     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8429     PerlMem_free(tpl);
8430     PerlMem_free(unixified);
8431     PerlMem_free(unixwild);
8432     PerlMem_free(lcres);
8433     return 1;
8434     ellipsis = nextell;
8435   }
8436
8437 }  /* end of trim_unixpath() */
8438 /*}}}*/
8439
8440
8441 /*
8442  *  VMS readdir() routines.
8443  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8444  *
8445  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
8446  *  Minor modifications to original routines.
8447  */
8448
8449 /* readdir may have been redefined by reentr.h, so make sure we get
8450  * the local version for what we do here.
8451  */
8452 #ifdef readdir
8453 # undef readdir
8454 #endif
8455 #if !defined(PERL_IMPLICIT_CONTEXT)
8456 # define readdir Perl_readdir
8457 #else
8458 # define readdir(a) Perl_readdir(aTHX_ a)
8459 #endif
8460
8461     /* Number of elements in vms_versions array */
8462 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
8463
8464 /*
8465  *  Open a directory, return a handle for later use.
8466  */
8467 /*{{{ DIR *opendir(char*name) */
8468 DIR *
8469 Perl_opendir(pTHX_ const char *name)
8470 {
8471     DIR *dd;
8472     char *dir;
8473     Stat_t sb;
8474     int unix_flag;
8475
8476     unix_flag = 0;
8477     if (decc_efs_charset) {
8478         unix_flag = is_unix_filespec(name);
8479     }
8480
8481     Newx(dir, VMS_MAXRSS, char);
8482     if (do_tovmspath(name,dir,0,NULL) == NULL) {
8483       Safefree(dir);
8484       return NULL;
8485     }
8486     /* Check access before stat; otherwise stat does not
8487      * accurately report whether it's a directory.
8488      */
8489     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8490       /* cando_by_name has already set errno */
8491       Safefree(dir);
8492       return NULL;
8493     }
8494     if (flex_stat(dir,&sb) == -1) return NULL;
8495     if (!S_ISDIR(sb.st_mode)) {
8496       Safefree(dir);
8497       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
8498       return NULL;
8499     }
8500     /* Get memory for the handle, and the pattern. */
8501     Newx(dd,1,DIR);
8502     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8503
8504     /* Fill in the fields; mainly playing with the descriptor. */
8505     sprintf(dd->pattern, "%s*.*",dir);
8506     Safefree(dir);
8507     dd->context = 0;
8508     dd->count = 0;
8509     dd->flags = 0;
8510     if (unix_flag)
8511         dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8512     dd->pat.dsc$a_pointer = dd->pattern;
8513     dd->pat.dsc$w_length = strlen(dd->pattern);
8514     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8515     dd->pat.dsc$b_class = DSC$K_CLASS_S;
8516 #if defined(USE_ITHREADS)
8517     Newx(dd->mutex,1,perl_mutex);
8518     MUTEX_INIT( (perl_mutex *) dd->mutex );
8519 #else
8520     dd->mutex = NULL;
8521 #endif
8522
8523     return dd;
8524 }  /* end of opendir() */
8525 /*}}}*/
8526
8527 /*
8528  *  Set the flag to indicate we want versions or not.
8529  */
8530 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8531 void
8532 vmsreaddirversions(DIR *dd, int flag)
8533 {
8534     if (flag)
8535         dd->flags |= PERL_VMSDIR_M_VERSIONS;
8536     else
8537         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8538 }
8539 /*}}}*/
8540
8541 /*
8542  *  Free up an opened directory.
8543  */
8544 /*{{{ void closedir(DIR *dd)*/
8545 void
8546 Perl_closedir(DIR *dd)
8547 {
8548     int sts;
8549
8550     sts = lib$find_file_end(&dd->context);
8551     Safefree(dd->pattern);
8552 #if defined(USE_ITHREADS)
8553     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8554     Safefree(dd->mutex);
8555 #endif
8556     Safefree(dd);
8557 }
8558 /*}}}*/
8559
8560 /*
8561  *  Collect all the version numbers for the current file.
8562  */
8563 static void
8564 collectversions(pTHX_ DIR *dd)
8565 {
8566     struct dsc$descriptor_s     pat;
8567     struct dsc$descriptor_s     res;
8568     struct dirent *e;
8569     char *p, *text, *buff;
8570     int i;
8571     unsigned long context, tmpsts;
8572
8573     /* Convenient shorthand. */
8574     e = &dd->entry;
8575
8576     /* Add the version wildcard, ignoring the "*.*" put on before */
8577     i = strlen(dd->pattern);
8578     Newx(text,i + e->d_namlen + 3,char);
8579     strcpy(text, dd->pattern);
8580     sprintf(&text[i - 3], "%s;*", e->d_name);
8581
8582     /* Set up the pattern descriptor. */
8583     pat.dsc$a_pointer = text;
8584     pat.dsc$w_length = i + e->d_namlen - 1;
8585     pat.dsc$b_dtype = DSC$K_DTYPE_T;
8586     pat.dsc$b_class = DSC$K_CLASS_S;
8587
8588     /* Set up result descriptor. */
8589     Newx(buff, VMS_MAXRSS, char);
8590     res.dsc$a_pointer = buff;
8591     res.dsc$w_length = VMS_MAXRSS - 1;
8592     res.dsc$b_dtype = DSC$K_DTYPE_T;
8593     res.dsc$b_class = DSC$K_CLASS_S;
8594
8595     /* Read files, collecting versions. */
8596     for (context = 0, e->vms_verscount = 0;
8597          e->vms_verscount < VERSIZE(e);
8598          e->vms_verscount++) {
8599         unsigned long rsts;
8600         unsigned long flags = 0;
8601
8602 #ifdef VMS_LONGNAME_SUPPORT
8603         flags = LIB$M_FIL_LONG_NAMES;
8604 #endif
8605         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8606         if (tmpsts == RMS$_NMF || context == 0) break;
8607         _ckvmssts(tmpsts);
8608         buff[VMS_MAXRSS - 1] = '\0';
8609         if ((p = strchr(buff, ';')))
8610             e->vms_versions[e->vms_verscount] = atoi(p + 1);
8611         else
8612             e->vms_versions[e->vms_verscount] = -1;
8613     }
8614
8615     _ckvmssts(lib$find_file_end(&context));
8616     Safefree(text);
8617     Safefree(buff);
8618
8619 }  /* end of collectversions() */
8620
8621 /*
8622  *  Read the next entry from the directory.
8623  */
8624 /*{{{ struct dirent *readdir(DIR *dd)*/
8625 struct dirent *
8626 Perl_readdir(pTHX_ DIR *dd)
8627 {
8628     struct dsc$descriptor_s     res;
8629     char *p, *buff;
8630     unsigned long int tmpsts;
8631     unsigned long rsts;
8632     unsigned long flags = 0;
8633     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8634     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8635
8636     /* Set up result descriptor, and get next file. */
8637     Newx(buff, VMS_MAXRSS, char);
8638     res.dsc$a_pointer = buff;
8639     res.dsc$w_length = VMS_MAXRSS - 1;
8640     res.dsc$b_dtype = DSC$K_DTYPE_T;
8641     res.dsc$b_class = DSC$K_CLASS_S;
8642
8643 #ifdef VMS_LONGNAME_SUPPORT
8644     flags = LIB$M_FIL_LONG_NAMES;
8645 #endif
8646
8647     tmpsts = lib$find_file
8648         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8649     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
8650     if (!(tmpsts & 1)) {
8651       set_vaxc_errno(tmpsts);
8652       switch (tmpsts) {
8653         case RMS$_PRV:
8654           set_errno(EACCES); break;
8655         case RMS$_DEV:
8656           set_errno(ENODEV); break;
8657         case RMS$_DIR:
8658           set_errno(ENOTDIR); break;
8659         case RMS$_FNF: case RMS$_DNF:
8660           set_errno(ENOENT); break;
8661         default:
8662           set_errno(EVMSERR);
8663       }
8664       Safefree(buff);
8665       return NULL;
8666     }
8667     dd->count++;
8668     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8669     if (!decc_efs_case_preserve) {
8670       buff[VMS_MAXRSS - 1] = '\0';
8671       for (p = buff; *p; p++) *p = _tolower(*p);
8672     }
8673     else {
8674       /* we don't want to force to lowercase, just null terminate */
8675       buff[res.dsc$w_length] = '\0';
8676     }
8677     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
8678     *p = '\0';
8679
8680     /* Skip any directory component and just copy the name. */
8681     sts = vms_split_path
8682        (buff,
8683         &v_spec,
8684         &v_len,
8685         &r_spec,
8686         &r_len,
8687         &d_spec,
8688         &d_len,
8689         &n_spec,
8690         &n_len,
8691         &e_spec,
8692         &e_len,
8693         &vs_spec,
8694         &vs_len);
8695
8696     /* Drop NULL extensions on UNIX file specification */
8697     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8698         (e_len == 1) && decc_readdir_dropdotnotype)) {
8699         e_len = 0;
8700         e_spec[0] = '\0';
8701     }
8702
8703     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8704     dd->entry.d_name[n_len + e_len] = '\0';
8705     dd->entry.d_namlen = strlen(dd->entry.d_name);
8706
8707     /* Convert the filename to UNIX format if needed */
8708     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8709
8710         /* Translate the encoded characters. */
8711         /* Fixme: unicode handling could result in embedded 0 characters */
8712         if (strchr(dd->entry.d_name, '^') != NULL) {
8713             char new_name[256];
8714             char * q;
8715             int cnt;
8716             p = dd->entry.d_name;
8717             q = new_name;
8718             while (*p != 0) {
8719                 int x, y;
8720                 x = copy_expand_vms_filename_escape(q, p, &y);
8721                 p += x;
8722                 q += y;
8723                 /* fix-me */
8724                 /* if y > 1, then this is a wide file specification */
8725                 /* Wide file specifications need to be passed in Perl */
8726                 /* counted strings apparently with a unicode flag */
8727             }
8728             *q = 0;
8729             strcpy(dd->entry.d_name, new_name);
8730         }
8731     }
8732
8733     dd->entry.vms_verscount = 0;
8734     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8735     Safefree(buff);
8736     return &dd->entry;
8737
8738 }  /* end of readdir() */
8739 /*}}}*/
8740
8741 /*
8742  *  Read the next entry from the directory -- thread-safe version.
8743  */
8744 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
8745 int
8746 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
8747 {
8748     int retval;
8749
8750     MUTEX_LOCK( (perl_mutex *) dd->mutex );
8751
8752     entry = readdir(dd);
8753     *result = entry;
8754     retval = ( *result == NULL ? errno : 0 );
8755
8756     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
8757
8758     return retval;
8759
8760 }  /* end of readdir_r() */
8761 /*}}}*/
8762
8763 /*
8764  *  Return something that can be used in a seekdir later.
8765  */
8766 /*{{{ long telldir(DIR *dd)*/
8767 long
8768 Perl_telldir(DIR *dd)
8769 {
8770     return dd->count;
8771 }
8772 /*}}}*/
8773
8774 /*
8775  *  Return to a spot where we used to be.  Brute force.
8776  */
8777 /*{{{ void seekdir(DIR *dd,long count)*/
8778 void
8779 Perl_seekdir(pTHX_ DIR *dd, long count)
8780 {
8781     int old_flags;
8782
8783     /* If we haven't done anything yet... */
8784     if (dd->count == 0)
8785         return;
8786
8787     /* Remember some state, and clear it. */
8788     old_flags = dd->flags;
8789     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8790     _ckvmssts(lib$find_file_end(&dd->context));
8791     dd->context = 0;
8792
8793     /* The increment is in readdir(). */
8794     for (dd->count = 0; dd->count < count; )
8795         readdir(dd);
8796
8797     dd->flags = old_flags;
8798
8799 }  /* end of seekdir() */
8800 /*}}}*/
8801
8802 /* VMS subprocess management
8803  *
8804  * my_vfork() - just a vfork(), after setting a flag to record that
8805  * the current script is trying a Unix-style fork/exec.
8806  *
8807  * vms_do_aexec() and vms_do_exec() are called in response to the
8808  * perl 'exec' function.  If this follows a vfork call, then they
8809  * call out the regular perl routines in doio.c which do an
8810  * execvp (for those who really want to try this under VMS).
8811  * Otherwise, they do exactly what the perl docs say exec should
8812  * do - terminate the current script and invoke a new command
8813  * (See below for notes on command syntax.)
8814  *
8815  * do_aspawn() and do_spawn() implement the VMS side of the perl
8816  * 'system' function.
8817  *
8818  * Note on command arguments to perl 'exec' and 'system': When handled
8819  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
8820  * are concatenated to form a DCL command string.  If the first arg
8821  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
8822  * the command string is handed off to DCL directly.  Otherwise,
8823  * the first token of the command is taken as the filespec of an image
8824  * to run.  The filespec is expanded using a default type of '.EXE' and
8825  * the process defaults for device, directory, etc., and if found, the resultant
8826  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
8827  * the command string as parameters.  This is perhaps a bit complicated,
8828  * but I hope it will form a happy medium between what VMS folks expect
8829  * from lib$spawn and what Unix folks expect from exec.
8830  */
8831
8832 static int vfork_called;
8833
8834 /*{{{int my_vfork()*/
8835 int
8836 my_vfork()
8837 {
8838   vfork_called++;
8839   return vfork();
8840 }
8841 /*}}}*/
8842
8843
8844 static void
8845 vms_execfree(struct dsc$descriptor_s *vmscmd)
8846 {
8847   if (vmscmd) {
8848       if (vmscmd->dsc$a_pointer) {
8849           PerlMem_free(vmscmd->dsc$a_pointer);
8850       }
8851       PerlMem_free(vmscmd);
8852   }
8853 }
8854
8855 static char *
8856 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
8857 {
8858   char *junk, *tmps = Nullch;
8859   register size_t cmdlen = 0;
8860   size_t rlen;
8861   register SV **idx;
8862   STRLEN n_a;
8863
8864   idx = mark;
8865   if (really) {
8866     tmps = SvPV(really,rlen);
8867     if (*tmps) {
8868       cmdlen += rlen + 1;
8869       idx++;
8870     }
8871   }
8872
8873   for (idx++; idx <= sp; idx++) {
8874     if (*idx) {
8875       junk = SvPVx(*idx,rlen);
8876       cmdlen += rlen ? rlen + 1 : 0;
8877     }
8878   }
8879   Newx(PL_Cmd, cmdlen+1, char);
8880
8881   if (tmps && *tmps) {
8882     strcpy(PL_Cmd,tmps);
8883     mark++;
8884   }
8885   else *PL_Cmd = '\0';
8886   while (++mark <= sp) {
8887     if (*mark) {
8888       char *s = SvPVx(*mark,n_a);
8889       if (!*s) continue;
8890       if (*PL_Cmd) strcat(PL_Cmd," ");
8891       strcat(PL_Cmd,s);
8892     }
8893   }
8894   return PL_Cmd;
8895
8896 }  /* end of setup_argstr() */
8897
8898
8899 static unsigned long int
8900 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
8901                    struct dsc$descriptor_s **pvmscmd)
8902 {
8903   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
8904   char image_name[NAM$C_MAXRSS+1];
8905   char image_argv[NAM$C_MAXRSS+1];
8906   $DESCRIPTOR(defdsc,".EXE");
8907   $DESCRIPTOR(defdsc2,".");
8908   $DESCRIPTOR(resdsc,resspec);
8909   struct dsc$descriptor_s *vmscmd;
8910   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8911   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
8912   register char *s, *rest, *cp, *wordbreak;
8913   char * cmd;
8914   int cmdlen;
8915   register int isdcl;
8916
8917   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8918   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
8919
8920   /* Make a copy for modification */
8921   cmdlen = strlen(incmd);
8922   cmd = PerlMem_malloc(cmdlen+1);
8923   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
8924   strncpy(cmd, incmd, cmdlen);
8925   cmd[cmdlen] = 0;
8926   image_name[0] = 0;
8927   image_argv[0] = 0;
8928
8929   vmscmd->dsc$a_pointer = NULL;
8930   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
8931   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
8932   vmscmd->dsc$w_length = 0;
8933   if (pvmscmd) *pvmscmd = vmscmd;
8934
8935   if (suggest_quote) *suggest_quote = 0;
8936
8937   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
8938     PerlMem_free(cmd);
8939     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
8940   }
8941
8942   s = cmd;
8943
8944   while (*s && isspace(*s)) s++;
8945
8946   if (*s == '@' || *s == '$') {
8947     vmsspec[0] = *s;  rest = s + 1;
8948     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
8949   }
8950   else { cp = vmsspec; rest = s; }
8951   if (*rest == '.' || *rest == '/') {
8952     char *cp2;
8953     for (cp2 = resspec;
8954          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
8955          rest++, cp2++) *cp2 = *rest;
8956     *cp2 = '\0';
8957     if (do_tovmsspec(resspec,cp,0,NULL)) {
8958       s = vmsspec;
8959       if (*rest) {
8960         for (cp2 = vmsspec + strlen(vmsspec);
8961              *rest && cp2 - vmsspec < sizeof vmsspec;
8962              rest++, cp2++) *cp2 = *rest;
8963         *cp2 = '\0';
8964       }
8965     }
8966   }
8967   /* Intuit whether verb (first word of cmd) is a DCL command:
8968    *   - if first nonspace char is '@', it's a DCL indirection
8969    * otherwise
8970    *   - if verb contains a filespec separator, it's not a DCL command
8971    *   - if it doesn't, caller tells us whether to default to a DCL
8972    *     command, or to a local image unless told it's DCL (by leading '$')
8973    */
8974   if (*s == '@') {
8975       isdcl = 1;
8976       if (suggest_quote) *suggest_quote = 1;
8977   } else {
8978     register char *filespec = strpbrk(s,":<[.;");
8979     rest = wordbreak = strpbrk(s," \"\t/");
8980     if (!wordbreak) wordbreak = s + strlen(s);
8981     if (*s == '$') check_img = 0;
8982     if (filespec && (filespec < wordbreak)) isdcl = 0;
8983     else isdcl = !check_img;
8984   }
8985
8986   if (!isdcl) {
8987     int rsts;
8988     imgdsc.dsc$a_pointer = s;
8989     imgdsc.dsc$w_length = wordbreak - s;
8990     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8991     if (!(retsts&1)) {
8992         _ckvmssts(lib$find_file_end(&cxt));
8993         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8994       if (!(retsts & 1) && *s == '$') {
8995         _ckvmssts(lib$find_file_end(&cxt));
8996         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
8997         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8998         if (!(retsts&1)) {
8999           _ckvmssts(lib$find_file_end(&cxt));
9000           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9001         }
9002       }
9003     }
9004     _ckvmssts(lib$find_file_end(&cxt));
9005
9006     if (retsts & 1) {
9007       FILE *fp;
9008       s = resspec;
9009       while (*s && !isspace(*s)) s++;
9010       *s = '\0';
9011
9012       /* check that it's really not DCL with no file extension */
9013       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9014       if (fp) {
9015         char b[256] = {0,0,0,0};
9016         read(fileno(fp), b, 256);
9017         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9018         if (isdcl) {
9019           int shebang_len;
9020
9021           /* Check for script */
9022           shebang_len = 0;
9023           if ((b[0] == '#') && (b[1] == '!'))
9024              shebang_len = 2;
9025 #ifdef ALTERNATE_SHEBANG
9026           else {
9027             shebang_len = strlen(ALTERNATE_SHEBANG);
9028             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9029               char * perlstr;
9030                 perlstr = strstr("perl",b);
9031                 if (perlstr == NULL)
9032                   shebang_len = 0;
9033             }
9034             else
9035               shebang_len = 0;
9036           }
9037 #endif
9038
9039           if (shebang_len > 0) {
9040           int i;
9041           int j;
9042           char tmpspec[NAM$C_MAXRSS + 1];
9043
9044             i = shebang_len;
9045              /* Image is following after white space */
9046             /*--------------------------------------*/
9047             while (isprint(b[i]) && isspace(b[i]))
9048                 i++;
9049
9050             j = 0;
9051             while (isprint(b[i]) && !isspace(b[i])) {
9052                 tmpspec[j++] = b[i++];
9053                 if (j >= NAM$C_MAXRSS)
9054                    break;
9055             }
9056             tmpspec[j] = '\0';
9057
9058              /* There may be some default parameters to the image */
9059             /*---------------------------------------------------*/
9060             j = 0;
9061             while (isprint(b[i])) {
9062                 image_argv[j++] = b[i++];
9063                 if (j >= NAM$C_MAXRSS)
9064                    break;
9065             }
9066             while ((j > 0) && !isprint(image_argv[j-1]))
9067                 j--;
9068             image_argv[j] = 0;
9069
9070             /* It will need to be converted to VMS format and validated */
9071             if (tmpspec[0] != '\0') {
9072               char * iname;
9073
9074                /* Try to find the exact program requested to be run */
9075               /*---------------------------------------------------*/
9076               iname = do_rmsexpand
9077                  (tmpspec, image_name, 0, ".exe",
9078                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
9079               if (iname != NULL) {
9080                 if (cando_by_name_int
9081                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9082                   /* MCR prefix needed */
9083                   isdcl = 0;
9084                 }
9085                 else {
9086                    /* Try again with a null type */
9087                   /*----------------------------*/
9088                   iname = do_rmsexpand
9089                     (tmpspec, image_name, 0, ".",
9090                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
9091                   if (iname != NULL) {
9092                     if (cando_by_name_int
9093                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9094                       /* MCR prefix needed */
9095                       isdcl = 0;
9096                     }
9097                   }
9098                 }
9099
9100                  /* Did we find the image to run the script? */
9101                 /*------------------------------------------*/
9102                 if (isdcl) {
9103                   char *tchr;
9104
9105                    /* Assume DCL or foreign command exists */
9106                   /*--------------------------------------*/
9107                   tchr = strrchr(tmpspec, '/');
9108                   if (tchr != NULL) {
9109                     tchr++;
9110                   }
9111                   else {
9112                     tchr = tmpspec;
9113                   }
9114                   strcpy(image_name, tchr);
9115                 }
9116               }
9117             }
9118           }
9119         }
9120         fclose(fp);
9121       }
9122       if (check_img && isdcl) return RMS$_FNF;
9123
9124       if (cando_by_name(S_IXUSR,0,resspec)) {
9125         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9126         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9127         if (!isdcl) {
9128             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9129             if (image_name[0] != 0) {
9130                 strcat(vmscmd->dsc$a_pointer, image_name);
9131                 strcat(vmscmd->dsc$a_pointer, " ");
9132             }
9133         } else if (image_name[0] != 0) {
9134             strcpy(vmscmd->dsc$a_pointer, image_name);
9135             strcat(vmscmd->dsc$a_pointer, " ");
9136         } else {
9137             strcpy(vmscmd->dsc$a_pointer,"@");
9138         }
9139         if (suggest_quote) *suggest_quote = 1;
9140
9141         /* If there is an image name, use original command */
9142         if (image_name[0] == 0)
9143             strcat(vmscmd->dsc$a_pointer,resspec);
9144         else {
9145             rest = cmd;
9146             while (*rest && isspace(*rest)) rest++;
9147         }
9148
9149         if (image_argv[0] != 0) {
9150           strcat(vmscmd->dsc$a_pointer,image_argv);
9151           strcat(vmscmd->dsc$a_pointer, " ");
9152         }
9153         if (rest) {
9154            int rest_len;
9155            int vmscmd_len;
9156
9157            rest_len = strlen(rest);
9158            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9159            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9160               strcat(vmscmd->dsc$a_pointer,rest);
9161            else
9162              retsts = CLI$_BUFOVF;
9163         }
9164         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9165         PerlMem_free(cmd);
9166         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9167       }
9168       else
9169         retsts = RMS$_PRV;
9170     }
9171   }
9172   /* It's either a DCL command or we couldn't find a suitable image */
9173   vmscmd->dsc$w_length = strlen(cmd);
9174
9175   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9176   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9177   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9178
9179   PerlMem_free(cmd);
9180
9181   /* check if it's a symbol (for quoting purposes) */
9182   if (suggest_quote && !*suggest_quote) {
9183     int iss;
9184     char equiv[LNM$C_NAMLENGTH];
9185     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9186     eqvdsc.dsc$a_pointer = equiv;
9187
9188     iss = lib$get_symbol(vmscmd,&eqvdsc);
9189     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9190   }
9191   if (!(retsts & 1)) {
9192     /* just hand off status values likely to be due to user error */
9193     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9194         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9195        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9196     else { _ckvmssts(retsts); }
9197   }
9198
9199   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9200
9201 }  /* end of setup_cmddsc() */
9202
9203
9204 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9205 bool
9206 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9207 {
9208 bool exec_sts;
9209 char * cmd;
9210
9211   if (sp > mark) {
9212     if (vfork_called) {           /* this follows a vfork - act Unixish */
9213       vfork_called--;
9214       if (vfork_called < 0) {
9215         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9216         vfork_called = 0;
9217       }
9218       else return do_aexec(really,mark,sp);
9219     }
9220                                            /* no vfork - act VMSish */
9221     cmd = setup_argstr(aTHX_ really,mark,sp);
9222     exec_sts = vms_do_exec(cmd);
9223     Safefree(cmd);  /* Clean up from setup_argstr() */
9224     return exec_sts;
9225   }
9226
9227   return FALSE;
9228 }  /* end of vms_do_aexec() */
9229 /*}}}*/
9230
9231 /* {{{bool vms_do_exec(char *cmd) */
9232 bool
9233 Perl_vms_do_exec(pTHX_ const char *cmd)
9234 {
9235   struct dsc$descriptor_s *vmscmd;
9236
9237   if (vfork_called) {             /* this follows a vfork - act Unixish */
9238     vfork_called--;
9239     if (vfork_called < 0) {
9240       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9241       vfork_called = 0;
9242     }
9243     else return do_exec(cmd);
9244   }
9245
9246   {                               /* no vfork - act VMSish */
9247     unsigned long int retsts;
9248
9249     TAINT_ENV();
9250     TAINT_PROPER("exec");
9251     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9252       retsts = lib$do_command(vmscmd);
9253
9254     switch (retsts) {
9255       case RMS$_FNF: case RMS$_DNF:
9256         set_errno(ENOENT); break;
9257       case RMS$_DIR:
9258         set_errno(ENOTDIR); break;
9259       case RMS$_DEV:
9260         set_errno(ENODEV); break;
9261       case RMS$_PRV:
9262         set_errno(EACCES); break;
9263       case RMS$_SYN:
9264         set_errno(EINVAL); break;
9265       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9266         set_errno(E2BIG); break;
9267       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9268         _ckvmssts(retsts); /* fall through */
9269       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9270         set_errno(EVMSERR);
9271     }
9272     set_vaxc_errno(retsts);
9273     if (ckWARN(WARN_EXEC)) {
9274       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9275              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9276     }
9277     vms_execfree(vmscmd);
9278   }
9279
9280   return FALSE;
9281
9282 }  /* end of vms_do_exec() */
9283 /*}}}*/
9284
9285 unsigned long int Perl_do_spawn(pTHX_ const char *);
9286
9287 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9288 unsigned long int
9289 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9290 {
9291 unsigned long int sts;
9292 char * cmd;
9293
9294   if (sp > mark) {
9295     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9296     sts = do_spawn(cmd);
9297     /* pp_sys will clean up cmd */
9298     return sts;
9299   }
9300   return SS$_ABORT;
9301 }  /* end of do_aspawn() */
9302 /*}}}*/
9303
9304 /* {{{unsigned long int do_spawn(char *cmd) */
9305 unsigned long int
9306 Perl_do_spawn(pTHX_ const char *cmd)
9307 {
9308   unsigned long int sts, substs;
9309
9310   /* The caller of this routine expects to Safefree(PL_Cmd) */
9311   Newx(PL_Cmd,10,char);
9312
9313   TAINT_ENV();
9314   TAINT_PROPER("spawn");
9315   if (!cmd || !*cmd) {
9316     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9317     if (!(sts & 1)) {
9318       switch (sts) {
9319         case RMS$_FNF:  case RMS$_DNF:
9320           set_errno(ENOENT); break;
9321         case RMS$_DIR:
9322           set_errno(ENOTDIR); break;
9323         case RMS$_DEV:
9324           set_errno(ENODEV); break;
9325         case RMS$_PRV:
9326           set_errno(EACCES); break;
9327         case RMS$_SYN:
9328           set_errno(EINVAL); break;
9329         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9330           set_errno(E2BIG); break;
9331         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9332           _ckvmssts(sts); /* fall through */
9333         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9334           set_errno(EVMSERR);
9335       }
9336       set_vaxc_errno(sts);
9337       if (ckWARN(WARN_EXEC)) {
9338         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9339                     Strerror(errno));
9340       }
9341     }
9342     sts = substs;
9343   }
9344   else {
9345     PerlIO * fp;
9346     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9347     if (fp != NULL)
9348       my_pclose(fp);
9349   }
9350   return sts;
9351 }  /* end of do_spawn() */
9352 /*}}}*/
9353
9354
9355 static unsigned int *sockflags, sockflagsize;
9356
9357 /*
9358  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9359  * routines found in some versions of the CRTL can't deal with sockets.
9360  * We don't shim the other file open routines since a socket isn't
9361  * likely to be opened by a name.
9362  */
9363 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9364 FILE *my_fdopen(int fd, const char *mode)
9365 {
9366   FILE *fp = fdopen(fd, mode);
9367
9368   if (fp) {
9369     unsigned int fdoff = fd / sizeof(unsigned int);
9370     Stat_t sbuf; /* native stat; we don't need flex_stat */
9371     if (!sockflagsize || fdoff > sockflagsize) {
9372       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
9373       else           Newx  (sockflags,fdoff+2,unsigned int);
9374       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9375       sockflagsize = fdoff + 2;
9376     }
9377     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9378       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9379   }
9380   return fp;
9381
9382 }
9383 /*}}}*/
9384
9385
9386 /*
9387  * Clear the corresponding bit when the (possibly) socket stream is closed.
9388  * There still a small hole: we miss an implicit close which might occur
9389  * via freopen().  >> Todo
9390  */
9391 /*{{{ int my_fclose(FILE *fp)*/
9392 int my_fclose(FILE *fp) {
9393   if (fp) {
9394     unsigned int fd = fileno(fp);
9395     unsigned int fdoff = fd / sizeof(unsigned int);
9396
9397     if (sockflagsize && fdoff <= sockflagsize)
9398       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9399   }
9400   return fclose(fp);
9401 }
9402 /*}}}*/
9403
9404
9405 /*
9406  * A simple fwrite replacement which outputs itmsz*nitm chars without
9407  * introducing record boundaries every itmsz chars.
9408  * We are using fputs, which depends on a terminating null.  We may
9409  * well be writing binary data, so we need to accommodate not only
9410  * data with nulls sprinkled in the middle but also data with no null
9411  * byte at the end.
9412  */
9413 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9414 int
9415 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9416 {
9417   register char *cp, *end, *cpd, *data;
9418   register unsigned int fd = fileno(dest);
9419   register unsigned int fdoff = fd / sizeof(unsigned int);
9420   int retval;
9421   int bufsize = itmsz * nitm + 1;
9422
9423   if (fdoff < sockflagsize &&
9424       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9425     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9426     return nitm;
9427   }
9428
9429   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9430   memcpy( data, src, itmsz*nitm );
9431   data[itmsz*nitm] = '\0';
9432
9433   end = data + itmsz * nitm;
9434   retval = (int) nitm; /* on success return # items written */
9435
9436   cpd = data;
9437   while (cpd <= end) {
9438     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9439     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9440     if (cp < end)
9441       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9442     cpd = cp + 1;
9443   }
9444
9445   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9446   return retval;
9447
9448 }  /* end of my_fwrite() */
9449 /*}}}*/
9450
9451 /*{{{ int my_flush(FILE *fp)*/
9452 int
9453 Perl_my_flush(pTHX_ FILE *fp)
9454 {
9455     int res;
9456     if ((res = fflush(fp)) == 0 && fp) {
9457 #ifdef VMS_DO_SOCKETS
9458         Stat_t s;
9459         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9460 #endif
9461             res = fsync(fileno(fp));
9462     }
9463 /*
9464  * If the flush succeeded but set end-of-file, we need to clear
9465  * the error because our caller may check ferror().  BTW, this
9466  * probably means we just flushed an empty file.
9467  */
9468     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9469
9470     return res;
9471 }
9472 /*}}}*/
9473
9474 /*
9475  * Here are replacements for the following Unix routines in the VMS environment:
9476  *      getpwuid    Get information for a particular UIC or UID
9477  *      getpwnam    Get information for a named user
9478  *      getpwent    Get information for each user in the rights database
9479  *      setpwent    Reset search to the start of the rights database
9480  *      endpwent    Finish searching for users in the rights database
9481  *
9482  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9483  * (defined in pwd.h), which contains the following fields:-
9484  *      struct passwd {
9485  *              char        *pw_name;    Username (in lower case)
9486  *              char        *pw_passwd;  Hashed password
9487  *              unsigned int pw_uid;     UIC
9488  *              unsigned int pw_gid;     UIC group  number
9489  *              char        *pw_unixdir; Default device/directory (VMS-style)
9490  *              char        *pw_gecos;   Owner name
9491  *              char        *pw_dir;     Default device/directory (Unix-style)
9492  *              char        *pw_shell;   Default CLI name (eg. DCL)
9493  *      };
9494  * If the specified user does not exist, getpwuid and getpwnam return NULL.
9495  *
9496  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9497  * not the UIC member number (eg. what's returned by getuid()),
9498  * getpwuid() can accept either as input (if uid is specified, the caller's
9499  * UIC group is used), though it won't recognise gid=0.
9500  *
9501  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9502  * information about other users in your group or in other groups, respectively.
9503  * If the required privilege is not available, then these routines fill only
9504  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9505  * string).
9506  *
9507  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9508  */
9509
9510 /* sizes of various UAF record fields */
9511 #define UAI$S_USERNAME 12
9512 #define UAI$S_IDENT    31
9513 #define UAI$S_OWNER    31
9514 #define UAI$S_DEFDEV   31
9515 #define UAI$S_DEFDIR   63
9516 #define UAI$S_DEFCLI   31
9517 #define UAI$S_PWD       8
9518
9519 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
9520                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9521                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
9522
9523 static char __empty[]= "";
9524 static struct passwd __passwd_empty=
9525     {(char *) __empty, (char *) __empty, 0, 0,
9526      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9527 static int contxt= 0;
9528 static struct passwd __pwdcache;
9529 static char __pw_namecache[UAI$S_IDENT+1];
9530
9531 /*
9532  * This routine does most of the work extracting the user information.
9533  */
9534 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9535 {
9536     static struct {
9537         unsigned char length;
9538         char pw_gecos[UAI$S_OWNER+1];
9539     } owner;
9540     static union uicdef uic;
9541     static struct {
9542         unsigned char length;
9543         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9544     } defdev;
9545     static struct {
9546         unsigned char length;
9547         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9548     } defdir;
9549     static struct {
9550         unsigned char length;
9551         char pw_shell[UAI$S_DEFCLI+1];
9552     } defcli;
9553     static char pw_passwd[UAI$S_PWD+1];
9554
9555     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9556     struct dsc$descriptor_s name_desc;
9557     unsigned long int sts;
9558
9559     static struct itmlst_3 itmlst[]= {
9560         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
9561         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
9562         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
9563         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
9564         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
9565         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
9566         {0,                0,           NULL,    NULL}};
9567
9568     name_desc.dsc$w_length=  strlen(name);
9569     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9570     name_desc.dsc$b_class=   DSC$K_CLASS_S;
9571     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9572
9573 /*  Note that sys$getuai returns many fields as counted strings. */
9574     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9575     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9576       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9577     }
9578     else { _ckvmssts(sts); }
9579     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
9580
9581     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
9582     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9583     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9584     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9585     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9586     owner.pw_gecos[lowner]=            '\0';
9587     defdev.pw_dir[ldefdev+ldefdir]= '\0';
9588     defcli.pw_shell[ldefcli]=          '\0';
9589     if (valid_uic(uic)) {
9590         pwd->pw_uid= uic.uic$l_uic;
9591         pwd->pw_gid= uic.uic$v_group;
9592     }
9593     else
9594       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9595     pwd->pw_passwd=  pw_passwd;
9596     pwd->pw_gecos=   owner.pw_gecos;
9597     pwd->pw_dir=     defdev.pw_dir;
9598     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9599     pwd->pw_shell=   defcli.pw_shell;
9600     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9601         int ldir;
9602         ldir= strlen(pwd->pw_unixdir) - 1;
9603         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9604     }
9605     else
9606         strcpy(pwd->pw_unixdir, pwd->pw_dir);
9607     if (!decc_efs_case_preserve)
9608         __mystrtolower(pwd->pw_unixdir);
9609     return 1;
9610 }
9611
9612 /*
9613  * Get information for a named user.
9614 */
9615 /*{{{struct passwd *getpwnam(char *name)*/
9616 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9617 {
9618     struct dsc$descriptor_s name_desc;
9619     union uicdef uic;
9620     unsigned long int status, sts;
9621
9622     __pwdcache = __passwd_empty;
9623     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9624       /* We still may be able to determine pw_uid and pw_gid */
9625       name_desc.dsc$w_length=  strlen(name);
9626       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9627       name_desc.dsc$b_class=   DSC$K_CLASS_S;
9628       name_desc.dsc$a_pointer= (char *) name;
9629       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9630         __pwdcache.pw_uid= uic.uic$l_uic;
9631         __pwdcache.pw_gid= uic.uic$v_group;
9632       }
9633       else {
9634         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9635           set_vaxc_errno(sts);
9636           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9637           return NULL;
9638         }
9639         else { _ckvmssts(sts); }
9640       }
9641     }
9642     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9643     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9644     __pwdcache.pw_name= __pw_namecache;
9645     return &__pwdcache;
9646 }  /* end of my_getpwnam() */
9647 /*}}}*/
9648
9649 /*
9650  * Get information for a particular UIC or UID.
9651  * Called by my_getpwent with uid=-1 to list all users.
9652 */
9653 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9654 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9655 {
9656     const $DESCRIPTOR(name_desc,__pw_namecache);
9657     unsigned short lname;
9658     union uicdef uic;
9659     unsigned long int status;
9660
9661     if (uid == (unsigned int) -1) {
9662       do {
9663         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9664         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9665           set_vaxc_errno(status);
9666           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9667           my_endpwent();
9668           return NULL;
9669         }
9670         else { _ckvmssts(status); }
9671       } while (!valid_uic (uic));
9672     }
9673     else {
9674       uic.uic$l_uic= uid;
9675       if (!uic.uic$v_group)
9676         uic.uic$v_group= PerlProc_getgid();
9677       if (valid_uic(uic))
9678         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9679       else status = SS$_IVIDENT;
9680       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9681           status == RMS$_PRV) {
9682         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9683         return NULL;
9684       }
9685       else { _ckvmssts(status); }
9686     }
9687     __pw_namecache[lname]= '\0';
9688     __mystrtolower(__pw_namecache);
9689
9690     __pwdcache = __passwd_empty;
9691     __pwdcache.pw_name = __pw_namecache;
9692
9693 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9694     The identifier's value is usually the UIC, but it doesn't have to be,
9695     so if we can, we let fillpasswd update this. */
9696     __pwdcache.pw_uid =  uic.uic$l_uic;
9697     __pwdcache.pw_gid =  uic.uic$v_group;
9698
9699     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9700     return &__pwdcache;
9701
9702 }  /* end of my_getpwuid() */
9703 /*}}}*/
9704
9705 /*
9706  * Get information for next user.
9707 */
9708 /*{{{struct passwd *my_getpwent()*/
9709 struct passwd *Perl_my_getpwent(pTHX)
9710 {
9711     return (my_getpwuid((unsigned int) -1));
9712 }
9713 /*}}}*/
9714
9715 /*
9716  * Finish searching rights database for users.
9717 */
9718 /*{{{void my_endpwent()*/
9719 void Perl_my_endpwent(pTHX)
9720 {
9721     if (contxt) {
9722       _ckvmssts(sys$finish_rdb(&contxt));
9723       contxt= 0;
9724     }
9725 }
9726 /*}}}*/
9727
9728 #ifdef HOMEGROWN_POSIX_SIGNALS
9729   /* Signal handling routines, pulled into the core from POSIX.xs.
9730    *
9731    * We need these for threads, so they've been rolled into the core,
9732    * rather than left in POSIX.xs.
9733    *
9734    * (DRS, Oct 23, 1997)
9735    */
9736
9737   /* sigset_t is atomic under VMS, so these routines are easy */
9738 /*{{{int my_sigemptyset(sigset_t *) */
9739 int my_sigemptyset(sigset_t *set) {
9740     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9741     *set = 0; return 0;
9742 }
9743 /*}}}*/
9744
9745
9746 /*{{{int my_sigfillset(sigset_t *)*/
9747 int my_sigfillset(sigset_t *set) {
9748     int i;
9749     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9750     for (i = 0; i < NSIG; i++) *set |= (1 << i);
9751     return 0;
9752 }
9753 /*}}}*/
9754
9755
9756 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
9757 int my_sigaddset(sigset_t *set, int sig) {
9758     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9759     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9760     *set |= (1 << (sig - 1));
9761     return 0;
9762 }
9763 /*}}}*/
9764
9765
9766 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
9767 int my_sigdelset(sigset_t *set, int sig) {
9768     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9769     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9770     *set &= ~(1 << (sig - 1));
9771     return 0;
9772 }
9773 /*}}}*/
9774
9775
9776 /*{{{int my_sigismember(sigset_t *set, int sig)*/
9777 int my_sigismember(sigset_t *set, int sig) {
9778     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9779     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9780     return *set & (1 << (sig - 1));
9781 }
9782 /*}}}*/
9783
9784
9785 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
9786 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
9787     sigset_t tempmask;
9788
9789     /* If set and oset are both null, then things are badly wrong. Bail out. */
9790     if ((oset == NULL) && (set == NULL)) {
9791       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
9792       return -1;
9793     }
9794
9795     /* If set's null, then we're just handling a fetch. */
9796     if (set == NULL) {
9797         tempmask = sigblock(0);
9798     }
9799     else {
9800       switch (how) {
9801       case SIG_SETMASK:
9802         tempmask = sigsetmask(*set);
9803         break;
9804       case SIG_BLOCK:
9805         tempmask = sigblock(*set);
9806         break;
9807       case SIG_UNBLOCK:
9808         tempmask = sigblock(0);
9809         sigsetmask(*oset & ~tempmask);
9810         break;
9811       default:
9812         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9813         return -1;
9814       }
9815     }
9816
9817     /* Did they pass us an oset? If so, stick our holding mask into it */
9818     if (oset)
9819       *oset = tempmask;
9820
9821     return 0;
9822 }
9823 /*}}}*/
9824 #endif  /* HOMEGROWN_POSIX_SIGNALS */
9825
9826
9827 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
9828  * my_utime(), and flex_stat(), all of which operate on UTC unless
9829  * VMSISH_TIMES is true.
9830  */
9831 /* method used to handle UTC conversions:
9832  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
9833  */
9834 static int gmtime_emulation_type;
9835 /* number of secs to add to UTC POSIX-style time to get local time */
9836 static long int utc_offset_secs;
9837
9838 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
9839  * in vmsish.h.  #undef them here so we can call the CRTL routines
9840  * directly.
9841  */
9842 #undef gmtime
9843 #undef localtime
9844 #undef time
9845
9846
9847 /*
9848  * DEC C previous to 6.0 corrupts the behavior of the /prefix
9849  * qualifier with the extern prefix pragma.  This provisional
9850  * hack circumvents this prefix pragma problem in previous
9851  * precompilers.
9852  */
9853 #if defined(__VMS_VER) && __VMS_VER >= 70000000
9854 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
9855 #    pragma __extern_prefix save
9856 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
9857 #    define gmtime decc$__utctz_gmtime
9858 #    define localtime decc$__utctz_localtime
9859 #    define time decc$__utc_time
9860 #    pragma __extern_prefix restore
9861
9862      struct tm *gmtime(), *localtime();
9863
9864 #  endif
9865 #endif
9866
9867
9868 static time_t toutc_dst(time_t loc) {
9869   struct tm *rsltmp;
9870
9871   if ((rsltmp = localtime(&loc)) == NULL) return -1;
9872   loc -= utc_offset_secs;
9873   if (rsltmp->tm_isdst) loc -= 3600;
9874   return loc;
9875 }
9876 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9877        ((gmtime_emulation_type || my_time(NULL)), \
9878        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
9879        ((secs) - utc_offset_secs))))
9880
9881 static time_t toloc_dst(time_t utc) {
9882   struct tm *rsltmp;
9883
9884   utc += utc_offset_secs;
9885   if ((rsltmp = localtime(&utc)) == NULL) return -1;
9886   if (rsltmp->tm_isdst) utc += 3600;
9887   return utc;
9888 }
9889 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9890        ((gmtime_emulation_type || my_time(NULL)), \
9891        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
9892        ((secs) + utc_offset_secs))))
9893
9894 #ifndef RTL_USES_UTC
9895 /*
9896
9897     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
9898         DST starts on 1st sun of april      at 02:00  std time
9899             ends on last sun of october     at 02:00  dst time
9900     see the UCX management command reference, SET CONFIG TIMEZONE
9901     for formatting info.
9902
9903     No, it's not as general as it should be, but then again, NOTHING
9904     will handle UK times in a sensible way.
9905 */
9906
9907
9908 /*
9909     parse the DST start/end info:
9910     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
9911 */
9912
9913 static char *
9914 tz_parse_startend(char *s, struct tm *w, int *past)
9915 {
9916     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
9917     int ly, dozjd, d, m, n, hour, min, sec, j, k;
9918     time_t g;
9919
9920     if (!s)    return 0;
9921     if (!w) return 0;
9922     if (!past) return 0;
9923
9924     ly = 0;
9925     if (w->tm_year % 4        == 0) ly = 1;
9926     if (w->tm_year % 100      == 0) ly = 0;
9927     if (w->tm_year+1900 % 400 == 0) ly = 1;
9928     if (ly) dinm[1]++;
9929
9930     dozjd = isdigit(*s);
9931     if (*s == 'J' || *s == 'j' || dozjd) {
9932         if (!dozjd && !isdigit(*++s)) return 0;
9933         d = *s++ - '0';
9934         if (isdigit(*s)) {
9935             d = d*10 + *s++ - '0';
9936             if (isdigit(*s)) {
9937                 d = d*10 + *s++ - '0';
9938             }
9939         }
9940         if (d == 0) return 0;
9941         if (d > 366) return 0;
9942         d--;
9943         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
9944         g = d * 86400;
9945         dozjd = 1;
9946     } else if (*s == 'M' || *s == 'm') {
9947         if (!isdigit(*++s)) return 0;
9948         m = *s++ - '0';
9949         if (isdigit(*s)) m = 10*m + *s++ - '0';
9950         if (*s != '.') return 0;
9951         if (!isdigit(*++s)) return 0;
9952         n = *s++ - '0';
9953         if (n < 1 || n > 5) return 0;
9954         if (*s != '.') return 0;
9955         if (!isdigit(*++s)) return 0;
9956         d = *s++ - '0';
9957         if (d > 6) return 0;
9958     }
9959
9960     if (*s == '/') {
9961         if (!isdigit(*++s)) return 0;
9962         hour = *s++ - '0';
9963         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
9964         if (*s == ':') {
9965             if (!isdigit(*++s)) return 0;
9966             min = *s++ - '0';
9967             if (isdigit(*s)) min = 10*min + *s++ - '0';
9968             if (*s == ':') {
9969                 if (!isdigit(*++s)) return 0;
9970                 sec = *s++ - '0';
9971                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
9972             }
9973         }
9974     } else {
9975         hour = 2;
9976         min = 0;
9977         sec = 0;
9978     }
9979
9980     if (dozjd) {
9981         if (w->tm_yday < d) goto before;
9982         if (w->tm_yday > d) goto after;
9983     } else {
9984         if (w->tm_mon+1 < m) goto before;
9985         if (w->tm_mon+1 > m) goto after;
9986
9987         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
9988         k = d - j; /* mday of first d */
9989         if (k <= 0) k += 7;
9990         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
9991         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
9992         if (w->tm_mday < k) goto before;
9993         if (w->tm_mday > k) goto after;
9994     }
9995
9996     if (w->tm_hour < hour) goto before;
9997     if (w->tm_hour > hour) goto after;
9998     if (w->tm_min  < min)  goto before;
9999     if (w->tm_min  > min)  goto after;
10000     if (w->tm_sec  < sec)  goto before;
10001     goto after;
10002
10003 before:
10004     *past = 0;
10005     return s;
10006 after:
10007     *past = 1;
10008     return s;
10009 }
10010
10011
10012
10013
10014 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
10015
10016 static char *
10017 tz_parse_offset(char *s, int *offset)
10018 {
10019     int hour = 0, min = 0, sec = 0;
10020     int neg = 0;
10021     if (!s) return 0;
10022     if (!offset) return 0;
10023
10024     if (*s == '-') {neg++; s++;}
10025     if (*s == '+') s++;
10026     if (!isdigit(*s)) return 0;
10027     hour = *s++ - '0';
10028     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10029     if (hour > 24) return 0;
10030     if (*s == ':') {
10031         if (!isdigit(*++s)) return 0;
10032         min = *s++ - '0';
10033         if (isdigit(*s)) min = min*10 + (*s++ - '0');
10034         if (min > 59) return 0;
10035         if (*s == ':') {
10036             if (!isdigit(*++s)) return 0;
10037             sec = *s++ - '0';
10038             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10039             if (sec > 59) return 0;
10040         }
10041     }
10042
10043     *offset = (hour*60+min)*60 + sec;
10044     if (neg) *offset = -*offset;
10045     return s;
10046 }
10047
10048 /*
10049     input time is w, whatever type of time the CRTL localtime() uses.
10050     sets dst, the zone, and the gmtoff (seconds)
10051
10052     caches the value of TZ and UCX$TZ env variables; note that
10053     my_setenv looks for these and sets a flag if they're changed
10054     for efficiency.
10055
10056     We have to watch out for the "australian" case (dst starts in
10057     october, ends in april)...flagged by "reverse" and checked by
10058     scanning through the months of the previous year.
10059
10060 */
10061
10062 static int
10063 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10064 {
10065     time_t when;
10066     struct tm *w2;
10067     char *s,*s2;
10068     char *dstzone, *tz, *s_start, *s_end;
10069     int std_off, dst_off, isdst;
10070     int y, dststart, dstend;
10071     static char envtz[1025];  /* longer than any logical, symbol, ... */
10072     static char ucxtz[1025];
10073     static char reversed = 0;
10074
10075     if (!w) return 0;
10076
10077     if (tz_updated) {
10078         tz_updated = 0;
10079         reversed = -1;  /* flag need to check  */
10080         envtz[0] = ucxtz[0] = '\0';
10081         tz = my_getenv("TZ",0);
10082         if (tz) strcpy(envtz, tz);
10083         tz = my_getenv("UCX$TZ",0);
10084         if (tz) strcpy(ucxtz, tz);
10085         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
10086     }
10087     tz = envtz;
10088     if (!*tz) tz = ucxtz;
10089
10090     s = tz;
10091     while (isalpha(*s)) s++;
10092     s = tz_parse_offset(s, &std_off);
10093     if (!s) return 0;
10094     if (!*s) {                  /* no DST, hurray we're done! */
10095         isdst = 0;
10096         goto done;
10097     }
10098
10099     dstzone = s;
10100     while (isalpha(*s)) s++;
10101     s2 = tz_parse_offset(s, &dst_off);
10102     if (s2) {
10103         s = s2;
10104     } else {
10105         dst_off = std_off - 3600;
10106     }
10107
10108     if (!*s) {      /* default dst start/end?? */
10109         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
10110             s = strchr(ucxtz,',');
10111         }
10112         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
10113     }
10114     if (*s != ',') return 0;
10115
10116     when = *w;
10117     when = _toutc(when);      /* convert to utc */
10118     when = when - std_off;    /* convert to pseudolocal time*/
10119
10120     w2 = localtime(&when);
10121     y = w2->tm_year;
10122     s_start = s+1;
10123     s = tz_parse_startend(s_start,w2,&dststart);
10124     if (!s) return 0;
10125     if (*s != ',') return 0;
10126
10127     when = *w;
10128     when = _toutc(when);      /* convert to utc */
10129     when = when - dst_off;    /* convert to pseudolocal time*/
10130     w2 = localtime(&when);
10131     if (w2->tm_year != y) {   /* spans a year, just check one time */
10132         when += dst_off - std_off;
10133         w2 = localtime(&when);
10134     }
10135     s_end = s+1;
10136     s = tz_parse_startend(s_end,w2,&dstend);
10137     if (!s) return 0;
10138
10139     if (reversed == -1) {  /* need to check if start later than end */
10140         int j, ds, de;
10141
10142         when = *w;
10143         if (when < 2*365*86400) {
10144             when += 2*365*86400;
10145         } else {
10146             when -= 365*86400;
10147         }
10148         w2 =localtime(&when);
10149         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
10150
10151         for (j = 0; j < 12; j++) {
10152             w2 =localtime(&when);
10153             tz_parse_startend(s_start,w2,&ds);
10154             tz_parse_startend(s_end,w2,&de);
10155             if (ds != de) break;
10156             when += 30*86400;
10157         }
10158         reversed = 0;
10159         if (de && !ds) reversed = 1;
10160     }
10161
10162     isdst = dststart && !dstend;
10163     if (reversed) isdst = dststart  || !dstend;
10164
10165 done:
10166     if (dst)    *dst = isdst;
10167     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10168     if (isdst)  tz = dstzone;
10169     if (zone) {
10170         while(isalpha(*tz))  *zone++ = *tz++;
10171         *zone = '\0';
10172     }
10173     return 1;
10174 }
10175
10176 #endif /* !RTL_USES_UTC */
10177
10178 /* my_time(), my_localtime(), my_gmtime()
10179  * By default traffic in UTC time values, using CRTL gmtime() or
10180  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10181  * Note: We need to use these functions even when the CRTL has working
10182  * UTC support, since they also handle C<use vmsish qw(times);>
10183  *
10184  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
10185  * Modified by Charles Bailey <bailey@newman.upenn.edu>
10186  */
10187
10188 /*{{{time_t my_time(time_t *timep)*/
10189 time_t Perl_my_time(pTHX_ time_t *timep)
10190 {
10191   time_t when;
10192   struct tm *tm_p;
10193
10194   if (gmtime_emulation_type == 0) {
10195     int dstnow;
10196     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
10197                               /* results of calls to gmtime() and localtime() */
10198                               /* for same &base */
10199
10200     gmtime_emulation_type++;
10201     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10202       char off[LNM$C_NAMLENGTH+1];;
10203
10204       gmtime_emulation_type++;
10205       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10206         gmtime_emulation_type++;
10207         utc_offset_secs = 0;
10208         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10209       }
10210       else { utc_offset_secs = atol(off); }
10211     }
10212     else { /* We've got a working gmtime() */
10213       struct tm gmt, local;
10214
10215       gmt = *tm_p;
10216       tm_p = localtime(&base);
10217       local = *tm_p;
10218       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
10219       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10220       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
10221       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
10222     }
10223   }
10224
10225   when = time(NULL);
10226 # ifdef VMSISH_TIME
10227 # ifdef RTL_USES_UTC
10228   if (VMSISH_TIME) when = _toloc(when);
10229 # else
10230   if (!VMSISH_TIME) when = _toutc(when);
10231 # endif
10232 # endif
10233   if (timep != NULL) *timep = when;
10234   return when;
10235
10236 }  /* end of my_time() */
10237 /*}}}*/
10238
10239
10240 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10241 struct tm *
10242 Perl_my_gmtime(pTHX_ const time_t *timep)
10243 {
10244   char *p;
10245   time_t when;
10246   struct tm *rsltmp;
10247
10248   if (timep == NULL) {
10249     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10250     return NULL;
10251   }
10252   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10253
10254   when = *timep;
10255 # ifdef VMSISH_TIME
10256   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10257 #  endif
10258 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
10259   return gmtime(&when);
10260 # else
10261   /* CRTL localtime() wants local time as input, so does no tz correction */
10262   rsltmp = localtime(&when);
10263   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
10264   return rsltmp;
10265 #endif
10266 }  /* end of my_gmtime() */
10267 /*}}}*/
10268
10269
10270 /*{{{struct tm *my_localtime(const time_t *timep)*/
10271 struct tm *
10272 Perl_my_localtime(pTHX_ const time_t *timep)
10273 {
10274   time_t when, whenutc;
10275   struct tm *rsltmp;
10276   int dst, offset;
10277
10278   if (timep == NULL) {
10279     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10280     return NULL;
10281   }
10282   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10283   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10284
10285   when = *timep;
10286 # ifdef RTL_USES_UTC
10287 # ifdef VMSISH_TIME
10288   if (VMSISH_TIME) when = _toutc(when);
10289 # endif
10290   /* CRTL localtime() wants UTC as input, does tz correction itself */
10291   return localtime(&when);
10292
10293 # else /* !RTL_USES_UTC */
10294   whenutc = when;
10295 # ifdef VMSISH_TIME
10296   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
10297   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
10298 # endif
10299   dst = -1;
10300 #ifndef RTL_USES_UTC
10301   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
10302       when = whenutc - offset;                   /* pseudolocal time*/
10303   }
10304 # endif
10305   /* CRTL localtime() wants local time as input, so does no tz correction */
10306   rsltmp = localtime(&when);
10307   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10308   return rsltmp;
10309 # endif
10310
10311 } /*  end of my_localtime() */
10312 /*}}}*/
10313
10314 /* Reset definitions for later calls */
10315 #define gmtime(t)    my_gmtime(t)
10316 #define localtime(t) my_localtime(t)
10317 #define time(t)      my_time(t)
10318
10319
10320 /* my_utime - update modification/access time of a file
10321  *
10322  * VMS 7.3 and later implementation
10323  * Only the UTC translation is home-grown. The rest is handled by the
10324  * CRTL utime(), which will take into account the relevant feature
10325  * logicals and ODS-5 volume characteristics for true access times.
10326  *
10327  * pre VMS 7.3 implementation:
10328  * The calling sequence is identical to POSIX utime(), but under
10329  * VMS with ODS-2, only the modification time is changed; ODS-2 does
10330  * not maintain access times.  Restrictions differ from the POSIX
10331  * definition in that the time can be changed as long as the
10332  * caller has permission to execute the necessary IO$_MODIFY $QIO;
10333  * no separate checks are made to insure that the caller is the
10334  * owner of the file or has special privs enabled.
10335  * Code here is based on Joe Meadows' FILE utility.
10336  *
10337  */
10338
10339 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10340  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
10341  * in 100 ns intervals.
10342  */
10343 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10344
10345 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10346 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10347 {
10348 #if __CRTL_VER >= 70300000
10349   struct utimbuf utc_utimes, *utc_utimesp;
10350
10351   if (utimes != NULL) {
10352     utc_utimes.actime = utimes->actime;
10353     utc_utimes.modtime = utimes->modtime;
10354 # ifdef VMSISH_TIME
10355     /* If input was local; convert to UTC for sys svc */
10356     if (VMSISH_TIME) {
10357       utc_utimes.actime = _toutc(utimes->actime);
10358       utc_utimes.modtime = _toutc(utimes->modtime);
10359     }
10360 # endif
10361     utc_utimesp = &utc_utimes;
10362   }
10363   else {
10364     utc_utimesp = NULL;
10365   }
10366
10367   return utime(file, utc_utimesp);
10368
10369 #else /* __CRTL_VER < 70300000 */
10370
10371   register int i;
10372   int sts;
10373   long int bintime[2], len = 2, lowbit, unixtime,
10374            secscale = 10000000; /* seconds --> 100 ns intervals */
10375   unsigned long int chan, iosb[2], retsts;
10376   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10377   struct FAB myfab = cc$rms_fab;
10378   struct NAM mynam = cc$rms_nam;
10379 #if defined (__DECC) && defined (__VAX)
10380   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10381    * at least through VMS V6.1, which causes a type-conversion warning.
10382    */
10383 #  pragma message save
10384 #  pragma message disable cvtdiftypes
10385 #endif
10386   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10387   struct fibdef myfib;
10388 #if defined (__DECC) && defined (__VAX)
10389   /* This should be right after the declaration of myatr, but due
10390    * to a bug in VAX DEC C, this takes effect a statement early.
10391    */
10392 #  pragma message restore
10393 #endif
10394   /* cast ok for read only parameter */
10395   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10396                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10397                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10398
10399   if (file == NULL || *file == '\0') {
10400     SETERRNO(ENOENT, LIB$_INVARG);
10401     return -1;
10402   }
10403
10404   /* Convert to VMS format ensuring that it will fit in 255 characters */
10405   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10406       SETERRNO(ENOENT, LIB$_INVARG);
10407       return -1;
10408   }
10409   if (utimes != NULL) {
10410     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
10411      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10412      * Since time_t is unsigned long int, and lib$emul takes a signed long int
10413      * as input, we force the sign bit to be clear by shifting unixtime right
10414      * one bit, then multiplying by an extra factor of 2 in lib$emul().
10415      */
10416     lowbit = (utimes->modtime & 1) ? secscale : 0;
10417     unixtime = (long int) utimes->modtime;
10418 #   ifdef VMSISH_TIME
10419     /* If input was UTC; convert to local for sys svc */
10420     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10421 #   endif
10422     unixtime >>= 1;  secscale <<= 1;
10423     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10424     if (!(retsts & 1)) {
10425       SETERRNO(EVMSERR, retsts);
10426       return -1;
10427     }
10428     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10429     if (!(retsts & 1)) {
10430       SETERRNO(EVMSERR, retsts);
10431       return -1;
10432     }
10433   }
10434   else {
10435     /* Just get the current time in VMS format directly */
10436     retsts = sys$gettim(bintime);
10437     if (!(retsts & 1)) {
10438       SETERRNO(EVMSERR, retsts);
10439       return -1;
10440     }
10441   }
10442
10443   myfab.fab$l_fna = vmsspec;
10444   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10445   myfab.fab$l_nam = &mynam;
10446   mynam.nam$l_esa = esa;
10447   mynam.nam$b_ess = (unsigned char) sizeof esa;
10448   mynam.nam$l_rsa = rsa;
10449   mynam.nam$b_rss = (unsigned char) sizeof rsa;
10450   if (decc_efs_case_preserve)
10451       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10452
10453   /* Look for the file to be affected, letting RMS parse the file
10454    * specification for us as well.  I have set errno using only
10455    * values documented in the utime() man page for VMS POSIX.
10456    */
10457   retsts = sys$parse(&myfab,0,0);
10458   if (!(retsts & 1)) {
10459     set_vaxc_errno(retsts);
10460     if      (retsts == RMS$_PRV) set_errno(EACCES);
10461     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10462     else                         set_errno(EVMSERR);
10463     return -1;
10464   }
10465   retsts = sys$search(&myfab,0,0);
10466   if (!(retsts & 1)) {
10467     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10468     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10469     set_vaxc_errno(retsts);
10470     if      (retsts == RMS$_PRV) set_errno(EACCES);
10471     else if (retsts == RMS$_FNF) set_errno(ENOENT);
10472     else                         set_errno(EVMSERR);
10473     return -1;
10474   }
10475
10476   devdsc.dsc$w_length = mynam.nam$b_dev;
10477   /* cast ok for read only parameter */
10478   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10479
10480   retsts = sys$assign(&devdsc,&chan,0,0);
10481   if (!(retsts & 1)) {
10482     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10483     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10484     set_vaxc_errno(retsts);
10485     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
10486     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
10487     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
10488     else                               set_errno(EVMSERR);
10489     return -1;
10490   }
10491
10492   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10493   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10494
10495   memset((void *) &myfib, 0, sizeof myfib);
10496 #if defined(__DECC) || defined(__DECCXX)
10497   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10498   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10499   /* This prevents the revision time of the file being reset to the current
10500    * time as a result of our IO$_MODIFY $QIO. */
10501   myfib.fib$l_acctl = FIB$M_NORECORD;
10502 #else
10503   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10504   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10505   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10506 #endif
10507   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10508   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10509   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10510   _ckvmssts(sys$dassgn(chan));
10511   if (retsts & 1) retsts = iosb[0];
10512   if (!(retsts & 1)) {
10513     set_vaxc_errno(retsts);
10514     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10515     else                      set_errno(EVMSERR);
10516     return -1;
10517   }
10518
10519   return 0;
10520
10521 #endif /* #if __CRTL_VER >= 70300000 */
10522
10523 }  /* end of my_utime() */
10524 /*}}}*/
10525
10526 /*
10527  * flex_stat, flex_lstat, flex_fstat
10528  * basic stat, but gets it right when asked to stat
10529  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10530  */
10531
10532 #ifndef _USE_STD_STAT
10533 /* encode_dev packs a VMS device name string into an integer to allow
10534  * simple comparisons. This can be used, for example, to check whether two
10535  * files are located on the same device, by comparing their encoded device
10536  * names. Even a string comparison would not do, because stat() reuses the
10537  * device name buffer for each call; so without encode_dev, it would be
10538  * necessary to save the buffer and use strcmp (this would mean a number of
10539  * changes to the standard Perl code, to say nothing of what a Perl script
10540  * would have to do.
10541  *
10542  * The device lock id, if it exists, should be unique (unless perhaps compared
10543  * with lock ids transferred from other nodes). We have a lock id if the disk is
10544  * mounted cluster-wide, which is when we tend to get long (host-qualified)
10545  * device names. Thus we use the lock id in preference, and only if that isn't
10546  * available, do we try to pack the device name into an integer (flagged by
10547  * the sign bit (LOCKID_MASK) being set).
10548  *
10549  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10550  * name and its encoded form, but it seems very unlikely that we will find
10551  * two files on different disks that share the same encoded device names,
10552  * and even more remote that they will share the same file id (if the test
10553  * is to check for the same file).
10554  *
10555  * A better method might be to use sys$device_scan on the first call, and to
10556  * search for the device, returning an index into the cached array.
10557  * The number returned would be more intelligible.
10558  * This is probably not worth it, and anyway would take quite a bit longer
10559  * on the first call.
10560  */
10561 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
10562 static mydev_t encode_dev (pTHX_ const char *dev)
10563 {
10564   int i;
10565   unsigned long int f;
10566   mydev_t enc;
10567   char c;
10568   const char *q;
10569
10570   if (!dev || !dev[0]) return 0;
10571
10572 #if LOCKID_MASK
10573   {
10574     struct dsc$descriptor_s dev_desc;
10575     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10576
10577     /* For cluster-mounted disks, the disk lock identifier is unique, so we
10578        can try that first. */
10579     dev_desc.dsc$w_length =  strlen (dev);
10580     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
10581     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
10582     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
10583     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10584     if (!$VMS_STATUS_SUCCESS(status)) {
10585       switch (status) {
10586         case SS$_NOSUCHDEV:
10587           SETERRNO(ENODEV, status);
10588           return 0;
10589         default:
10590           _ckvmssts(status);
10591       }
10592     }
10593     if (lockid) return (lockid & ~LOCKID_MASK);
10594   }
10595 #endif
10596
10597   /* Otherwise we try to encode the device name */
10598   enc = 0;
10599   f = 1;
10600   i = 0;
10601   for (q = dev + strlen(dev); q--; q >= dev) {
10602     if (*q == ':')
10603         break;
10604     if (isdigit (*q))
10605       c= (*q) - '0';
10606     else if (isalpha (toupper (*q)))
10607       c= toupper (*q) - 'A' + (char)10;
10608     else
10609       continue; /* Skip '$'s */
10610     i++;
10611     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
10612     if (i>1) f *= 36;
10613     enc += f * (unsigned long int) c;
10614   }
10615   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
10616
10617 }  /* end of encode_dev() */
10618 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10619         device_no = encode_dev(aTHX_ devname)
10620 #else
10621 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10622         device_no = new_dev_no
10623 #endif
10624
10625 static int
10626 is_null_device(name)
10627     const char *name;
10628 {
10629   if (decc_bug_devnull != 0) {
10630     if (strncmp("/dev/null", name, 9) == 0)
10631       return 1;
10632   }
10633     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10634        The underscore prefix, controller letter, and unit number are
10635        independently optional; for our purposes, the colon punctuation
10636        is not.  The colon can be trailed by optional directory and/or
10637        filename, but two consecutive colons indicates a nodename rather
10638        than a device.  [pr]  */
10639   if (*name == '_') ++name;
10640   if (tolower(*name++) != 'n') return 0;
10641   if (tolower(*name++) != 'l') return 0;
10642   if (tolower(*name) == 'a') ++name;
10643   if (*name == '0') ++name;
10644   return (*name++ == ':') && (*name != ':');
10645 }
10646
10647
10648 static I32
10649 Perl_cando_by_name_int
10650    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10651 {
10652   static char usrname[L_cuserid];
10653   static struct dsc$descriptor_s usrdsc =
10654          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10655   char vmsname[NAM$C_MAXRSS+1];
10656   char *fileified;
10657   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10658   unsigned short int retlen, trnlnm_iter_count;
10659   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10660   union prvdef curprv;
10661   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10662          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10663          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10664   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10665          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10666          {0,0,0,0}};
10667   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10668          {0,0,0,0}};
10669   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10670
10671   if (!fname || !*fname) return FALSE;
10672   /* Make sure we expand logical names, since sys$check_access doesn't */
10673
10674   fileified = NULL;
10675   if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
10676     fileified = PerlMem_malloc(VMS_MAXRSS);
10677     if (!strpbrk(fname,"/]>:")) {
10678       strcpy(fileified,fname);
10679       trnlnm_iter_count = 0;
10680       while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10681         trnlnm_iter_count++;
10682         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10683       }
10684       fname = fileified;
10685     }
10686     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10687       PerlMem_free(fileified);
10688       return FALSE;
10689     }
10690     retlen = namdsc.dsc$w_length = strlen(vmsname);
10691     namdsc.dsc$a_pointer = vmsname;
10692     if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10693       vmsname[retlen-1] == ':') {
10694       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) return FALSE;
10695       namdsc.dsc$w_length = strlen(fileified);
10696       namdsc.dsc$a_pointer = fileified;
10697     }
10698   }
10699   else {
10700     retlen = namdsc.dsc$w_length = strlen(fname);
10701     namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
10702   }
10703
10704   switch (bit) {
10705     case S_IXUSR: case S_IXGRP: case S_IXOTH:
10706       access = ARM$M_EXECUTE;
10707       flags = CHP$M_READ;
10708       break;
10709     case S_IRUSR: case S_IRGRP: case S_IROTH:
10710       access = ARM$M_READ;
10711       flags = CHP$M_READ | CHP$M_USEREADALL;
10712       break;
10713     case S_IWUSR: case S_IWGRP: case S_IWOTH:
10714       access = ARM$M_WRITE;
10715       flags = CHP$M_READ | CHP$M_WRITE;
10716       break;
10717     case S_IDUSR: case S_IDGRP: case S_IDOTH:
10718       access = ARM$M_DELETE;
10719       flags = CHP$M_READ | CHP$M_WRITE;
10720       break;
10721     default:
10722       if (fileified != NULL)
10723         PerlMem_free(fileified);
10724       return FALSE;
10725   }
10726
10727   /* Before we call $check_access, create a user profile with the current
10728    * process privs since otherwise it just uses the default privs from the
10729    * UAF and might give false positives or negatives.  This only works on
10730    * VMS versions v6.0 and later since that's when sys$create_user_profile
10731    * became available.
10732    */
10733
10734   /* get current process privs and username */
10735   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
10736   _ckvmssts(iosb[0]);
10737
10738 #if defined(__VMS_VER) && __VMS_VER >= 60000000
10739
10740   /* find out the space required for the profile */
10741   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
10742                                     &usrprodsc.dsc$w_length,0));
10743
10744   /* allocate space for the profile and get it filled in */
10745   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
10746   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10747   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
10748                                     &usrprodsc.dsc$w_length,0));
10749
10750   /* use the profile to check access to the file; free profile & analyze results */
10751   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
10752   PerlMem_free(usrprodsc.dsc$a_pointer);
10753   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
10754
10755 #else
10756
10757   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
10758
10759 #endif
10760
10761   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
10762       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
10763       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
10764     set_vaxc_errno(retsts);
10765     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10766     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
10767     else set_errno(ENOENT);
10768     if (fileified != NULL)
10769       PerlMem_free(fileified);
10770     return FALSE;
10771   }
10772   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
10773     if (fileified != NULL)
10774       PerlMem_free(fileified);
10775     return TRUE;
10776   }
10777   _ckvmssts(retsts);
10778
10779   if (fileified != NULL)
10780     PerlMem_free(fileified);
10781   return FALSE;  /* Should never get here */
10782
10783 }
10784
10785 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
10786 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
10787  * subset of the applicable information.
10788  */
10789 bool
10790 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
10791 {
10792   return cando_by_name_int
10793         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
10794 }  /* end of cando() */
10795 /*}}}*/
10796
10797
10798 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
10799 I32
10800 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
10801 {
10802    return cando_by_name_int(bit, effective, fname, 0);
10803
10804 }  /* end of cando_by_name() */
10805 /*}}}*/
10806
10807
10808 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
10809 int
10810 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
10811 {
10812   if (!fstat(fd,(stat_t *) statbufp)) {
10813     char *cptr;
10814     char *vms_filename;
10815     vms_filename = PerlMem_malloc(VMS_MAXRSS);
10816     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
10817
10818     /* Save name for cando by name in VMS format */
10819     cptr = getname(fd, vms_filename, 1);
10820
10821     /* This should not happen, but just in case */
10822     if (cptr == NULL) {
10823         statbufp->st_devnam[0] = 0;
10824     }
10825     else {
10826         /* Make sure that the saved name fits in 255 characters */
10827         cptr = do_rmsexpand
10828                        (vms_filename,
10829                         statbufp->st_devnam,
10830                         0,
10831                         NULL,
10832                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
10833                         NULL,
10834                         NULL);
10835         if (cptr == NULL)
10836             statbufp->st_devnam[0] = 0;
10837     }
10838     PerlMem_free(vms_filename);
10839
10840     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10841     VMS_DEVICE_ENCODE
10842         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10843
10844 #   ifdef RTL_USES_UTC
10845 #   ifdef VMSISH_TIME
10846     if (VMSISH_TIME) {
10847       statbufp->st_mtime = _toloc(statbufp->st_mtime);
10848       statbufp->st_atime = _toloc(statbufp->st_atime);
10849       statbufp->st_ctime = _toloc(statbufp->st_ctime);
10850     }
10851 #   endif
10852 #   else
10853 #   ifdef VMSISH_TIME
10854     if (!VMSISH_TIME) { /* Return UTC instead of local time */
10855 #   else
10856     if (1) {
10857 #   endif
10858       statbufp->st_mtime = _toutc(statbufp->st_mtime);
10859       statbufp->st_atime = _toutc(statbufp->st_atime);
10860       statbufp->st_ctime = _toutc(statbufp->st_ctime);
10861     }
10862 #endif
10863     return 0;
10864   }
10865   return -1;
10866
10867 }  /* end of flex_fstat() */
10868 /*}}}*/
10869
10870 #if !defined(__VAX) && __CRTL_VER >= 80200000
10871 #ifdef lstat
10872 #undef lstat
10873 #endif
10874 #else
10875 #ifdef lstat
10876 #undef lstat
10877 #endif
10878 #define lstat(_x, _y) stat(_x, _y)
10879 #endif
10880
10881 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
10882
10883 static int
10884 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
10885 {
10886     char fileified[VMS_MAXRSS];
10887     char temp_fspec[VMS_MAXRSS];
10888     char *save_spec;
10889     int retval = -1;
10890     int saved_errno, saved_vaxc_errno;
10891
10892     if (!fspec) return retval;
10893     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
10894     strcpy(temp_fspec, fspec);
10895
10896     if (decc_bug_devnull != 0) {
10897       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
10898         memset(statbufp,0,sizeof *statbufp);
10899         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
10900         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
10901         statbufp->st_uid = 0x00010001;
10902         statbufp->st_gid = 0x0001;
10903         time((time_t *)&statbufp->st_mtime);
10904         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
10905         return 0;
10906       }
10907     }
10908
10909     /* Try for a directory name first.  If fspec contains a filename without
10910      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
10911      * and sea:[wine.dark]water. exist, we prefer the directory here.
10912      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
10913      * not sea:[wine.dark]., if the latter exists.  If the intended target is
10914      * the file with null type, specify this by calling flex_stat() with
10915      * a '.' at the end of fspec.
10916      *
10917      * If we are in Posix filespec mode, accept the filename as is.
10918      */
10919 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10920   if (decc_posix_compliant_pathnames == 0) {
10921 #endif
10922     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
10923       if (lstat_flag == 0)
10924         retval = stat(fileified,(stat_t *) statbufp);
10925       else
10926         retval = lstat(fileified,(stat_t *) statbufp);
10927       save_spec = fileified;
10928     }
10929     if (retval) {
10930       if (lstat_flag == 0)
10931         retval = stat(temp_fspec,(stat_t *) statbufp);
10932       else
10933         retval = lstat(temp_fspec,(stat_t *) statbufp);
10934       save_spec = temp_fspec;
10935     }
10936 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10937   } else {
10938     if (lstat_flag == 0)
10939       retval = stat(temp_fspec,(stat_t *) statbufp);
10940     else
10941       retval = lstat(temp_fspec,(stat_t *) statbufp);
10942       save_spec = temp_fspec;
10943   }
10944 #endif
10945     if (!retval) {
10946     char * cptr;
10947       cptr = do_rmsexpand
10948        (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
10949       if (cptr == NULL)
10950         statbufp->st_devnam[0] = 0;
10951
10952       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10953       VMS_DEVICE_ENCODE
10954         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10955 #     ifdef RTL_USES_UTC
10956 #     ifdef VMSISH_TIME
10957       if (VMSISH_TIME) {
10958         statbufp->st_mtime = _toloc(statbufp->st_mtime);
10959         statbufp->st_atime = _toloc(statbufp->st_atime);
10960         statbufp->st_ctime = _toloc(statbufp->st_ctime);
10961       }
10962 #     endif
10963 #     else
10964 #     ifdef VMSISH_TIME
10965       if (!VMSISH_TIME) { /* Return UTC instead of local time */
10966 #     else
10967       if (1) {
10968 #     endif
10969         statbufp->st_mtime = _toutc(statbufp->st_mtime);
10970         statbufp->st_atime = _toutc(statbufp->st_atime);
10971         statbufp->st_ctime = _toutc(statbufp->st_ctime);
10972       }
10973 #     endif
10974     }
10975     /* If we were successful, leave errno where we found it */
10976     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
10977     return retval;
10978
10979 }  /* end of flex_stat_int() */
10980
10981
10982 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
10983 int
10984 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
10985 {
10986    return flex_stat_int(fspec, statbufp, 0);
10987 }
10988 /*}}}*/
10989
10990 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
10991 int
10992 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
10993 {
10994    return flex_stat_int(fspec, statbufp, 1);
10995 }
10996 /*}}}*/
10997
10998
10999 /*{{{char *my_getlogin()*/
11000 /* VMS cuserid == Unix getlogin, except calling sequence */
11001 char *
11002 my_getlogin(void)
11003 {
11004     static char user[L_cuserid];
11005     return cuserid(user);
11006 }
11007 /*}}}*/
11008
11009
11010 /*  rmscopy - copy a file using VMS RMS routines
11011  *
11012  *  Copies contents and attributes of spec_in to spec_out, except owner
11013  *  and protection information.  Name and type of spec_in are used as
11014  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
11015  *  should try to propagate timestamps from the input file to the output file.
11016  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
11017  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
11018  *  propagated to the output file at creation iff the output file specification
11019  *  did not contain an explicit name or type, and the revision date is always
11020  *  updated at the end of the copy operation.  If it is greater than 0, then
11021  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11022  *  other than the revision date should be propagated, and bit 1 indicates
11023  *  that the revision date should be propagated.
11024  *
11025  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11026  *
11027  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11028  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
11029  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
11030  * as part of the Perl standard distribution under the terms of the
11031  * GNU General Public License or the Perl Artistic License.  Copies
11032  * of each may be found in the Perl standard distribution.
11033  */ /* FIXME */
11034 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11035 int
11036 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11037 {
11038     char *vmsin, * vmsout, *esa, *esa_out,
11039          *rsa, *ubf;
11040     unsigned long int i, sts, sts2;
11041     int dna_len;
11042     struct FAB fab_in, fab_out;
11043     struct RAB rab_in, rab_out;
11044     rms_setup_nam(nam);
11045     rms_setup_nam(nam_out);
11046     struct XABDAT xabdat;
11047     struct XABFHC xabfhc;
11048     struct XABRDT xabrdt;
11049     struct XABSUM xabsum;
11050
11051     vmsin = PerlMem_malloc(VMS_MAXRSS);
11052     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11053     vmsout = PerlMem_malloc(VMS_MAXRSS);
11054     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11055     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11056         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11057       PerlMem_free(vmsin);
11058       PerlMem_free(vmsout);
11059       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11060       return 0;
11061     }
11062
11063     esa = PerlMem_malloc(VMS_MAXRSS);
11064     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11065     fab_in = cc$rms_fab;
11066     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11067     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11068     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11069     fab_in.fab$l_fop = FAB$M_SQO;
11070     rms_bind_fab_nam(fab_in, nam);
11071     fab_in.fab$l_xab = (void *) &xabdat;
11072
11073     rsa = PerlMem_malloc(VMS_MAXRSS);
11074     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11075     rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11076     rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11077     rms_nam_esl(nam) = 0;
11078     rms_nam_rsl(nam) = 0;
11079     rms_nam_esll(nam) = 0;
11080     rms_nam_rsll(nam) = 0;
11081 #ifdef NAM$M_NO_SHORT_UPCASE
11082     if (decc_efs_case_preserve)
11083         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11084 #endif
11085
11086     xabdat = cc$rms_xabdat;        /* To get creation date */
11087     xabdat.xab$l_nxt = (void *) &xabfhc;
11088
11089     xabfhc = cc$rms_xabfhc;        /* To get record length */
11090     xabfhc.xab$l_nxt = (void *) &xabsum;
11091
11092     xabsum = cc$rms_xabsum;        /* To get key and area information */
11093
11094     if (!((sts = sys$open(&fab_in)) & 1)) {
11095       PerlMem_free(vmsin);
11096       PerlMem_free(vmsout);
11097       PerlMem_free(esa);
11098       PerlMem_free(rsa);
11099       set_vaxc_errno(sts);
11100       switch (sts) {
11101         case RMS$_FNF: case RMS$_DNF:
11102           set_errno(ENOENT); break;
11103         case RMS$_DIR:
11104           set_errno(ENOTDIR); break;
11105         case RMS$_DEV:
11106           set_errno(ENODEV); break;
11107         case RMS$_SYN:
11108           set_errno(EINVAL); break;
11109         case RMS$_PRV:
11110           set_errno(EACCES); break;
11111         default:
11112           set_errno(EVMSERR);
11113       }
11114       return 0;
11115     }
11116
11117     nam_out = nam;
11118     fab_out = fab_in;
11119     fab_out.fab$w_ifi = 0;
11120     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11121     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11122     fab_out.fab$l_fop = FAB$M_SQO;
11123     rms_bind_fab_nam(fab_out, nam_out);
11124     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11125     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11126     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11127     esa_out = PerlMem_malloc(VMS_MAXRSS);
11128     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11129     rms_set_rsa(nam_out, NULL, 0);
11130     rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11131
11132     if (preserve_dates == 0) {  /* Act like DCL COPY */
11133       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11134       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
11135       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11136         PerlMem_free(vmsin);
11137         PerlMem_free(vmsout);
11138         PerlMem_free(esa);
11139         PerlMem_free(rsa);
11140         PerlMem_free(esa_out);
11141         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11142         set_vaxc_errno(sts);
11143         return 0;
11144       }
11145       fab_out.fab$l_xab = (void *) &xabdat;
11146       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11147         preserve_dates = 1;
11148     }
11149     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
11150       preserve_dates =0;      /* bitmask from this point forward   */
11151
11152     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11153     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11154       PerlMem_free(vmsin);
11155       PerlMem_free(vmsout);
11156       PerlMem_free(esa);
11157       PerlMem_free(rsa);
11158       PerlMem_free(esa_out);
11159       set_vaxc_errno(sts);
11160       switch (sts) {
11161         case RMS$_DNF:
11162           set_errno(ENOENT); break;
11163         case RMS$_DIR:
11164           set_errno(ENOTDIR); break;
11165         case RMS$_DEV:
11166           set_errno(ENODEV); break;
11167         case RMS$_SYN:
11168           set_errno(EINVAL); break;
11169         case RMS$_PRV:
11170           set_errno(EACCES); break;
11171         default:
11172           set_errno(EVMSERR);
11173       }
11174       return 0;
11175     }
11176     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
11177     if (preserve_dates & 2) {
11178       /* sys$close() will process xabrdt, not xabdat */
11179       xabrdt = cc$rms_xabrdt;
11180 #ifndef __GNUC__
11181       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11182 #else
11183       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11184        * is unsigned long[2], while DECC & VAXC use a struct */
11185       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11186 #endif
11187       fab_out.fab$l_xab = (void *) &xabrdt;
11188     }
11189
11190     ubf = PerlMem_malloc(32256);
11191     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11192     rab_in = cc$rms_rab;
11193     rab_in.rab$l_fab = &fab_in;
11194     rab_in.rab$l_rop = RAB$M_BIO;
11195     rab_in.rab$l_ubf = ubf;
11196     rab_in.rab$w_usz = 32256;
11197     if (!((sts = sys$connect(&rab_in)) & 1)) {
11198       sys$close(&fab_in); sys$close(&fab_out);
11199       PerlMem_free(vmsin);
11200       PerlMem_free(vmsout);
11201       PerlMem_free(esa);
11202       PerlMem_free(ubf);
11203       PerlMem_free(rsa);
11204       PerlMem_free(esa_out);
11205       set_errno(EVMSERR); set_vaxc_errno(sts);
11206       return 0;
11207     }
11208
11209     rab_out = cc$rms_rab;
11210     rab_out.rab$l_fab = &fab_out;
11211     rab_out.rab$l_rbf = ubf;
11212     if (!((sts = sys$connect(&rab_out)) & 1)) {
11213       sys$close(&fab_in); sys$close(&fab_out);
11214       PerlMem_free(vmsin);
11215       PerlMem_free(vmsout);
11216       PerlMem_free(esa);
11217       PerlMem_free(ubf);
11218       PerlMem_free(rsa);
11219       PerlMem_free(esa_out);
11220       set_errno(EVMSERR); set_vaxc_errno(sts);
11221       return 0;
11222     }
11223
11224     while ((sts = sys$read(&rab_in))) {  /* always true  */
11225       if (sts == RMS$_EOF) break;
11226       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11227       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11228         sys$close(&fab_in); sys$close(&fab_out);
11229         PerlMem_free(vmsin);
11230         PerlMem_free(vmsout);
11231         PerlMem_free(esa);
11232         PerlMem_free(ubf);
11233         PerlMem_free(rsa);
11234         PerlMem_free(esa_out);
11235         set_errno(EVMSERR); set_vaxc_errno(sts);
11236         return 0;
11237       }
11238     }
11239
11240
11241     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
11242     sys$close(&fab_in);  sys$close(&fab_out);
11243     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11244     if (!(sts & 1)) {
11245       PerlMem_free(vmsin);
11246       PerlMem_free(vmsout);
11247       PerlMem_free(esa);
11248       PerlMem_free(ubf);
11249       PerlMem_free(rsa);
11250       PerlMem_free(esa_out);
11251       set_errno(EVMSERR); set_vaxc_errno(sts);
11252       return 0;
11253     }
11254
11255     PerlMem_free(vmsin);
11256     PerlMem_free(vmsout);
11257     PerlMem_free(esa);
11258     PerlMem_free(ubf);
11259     PerlMem_free(rsa);
11260     PerlMem_free(esa_out);
11261     return 1;
11262
11263 }  /* end of rmscopy() */
11264 /*}}}*/
11265
11266
11267 /***  The following glue provides 'hooks' to make some of the routines
11268  * from this file available from Perl.  These routines are sufficiently
11269  * basic, and are required sufficiently early in the build process,
11270  * that's it's nice to have them available to miniperl as well as the
11271  * full Perl, so they're set up here instead of in an extension.  The
11272  * Perl code which handles importation of these names into a given
11273  * package lives in [.VMS]Filespec.pm in @INC.
11274  */
11275
11276 void
11277 rmsexpand_fromperl(pTHX_ CV *cv)
11278 {
11279   dXSARGS;
11280   char *fspec, *defspec = NULL, *rslt;
11281   STRLEN n_a;
11282   int fs_utf8, dfs_utf8;
11283
11284   fs_utf8 = 0;
11285   dfs_utf8 = 0;
11286   if (!items || items > 2)
11287     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11288   fspec = SvPV(ST(0),n_a);
11289   fs_utf8 = SvUTF8(ST(0));
11290   if (!fspec || !*fspec) XSRETURN_UNDEF;
11291   if (items == 2) {
11292     defspec = SvPV(ST(1),n_a);
11293     dfs_utf8 = SvUTF8(ST(1));
11294   }
11295   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11296   ST(0) = sv_newmortal();
11297   if (rslt != NULL) {
11298     sv_usepvn(ST(0),rslt,strlen(rslt));
11299     if (fs_utf8) {
11300         SvUTF8_on(ST(0));
11301     }
11302   }
11303   XSRETURN(1);
11304 }
11305
11306 void
11307 vmsify_fromperl(pTHX_ CV *cv)
11308 {
11309   dXSARGS;
11310   char *vmsified;
11311   STRLEN n_a;
11312   int utf8_fl;
11313
11314   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11315   utf8_fl = SvUTF8(ST(0));
11316   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11317   ST(0) = sv_newmortal();
11318   if (vmsified != NULL) {
11319     sv_usepvn(ST(0),vmsified,strlen(vmsified));
11320     if (utf8_fl) {
11321         SvUTF8_on(ST(0));
11322     }
11323   }
11324   XSRETURN(1);
11325 }
11326
11327 void
11328 unixify_fromperl(pTHX_ CV *cv)
11329 {
11330   dXSARGS;
11331   char *unixified;
11332   STRLEN n_a;
11333   int utf8_fl;
11334
11335   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11336   utf8_fl = SvUTF8(ST(0));
11337   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11338   ST(0) = sv_newmortal();
11339   if (unixified != NULL) {
11340     sv_usepvn(ST(0),unixified,strlen(unixified));
11341     if (utf8_fl) {
11342         SvUTF8_on(ST(0));
11343     }
11344   }
11345   XSRETURN(1);
11346 }
11347
11348 void
11349 fileify_fromperl(pTHX_ CV *cv)
11350 {
11351   dXSARGS;
11352   char *fileified;
11353   STRLEN n_a;
11354   int utf8_fl;
11355
11356   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11357   utf8_fl = SvUTF8(ST(0));
11358   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11359   ST(0) = sv_newmortal();
11360   if (fileified != NULL) {
11361     sv_usepvn(ST(0),fileified,strlen(fileified));
11362     if (utf8_fl) {
11363         SvUTF8_on(ST(0));
11364     }
11365   }
11366   XSRETURN(1);
11367 }
11368
11369 void
11370 pathify_fromperl(pTHX_ CV *cv)
11371 {
11372   dXSARGS;
11373   char *pathified;
11374   STRLEN n_a;
11375   int utf8_fl;
11376
11377   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11378   utf8_fl = SvUTF8(ST(0));
11379   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11380   ST(0) = sv_newmortal();
11381   if (pathified != NULL) {
11382     sv_usepvn(ST(0),pathified,strlen(pathified));
11383     if (utf8_fl) {
11384         SvUTF8_on(ST(0));
11385     }
11386   }
11387   XSRETURN(1);
11388 }
11389
11390 void
11391 vmspath_fromperl(pTHX_ CV *cv)
11392 {
11393   dXSARGS;
11394   char *vmspath;
11395   STRLEN n_a;
11396   int utf8_fl;
11397
11398   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11399   utf8_fl = SvUTF8(ST(0));
11400   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11401   ST(0) = sv_newmortal();
11402   if (vmspath != NULL) {
11403     sv_usepvn(ST(0),vmspath,strlen(vmspath));
11404     if (utf8_fl) {
11405         SvUTF8_on(ST(0));
11406     }
11407   }
11408   XSRETURN(1);
11409 }
11410
11411 void
11412 unixpath_fromperl(pTHX_ CV *cv)
11413 {
11414   dXSARGS;
11415   char *unixpath;
11416   STRLEN n_a;
11417   int utf8_fl;
11418
11419   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11420   utf8_fl = SvUTF8(ST(0));
11421   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11422   ST(0) = sv_newmortal();
11423   if (unixpath != NULL) {
11424     sv_usepvn(ST(0),unixpath,strlen(unixpath));
11425     if (utf8_fl) {
11426         SvUTF8_on(ST(0));
11427     }
11428   }
11429   XSRETURN(1);
11430 }
11431
11432 void
11433 candelete_fromperl(pTHX_ CV *cv)
11434 {
11435   dXSARGS;
11436   char *fspec, *fsp;
11437   SV *mysv;
11438   IO *io;
11439   STRLEN n_a;
11440
11441   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11442
11443   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11444   Newx(fspec, VMS_MAXRSS, char);
11445   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11446   if (SvTYPE(mysv) == SVt_PVGV) {
11447     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11448       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11449       ST(0) = &PL_sv_no;
11450       Safefree(fspec);
11451       XSRETURN(1);
11452     }
11453     fsp = fspec;
11454   }
11455   else {
11456     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11457       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11458       ST(0) = &PL_sv_no;
11459       Safefree(fspec);
11460       XSRETURN(1);
11461     }
11462   }
11463
11464   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11465   Safefree(fspec);
11466   XSRETURN(1);
11467 }
11468
11469 void
11470 rmscopy_fromperl(pTHX_ CV *cv)
11471 {
11472   dXSARGS;
11473   char *inspec, *outspec, *inp, *outp;
11474   int date_flag;
11475   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11476                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11477   unsigned long int sts;
11478   SV *mysv;
11479   IO *io;
11480   STRLEN n_a;
11481
11482   if (items < 2 || items > 3)
11483     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11484
11485   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11486   Newx(inspec, VMS_MAXRSS, char);
11487   if (SvTYPE(mysv) == SVt_PVGV) {
11488     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11489       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11490       ST(0) = &PL_sv_no;
11491       Safefree(inspec);
11492       XSRETURN(1);
11493     }
11494     inp = inspec;
11495   }
11496   else {
11497     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11498       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11499       ST(0) = &PL_sv_no;
11500       Safefree(inspec);
11501       XSRETURN(1);
11502     }
11503   }
11504   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11505   Newx(outspec, VMS_MAXRSS, char);
11506   if (SvTYPE(mysv) == SVt_PVGV) {
11507     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11508       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11509       ST(0) = &PL_sv_no;
11510       Safefree(inspec);
11511       Safefree(outspec);
11512       XSRETURN(1);
11513     }
11514     outp = outspec;
11515   }
11516   else {
11517     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11518       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11519       ST(0) = &PL_sv_no;
11520       Safefree(inspec);
11521       Safefree(outspec);
11522       XSRETURN(1);
11523     }
11524   }
11525   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11526
11527   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11528   Safefree(inspec);
11529   Safefree(outspec);
11530   XSRETURN(1);
11531 }
11532
11533 /* The mod2fname is limited to shorter filenames by design, so it should
11534  * not be modified to support longer EFS pathnames
11535  */
11536 void
11537 mod2fname(pTHX_ CV *cv)
11538 {
11539   dXSARGS;
11540   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11541        workbuff[NAM$C_MAXRSS*1 + 1];
11542   int total_namelen = 3, counter, num_entries;
11543   /* ODS-5 ups this, but we want to be consistent, so... */
11544   int max_name_len = 39;
11545   AV *in_array = (AV *)SvRV(ST(0));
11546
11547   num_entries = av_len(in_array);
11548
11549   /* All the names start with PL_. */
11550   strcpy(ultimate_name, "PL_");
11551
11552   /* Clean up our working buffer */
11553   Zero(work_name, sizeof(work_name), char);
11554
11555   /* Run through the entries and build up a working name */
11556   for(counter = 0; counter <= num_entries; counter++) {
11557     /* If it's not the first name then tack on a __ */
11558     if (counter) {
11559       strcat(work_name, "__");
11560     }
11561     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11562                            PL_na));
11563   }
11564
11565   /* Check to see if we actually have to bother...*/
11566   if (strlen(work_name) + 3 <= max_name_len) {
11567     strcat(ultimate_name, work_name);
11568   } else {
11569     /* It's too darned big, so we need to go strip. We use the same */
11570     /* algorithm as xsubpp does. First, strip out doubled __ */
11571     char *source, *dest, last;
11572     dest = workbuff;
11573     last = 0;
11574     for (source = work_name; *source; source++) {
11575       if (last == *source && last == '_') {
11576         continue;
11577       }
11578       *dest++ = *source;
11579       last = *source;
11580     }
11581     /* Go put it back */
11582     strcpy(work_name, workbuff);
11583     /* Is it still too big? */
11584     if (strlen(work_name) + 3 > max_name_len) {
11585       /* Strip duplicate letters */
11586       last = 0;
11587       dest = workbuff;
11588       for (source = work_name; *source; source++) {
11589         if (last == toupper(*source)) {
11590         continue;
11591         }
11592         *dest++ = *source;
11593         last = toupper(*source);
11594       }
11595       strcpy(work_name, workbuff);
11596     }
11597
11598     /* Is it *still* too big? */
11599     if (strlen(work_name) + 3 > max_name_len) {
11600       /* Too bad, we truncate */
11601       work_name[max_name_len - 2] = 0;
11602     }
11603     strcat(ultimate_name, work_name);
11604   }
11605
11606   /* Okay, return it */
11607   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11608   XSRETURN(1);
11609 }
11610
11611 void
11612 hushexit_fromperl(pTHX_ CV *cv)
11613 {
11614     dXSARGS;
11615
11616     if (items > 0) {
11617         VMSISH_HUSHED = SvTRUE(ST(0));
11618     }
11619     ST(0) = boolSV(VMSISH_HUSHED);
11620     XSRETURN(1);
11621 }
11622
11623
11624 PerlIO *
11625 Perl_vms_start_glob
11626    (pTHX_ SV *tmpglob,
11627     IO *io)
11628 {
11629     PerlIO *fp;
11630     struct vs_str_st *rslt;
11631     char *vmsspec;
11632     char *rstr;
11633     char *begin, *cp;
11634     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11635     PerlIO *tmpfp;
11636     STRLEN i;
11637     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11638     struct dsc$descriptor_vs rsdsc;
11639     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11640     unsigned long hasver = 0, isunix = 0;
11641     unsigned long int lff_flags = 0;
11642     int rms_sts;
11643
11644 #ifdef VMS_LONGNAME_SUPPORT
11645     lff_flags = LIB$M_FIL_LONG_NAMES;
11646 #endif
11647     /* The Newx macro will not allow me to assign a smaller array
11648      * to the rslt pointer, so we will assign it to the begin char pointer
11649      * and then copy the value into the rslt pointer.
11650      */
11651     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11652     rslt = (struct vs_str_st *)begin;
11653     rslt->length = 0;
11654     rstr = &rslt->str[0];
11655     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11656     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11657     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11658     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11659
11660     Newx(vmsspec, VMS_MAXRSS, char);
11661
11662         /* We could find out if there's an explicit dev/dir or version
11663            by peeking into lib$find_file's internal context at
11664            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11665            but that's unsupported, so I don't want to do it now and
11666            have it bite someone in the future. */
11667         /* Fix-me: vms_split_path() is the only way to do this, the
11668            existing method will fail with many legal EFS or UNIX specifications
11669          */
11670
11671     cp = SvPV(tmpglob,i);
11672
11673     for (; i; i--) {
11674         if (cp[i] == ';') hasver = 1;
11675         if (cp[i] == '.') {
11676             if (sts) hasver = 1;
11677             else sts = 1;
11678         }
11679         if (cp[i] == '/') {
11680             hasdir = isunix = 1;
11681             break;
11682         }
11683         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11684             hasdir = 1;
11685             break;
11686         }
11687     }
11688     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11689         Stat_t st;
11690         int stat_sts;
11691         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11692         if (!stat_sts && S_ISDIR(st.st_mode)) {
11693             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
11694             ok = (wilddsc.dsc$a_pointer != NULL);
11695         }
11696         else {
11697             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
11698             ok = (wilddsc.dsc$a_pointer != NULL);
11699         }
11700         if (ok)
11701             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11702
11703         /* If not extended character set, replace ? with % */
11704         /* With extended character set, ? is a wildcard single character */
11705         if (!decc_efs_case_preserve) {
11706             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11707                 if (*cp == '?') *cp = '%';
11708         }
11709         sts = SS$_NORMAL;
11710         while (ok && $VMS_STATUS_SUCCESS(sts)) {
11711          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11712          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11713
11714             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11715                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
11716             if (!$VMS_STATUS_SUCCESS(sts))
11717                 break;
11718
11719             /* with varying string, 1st word of buffer contains result length */
11720             rstr[rslt->length] = '\0';
11721
11722              /* Find where all the components are */
11723              v_sts = vms_split_path
11724                        (rstr,
11725                         &v_spec,
11726                         &v_len,
11727                         &r_spec,
11728                         &r_len,
11729                         &d_spec,
11730                         &d_len,
11731                         &n_spec,
11732                         &n_len,
11733                         &e_spec,
11734                         &e_len,
11735                         &vs_spec,
11736                         &vs_len);
11737
11738             /* If no version on input, truncate the version on output */
11739             if (!hasver && (vs_len > 0)) {
11740                 *vs_spec = '\0';
11741                 vs_len = 0;
11742
11743                 /* No version & a null extension on UNIX handling */
11744                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
11745                     e_len = 0;
11746                     *e_spec = '\0';
11747                 }
11748             }
11749
11750             if (!decc_efs_case_preserve) {
11751                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
11752             }
11753
11754             if (hasdir) {
11755                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
11756                 begin = rstr;
11757             }
11758             else {
11759                 /* Start with the name */
11760                 begin = n_spec;
11761             }
11762             strcat(begin,"\n");
11763             ok = (PerlIO_puts(tmpfp,begin) != EOF);
11764         }
11765         if (cxt) (void)lib$find_file_end(&cxt);
11766         if (ok && sts != RMS$_NMF &&
11767             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
11768         if (!ok) {
11769             if (!(sts & 1)) {
11770                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
11771             }
11772             PerlIO_close(tmpfp);
11773             fp = NULL;
11774         }
11775         else {
11776             PerlIO_rewind(tmpfp);
11777             IoTYPE(io) = IoTYPE_RDONLY;
11778             IoIFP(io) = fp = tmpfp;
11779             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
11780         }
11781     }
11782     Safefree(vmsspec);
11783     Safefree(rslt);
11784     return fp;
11785 }
11786
11787 #ifdef HAS_SYMLINK
11788 static char *
11789 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
11790
11791 void
11792 vms_realpath_fromperl(pTHX_ CV *cv)
11793 {
11794   dXSARGS;
11795   char *fspec, *rslt_spec, *rslt;
11796   STRLEN n_a;
11797
11798   if (!items || items != 1)
11799     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
11800
11801   fspec = SvPV(ST(0),n_a);
11802   if (!fspec || !*fspec) XSRETURN_UNDEF;
11803
11804   Newx(rslt_spec, VMS_MAXRSS + 1, char);
11805   rslt = do_vms_realpath(fspec, rslt_spec, NULL);
11806   ST(0) = sv_newmortal();
11807   if (rslt != NULL)
11808     sv_usepvn(ST(0),rslt,strlen(rslt));
11809   else
11810     Safefree(rslt_spec);
11811   XSRETURN(1);
11812 }
11813 #endif
11814
11815 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11816 int do_vms_case_tolerant(void);
11817
11818 void
11819 vms_case_tolerant_fromperl(pTHX_ CV *cv)
11820 {
11821   dXSARGS;
11822   ST(0) = boolSV(do_vms_case_tolerant());
11823   XSRETURN(1);
11824 }
11825 #endif
11826
11827 void
11828 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
11829                           struct interp_intern *dst)
11830 {
11831     memcpy(dst,src,sizeof(struct interp_intern));
11832 }
11833
11834 void
11835 Perl_sys_intern_clear(pTHX)
11836 {
11837 }
11838
11839 void
11840 Perl_sys_intern_init(pTHX)
11841 {
11842     unsigned int ix = RAND_MAX;
11843     double x;
11844
11845     VMSISH_HUSHED = 0;
11846
11847     /* fix me later to track running under GNV */
11848     /* this allows some limited testing */
11849     MY_POSIX_EXIT = decc_filename_unix_report;
11850
11851     x = (float)ix;
11852     MY_INV_RAND_MAX = 1./x;
11853 }
11854
11855 void
11856 init_os_extras(void)
11857 {
11858   dTHX;
11859   char* file = __FILE__;
11860   if (decc_disable_to_vms_logname_translation) {
11861     no_translate_barewords = TRUE;
11862   } else {
11863     no_translate_barewords = FALSE;
11864   }
11865
11866   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
11867   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
11868   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
11869   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
11870   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
11871   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
11872   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
11873   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
11874   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
11875   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
11876   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
11877 #ifdef HAS_SYMLINK
11878   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
11879 #endif
11880 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11881   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
11882 #endif
11883
11884   store_pipelocs(aTHX);         /* will redo any earlier attempts */
11885
11886   return;
11887 }
11888
11889 #ifdef HAS_SYMLINK
11890
11891 #if __CRTL_VER == 80200000
11892 /* This missed getting in to the DECC SDK for 8.2 */
11893 char *realpath(const char *file_name, char * resolved_name, ...);
11894 #endif
11895
11896 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
11897 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
11898  * The perl fallback routine to provide realpath() is not as efficient
11899  * on OpenVMS.
11900  */
11901 static char *
11902 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11903 {
11904     return realpath(filespec, outbuf);
11905 }
11906
11907 /*}}}*/
11908 /* External entry points */
11909 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11910 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
11911 #else
11912 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11913 { return NULL; }
11914 #endif
11915
11916
11917 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11918 /* case_tolerant */
11919
11920 /*{{{int do_vms_case_tolerant(void)*/
11921 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
11922  * controlled by a process setting.
11923  */
11924 int do_vms_case_tolerant(void)
11925 {
11926     return vms_process_case_tolerant;
11927 }
11928 /*}}}*/
11929 /* External entry points */
11930 int Perl_vms_case_tolerant(void)
11931 { return do_vms_case_tolerant(); }
11932 #else
11933 int Perl_vms_case_tolerant(void)
11934 { return vms_process_case_tolerant; }
11935 #endif
11936
11937
11938  /* Start of DECC RTL Feature handling */
11939
11940 static int sys_trnlnm
11941    (const char * logname,
11942     char * value,
11943     int value_len)
11944 {
11945     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
11946     const unsigned long attr = LNM$M_CASE_BLIND;
11947     struct dsc$descriptor_s name_dsc;
11948     int status;
11949     unsigned short result;
11950     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
11951                                 {0, 0, 0, 0}};
11952
11953     name_dsc.dsc$w_length = strlen(logname);
11954     name_dsc.dsc$a_pointer = (char *)logname;
11955     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11956     name_dsc.dsc$b_class = DSC$K_CLASS_S;
11957
11958     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
11959
11960     if ($VMS_STATUS_SUCCESS(status)) {
11961
11962          /* Null terminate and return the string */
11963         /*--------------------------------------*/
11964         value[result] = 0;
11965     }
11966
11967     return status;
11968 }
11969
11970 static int sys_crelnm
11971    (const char * logname,
11972     const char * value)
11973 {
11974     int ret_val;
11975     const char * proc_table = "LNM$PROCESS_TABLE";
11976     struct dsc$descriptor_s proc_table_dsc;
11977     struct dsc$descriptor_s logname_dsc;
11978     struct itmlst_3 item_list[2];
11979
11980     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
11981     proc_table_dsc.dsc$w_length = strlen(proc_table);
11982     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11983     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
11984
11985     logname_dsc.dsc$a_pointer = (char *) logname;
11986     logname_dsc.dsc$w_length = strlen(logname);
11987     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11988     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
11989
11990     item_list[0].buflen = strlen(value);
11991     item_list[0].itmcode = LNM$_STRING;
11992     item_list[0].bufadr = (char *)value;
11993     item_list[0].retlen = NULL;
11994
11995     item_list[1].buflen = 0;
11996     item_list[1].itmcode = 0;
11997
11998     ret_val = sys$crelnm
11999                        (NULL,
12000                         (const struct dsc$descriptor_s *)&proc_table_dsc,
12001                         (const struct dsc$descriptor_s *)&logname_dsc,
12002                         NULL,
12003                         (const struct item_list_3 *) item_list);
12004
12005     return ret_val;
12006 }
12007
12008 /* C RTL Feature settings */
12009
12010 static int set_features
12011    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
12012     int (* cli_routine)(void),  /* Not documented */
12013     void *image_info)           /* Not documented */
12014 {
12015     int status;
12016     int s;
12017     int dflt;
12018     char* str;
12019     char val_str[10];
12020 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12021     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12022     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12023     unsigned long case_perm;
12024     unsigned long case_image;
12025 #endif
12026
12027     /* Allow an exception to bring Perl into the VMS debugger */
12028     vms_debug_on_exception = 0;
12029     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12030     if ($VMS_STATUS_SUCCESS(status)) {
12031        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12032          vms_debug_on_exception = 1;
12033        else
12034          vms_debug_on_exception = 0;
12035     }
12036
12037     /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
12038     vms_vtf7_filenames = 0;
12039     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12040     if ($VMS_STATUS_SUCCESS(status)) {
12041        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12042          vms_vtf7_filenames = 1;
12043        else
12044          vms_vtf7_filenames = 0;
12045     }
12046
12047     /* Dectect running under GNV Bash or other UNIX like shell */
12048 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12049     gnv_unix_shell = 0;
12050     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12051     if ($VMS_STATUS_SUCCESS(status)) {
12052        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12053          gnv_unix_shell = 1;
12054          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12055          set_feature_default("DECC$EFS_CHARSET", 1);
12056          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12057          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12058          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12059          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12060        }
12061        else
12062          gnv_unix_shell = 0;
12063     }
12064 #endif
12065
12066     /* hacks to see if known bugs are still present for testing */
12067
12068     /* Readdir is returning filenames in VMS syntax always */
12069     decc_bug_readdir_efs1 = 1;
12070     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12071     if ($VMS_STATUS_SUCCESS(status)) {
12072        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12073          decc_bug_readdir_efs1 = 1;
12074        else
12075          decc_bug_readdir_efs1 = 0;
12076     }
12077
12078     /* PCP mode requires creating /dev/null special device file */
12079     decc_bug_devnull = 0;
12080     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12081     if ($VMS_STATUS_SUCCESS(status)) {
12082        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12083           decc_bug_devnull = 1;
12084        else
12085           decc_bug_devnull = 0;
12086     }
12087
12088     /* fgetname returning a VMS name in UNIX mode */
12089     decc_bug_fgetname = 1;
12090     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12091     if ($VMS_STATUS_SUCCESS(status)) {
12092       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12093         decc_bug_fgetname = 1;
12094       else
12095         decc_bug_fgetname = 0;
12096     }
12097
12098     /* UNIX directory names with no paths are broken in a lot of places */
12099     decc_dir_barename = 1;
12100     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12101     if ($VMS_STATUS_SUCCESS(status)) {
12102       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12103         decc_dir_barename = 1;
12104       else
12105         decc_dir_barename = 0;
12106     }
12107
12108 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12109     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12110     if (s >= 0) {
12111         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12112         if (decc_disable_to_vms_logname_translation < 0)
12113             decc_disable_to_vms_logname_translation = 0;
12114     }
12115
12116     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12117     if (s >= 0) {
12118         decc_efs_case_preserve = decc$feature_get_value(s, 1);
12119         if (decc_efs_case_preserve < 0)
12120             decc_efs_case_preserve = 0;
12121     }
12122
12123     s = decc$feature_get_index("DECC$EFS_CHARSET");
12124     if (s >= 0) {
12125         decc_efs_charset = decc$feature_get_value(s, 1);
12126         if (decc_efs_charset < 0)
12127             decc_efs_charset = 0;
12128     }
12129
12130     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12131     if (s >= 0) {
12132         decc_filename_unix_report = decc$feature_get_value(s, 1);
12133         if (decc_filename_unix_report > 0)
12134             decc_filename_unix_report = 1;
12135         else
12136             decc_filename_unix_report = 0;
12137     }
12138
12139     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12140     if (s >= 0) {
12141         decc_filename_unix_only = decc$feature_get_value(s, 1);
12142         if (decc_filename_unix_only > 0) {
12143             decc_filename_unix_only = 1;
12144         }
12145         else {
12146             decc_filename_unix_only = 0;
12147         }
12148     }
12149
12150     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12151     if (s >= 0) {
12152         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12153         if (decc_filename_unix_no_version < 0)
12154             decc_filename_unix_no_version = 0;
12155     }
12156
12157     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12158     if (s >= 0) {
12159         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12160         if (decc_readdir_dropdotnotype < 0)
12161             decc_readdir_dropdotnotype = 0;
12162     }
12163
12164     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12165     if ($VMS_STATUS_SUCCESS(status)) {
12166         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12167         if (s >= 0) {
12168             dflt = decc$feature_get_value(s, 4);
12169             if (dflt > 0) {
12170                 decc_disable_posix_root = decc$feature_get_value(s, 1);
12171                 if (decc_disable_posix_root <= 0) {
12172                     decc$feature_set_value(s, 1, 1);
12173                     decc_disable_posix_root = 1;
12174                 }
12175             }
12176             else {
12177                 /* Traditionally Perl assumes this is off */
12178                 decc_disable_posix_root = 1;
12179                 decc$feature_set_value(s, 1, 1);
12180             }
12181         }
12182     }
12183
12184 #if __CRTL_VER >= 80200000
12185     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12186     if (s >= 0) {
12187         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12188         if (decc_posix_compliant_pathnames < 0)
12189             decc_posix_compliant_pathnames = 0;
12190         if (decc_posix_compliant_pathnames > 4)
12191             decc_posix_compliant_pathnames = 0;
12192     }
12193
12194 #endif
12195 #else
12196     status = sys_trnlnm
12197         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12198     if ($VMS_STATUS_SUCCESS(status)) {
12199         val_str[0] = _toupper(val_str[0]);
12200         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12201            decc_disable_to_vms_logname_translation = 1;
12202         }
12203     }
12204
12205 #ifndef __VAX
12206     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12207     if ($VMS_STATUS_SUCCESS(status)) {
12208         val_str[0] = _toupper(val_str[0]);
12209         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12210            decc_efs_case_preserve = 1;
12211         }
12212     }
12213 #endif
12214
12215     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", 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_filename_unix_report = 1;
12220         }
12221     }
12222     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12223     if ($VMS_STATUS_SUCCESS(status)) {
12224         val_str[0] = _toupper(val_str[0]);
12225         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12226            decc_filename_unix_only = 1;
12227            decc_filename_unix_report = 1;
12228         }
12229     }
12230     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12231     if ($VMS_STATUS_SUCCESS(status)) {
12232         val_str[0] = _toupper(val_str[0]);
12233         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12234            decc_filename_unix_no_version = 1;
12235         }
12236     }
12237     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12238     if ($VMS_STATUS_SUCCESS(status)) {
12239         val_str[0] = _toupper(val_str[0]);
12240         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12241            decc_readdir_dropdotnotype = 1;
12242         }
12243     }
12244 #endif
12245
12246 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12247
12248      /* Report true case tolerance */
12249     /*----------------------------*/
12250     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12251     if (!$VMS_STATUS_SUCCESS(status))
12252         case_perm = PPROP$K_CASE_BLIND;
12253     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12254     if (!$VMS_STATUS_SUCCESS(status))
12255         case_image = PPROP$K_CASE_BLIND;
12256     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12257         (case_image == PPROP$K_CASE_SENSITIVE))
12258         vms_process_case_tolerant = 0;
12259
12260 #endif
12261
12262
12263     /* CRTL can be initialized past this point, but not before. */
12264 /*    DECC$CRTL_INIT(); */
12265
12266     return SS$_NORMAL;
12267 }
12268
12269 #ifdef __DECC
12270 /* DECC dependent attributes */
12271 #if __DECC_VER < 60560002
12272 #define relative
12273 #define not_executable
12274 #else
12275 #define relative ,rel
12276 #define not_executable ,noexe
12277 #endif
12278 #pragma nostandard
12279 #pragma extern_model save
12280 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12281 #endif
12282         const __align (LONGWORD) int spare[8] = {0};
12283 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
12284 /*                        NOWRT, LONG */
12285 #ifdef __DECC
12286 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
12287         nowrt,noshr relative not_executable
12288 #endif
12289 const long vms_cc_features = (const long)set_features;
12290
12291 /*
12292 ** Force a reference to LIB$INITIALIZE to ensure it
12293 ** exists in the image.
12294 */
12295 int lib$initialize(void);
12296 #ifdef __DECC
12297 #pragma extern_model strict_refdef
12298 #endif
12299     int lib_init_ref = (int) lib$initialize;
12300
12301 #ifdef __DECC
12302 #pragma extern_model restore
12303 #pragma standard
12304 #endif
12305
12306 /*  End of vms.c */