vms/vms.c

   1 /* vms.c
   2  *
   3  * VMS-specific routines for perl5
   4  * Version: 5.7.0
   5  *
   6  * August 2005 Convert VMS status code to UNIX status codes
   7  * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
   8  *             and Perl_cando by Craig Berry
   9  * 29-Aug-2000 Charles Lane's piping improvements rolled in
  10  * 20-Aug-1999 revisions by Charles Bailey  bailey@newman.upenn.edu
  11  */
  12
  13 #include <acedef.h>
  14 #include <acldef.h>
  15 #include <armdef.h>
  16 #include <atrdef.h>
  17 #include <chpdef.h>
  18 #include <clidef.h>
  19 #include <climsgdef.h>
  20 #include <descrip.h>
  21 #include <devdef.h>
  22 #include <dvidef.h>
  23 #include <fibdef.h>
  24 #include <float.h>
  25 #include <fscndef.h>
  26 #include <iodef.h>
  27 #include <jpidef.h>
  28 #include <kgbdef.h>
  29 #include <libclidef.h>
  30 #include <libdef.h>
  31 #include <lib$routines.h>
  32 #include <lnmdef.h>
  33 #include <msgdef.h>
  34 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  35 #include <ppropdef.h>
  36 #endif
  37 #include <prvdef.h>
  38 #include <psldef.h>
  39 #include <rms.h>
  40 #include <shrdef.h>
  41 #include <ssdef.h>
  42 #include <starlet.h>
  43 #include <strdef.h>
  44 #include <str$routines.h>
  45 #include <syidef.h>
  46 #include <uaidef.h>
  47 #include <uicdef.h>
  48 #include <stsdef.h>
  49 #include <rmsdef.h>
  50 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
  51 #include <efndef.h>
  52 #define NO_EFN EFN$C_ENF
  53 #else
  54 #define NO_EFN 0;
  55 #endif
  56
  57 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  58 int   decc$feature_get_index(const char *name);
  59 char* decc$feature_get_name(int index);
  60 int   decc$feature_get_value(int index, int mode);
  61 int   decc$feature_set_value(int index, int mode, int value);
  62 #else
  63 #include <unixlib.h>
  64 #endif
  65
  66 #pragma member_alignment save
  67 #pragma nomember_alignment longword
  68 struct item_list_3 {
  69         unsigned short len;
  70         unsigned short code;
  71         void * bufadr;
  72         unsigned short * retadr;
  73 };
  74 #pragma member_alignment restore
  75
  76 /* More specific prototype than in starlet_c.h makes programming errors
  77    more visible.
  78  */
  79 #ifdef sys$getdviw
  80 #undef sys$getdviw
  81 #endif
  82 int sys$getdviw
  83        (unsigned long efn,
  84         unsigned short chan,
  85         const struct dsc$descriptor_s * devnam,
  86         const struct item_list_3 * itmlst,
  87         void * iosb,
  88         void * (astadr)(unsigned long),
  89         void * astprm,
  90         void * nullarg);
  91
  92 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  93
  94 static int set_feature_default(const char *name, int value)
  95 {
  96     int status;
  97     int index;
  98
  99     index = decc$feature_get_index(name);
 100
 101     status = decc$feature_set_value(index, 1, value);
 102     if (index == -1 || (status == -1)) {
 103       return -1;
 104     }
 105
 106     status = decc$feature_get_value(index, 1);
 107     if (status != value) {
 108       return -1;
 109     }
 110
 111 return 0;
 112 }
 113 #endif
 114
 115 /* Older versions of ssdef.h don't have these */
 116 #ifndef SS$_INVFILFOROP
 117 #  define SS$_INVFILFOROP 3930
 118 #endif
 119 #ifndef SS$_NOSUCHOBJECT
 120 #  define SS$_NOSUCHOBJECT 2696
 121 #endif
 122
 123 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 124 #define PERLIO_NOT_STDIO 0
 125
 126 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 127  * code below needs to get to the underlying CRTL routines. */
 128 #define DONT_MASK_RTL_CALLS
 129 #include "EXTERN.h"
 130 #include "perl.h"
 131 #include "XSUB.h"
 132 /* Anticipating future expansion in lexical warnings . . . */
 133 #ifndef WARN_INTERNAL
 134 #  define WARN_INTERNAL WARN_MISC
 135 #endif
 136
 137 #ifdef VMS_LONGNAME_SUPPORT
 138 #include <libfildef.h>
 139 #endif
 140
 141 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 142 #  define RTL_USES_UTC 1
 143 #endif
 144
 145
 146 /* gcc's header files don't #define direct access macros
 147  * corresponding to VAXC's variant structs */
 148 #ifdef __GNUC__
 149 #  define uic$v_format uic$r_uic_form.uic$v_format
 150 #  define uic$v_group uic$r_uic_form.uic$v_group
 151 #  define uic$v_member uic$r_uic_form.uic$v_member
 152 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 153 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 154 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 155 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 156 #endif
 157
 158 #if defined(NEED_AN_H_ERRNO)
 159 dEXT int h_errno;
 160 #endif
 161
 162 #ifdef __DECC
 163 #pragma message disable pragma
 164 #pragma member_alignment save
 165 #pragma nomember_alignment longword
 166 #pragma message save
 167 #pragma message disable misalgndmem
 168 #endif
 169 struct itmlst_3 {
 170   unsigned short int buflen;
 171   unsigned short int itmcode;
 172   void *bufadr;
 173   unsigned short int *retlen;
 174 };
 175
 176 struct filescan_itmlst_2 {
 177     unsigned short length;
 178     unsigned short itmcode;
 179     char * component;
 180 };
 181
 182 struct vs_str_st {
 183     unsigned short length;
 184     char str[65536];
 185 };
 186
 187 #ifdef __DECC
 188 #pragma message restore
 189 #pragma member_alignment restore
 190 #endif
 191
 192 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 193 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 194 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 195 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 196 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 197 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 198 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 199 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 200 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 201 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 202 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 203
 204 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 205 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 206 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 207 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 208
 209 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 210 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 211
 212 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 213  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 214  * the Perl facility.
 215  */
 216 #define PERL_LNM_MAX_ITER 10
 217
 218   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 219 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 220 #define MAX_DCL_SYMBOL          (8192)
 221 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 222 #else
 223 #define MAX_DCL_SYMBOL          (1024)
 224 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 225 #endif
 226
 227 static char *__mystrtolower(char *str)
 228 {
 229   if (str) for (; *str; ++str) *str= tolower(*str);
 230   return str;
 231 }
 232
 233 static struct dsc$descriptor_s fildevdsc =
 234   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 235 static struct dsc$descriptor_s crtlenvdsc =
 236   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 237 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 238 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 239 static struct dsc$descriptor_s **env_tables = defenv;
 240 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 241
 242 /* True if we shouldn't treat barewords as logicals during directory */
 243 /* munching */
 244 static int no_translate_barewords;
 245
 246 #ifndef RTL_USES_UTC
 247 static int tz_updated = 1;
 248 #endif
 249
 250 /* DECC Features that may need to affect how Perl interprets
 251  * displays filename information
 252  */
 253 static int decc_disable_to_vms_logname_translation = 1;
 254 static int decc_disable_posix_root = 1;
 255 int decc_efs_case_preserve = 0;
 256 static int decc_efs_charset = 0;
 257 static int decc_filename_unix_no_version = 0;
 258 static int decc_filename_unix_only = 0;
 259 int decc_filename_unix_report = 0;
 260 int decc_posix_compliant_pathnames = 0;
 261 int decc_readdir_dropdotnotype = 0;
 262 static int vms_process_case_tolerant = 1;
 263 int vms_vtf7_filenames = 0;
 264 int gnv_unix_shell = 0;
 265
 266 /* bug workarounds if needed */
 267 int decc_bug_readdir_efs1 = 0;
 268 int decc_bug_devnull = 1;
 269 int decc_bug_fgetname = 0;
 270 int decc_dir_barename = 0;
 271
 272 static int vms_debug_on_exception = 0;
 273
 274 /* Is this a UNIX file specification?
 275  *   No longer a simple check with EFS file specs
 276  *   For now, not a full check, but need to
 277  *   handle POSIX ^UP^ specifications
 278  *   Fixing to handle ^/ cases would require
 279  *   changes to many other conversion routines.
 280  */
 281
 282 static int is_unix_filespec(const char *path)
 283 {
 284 int ret_val;
 285 const char * pch1;
 286
 287     ret_val = 0;
 288     if (strncmp(path,"\"^UP^",5) != 0) {
 289         pch1 = strchr(path, '/');
 290         if (pch1 != NULL)
 291             ret_val = 1;
 292         else {
 293
 294             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 295             if (decc_filename_unix_report || decc_filename_unix_only) {
 296             if (strcmp(path,".") == 0)
 297                 ret_val = 1;
 298             }
 299         }
 300     }
 301     return ret_val;
 302 }
 303
 304 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 305  */
 306
 307 static void ucs2_to_vtf7
 308    (char *outspec,
 309     unsigned long ucs2_char,
 310     int * output_cnt)
 311 {
 312 unsigned char * ucs_ptr;
 313 int hex;
 314
 315     ucs_ptr = (unsigned char *)&ucs2_char;
 316
 317     outspec[0] = '^';
 318     outspec[1] = 'U';
 319     hex = (ucs_ptr[1] >> 4) & 0xf;
 320     if (hex < 0xA)
 321         outspec[2] = hex + '0';
 322     else
 323         outspec[2] = (hex - 9) + 'A';
 324     hex = ucs_ptr[1] & 0xF;
 325     if (hex < 0xA)
 326         outspec[3] = hex + '0';
 327     else {
 328         outspec[3] = (hex - 9) + 'A';
 329     }
 330     hex = (ucs_ptr[0] >> 4) & 0xf;
 331     if (hex < 0xA)
 332         outspec[4] = hex + '0';
 333     else
 334         outspec[4] = (hex - 9) + 'A';
 335     hex = ucs_ptr[1] & 0xF;
 336     if (hex < 0xA)
 337         outspec[5] = hex + '0';
 338     else {
 339         outspec[5] = (hex - 9) + 'A';
 340     }
 341     *output_cnt = 6;
 342 }
 343
 344
 345 /* This handles the conversion of a UNIX extended character set to a ^
 346  * escaped VMS character.
 347  * in a UNIX file specification.
 348  *
 349  * The output count variable contains the number of characters added
 350  * to the output string.
 351  *
 352  * The return value is the number of characters read from the input string
 353  */
 354 static int copy_expand_unix_filename_escape
 355   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 356 {
 357 int count;
 358 int scnt;
 359 int utf8_flag;
 360
 361     utf8_flag = 0;
 362     if (utf8_fl)
 363       utf8_flag = *utf8_fl;
 364
 365     count = 0;
 366     *output_cnt = 0;
 367     if (*inspec >= 0x80) {
 368         if (utf8_fl && vms_vtf7_filenames) {
 369         unsigned long ucs_char;
 370
 371             ucs_char = 0;
 372
 373             if ((*inspec & 0xE0) == 0xC0) {
 374                 /* 2 byte Unicode */
 375                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 376                 if (ucs_char >= 0x80) {
 377                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 378                     return 2;
 379                 }
 380             } else if ((*inspec & 0xF0) == 0xE0) {
 381                 /* 3 byte Unicode */
 382                 ucs_char = ((inspec[0] & 0xF) << 12) +
 383                    ((inspec[1] & 0x3f) << 6) +
 384                    (inspec[2] & 0x3f);
 385                 if (ucs_char >= 0x800) {
 386                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 387                     return 3;
 388                 }
 389
 390 #if 0 /* I do not see longer sequences supported by OpenVMS */
 391       /* Maybe some one can fix this later */
 392             } else if ((*inspec & 0xF8) == 0xF0) {
 393                 /* 4 byte Unicode */
 394                 /* UCS-4 to UCS-2 */
 395             } else if ((*inspec & 0xFC) == 0xF8) {
 396                 /* 5 byte Unicode */
 397                 /* UCS-4 to UCS-2 */
 398             } else if ((*inspec & 0xFE) == 0xFC) {
 399                 /* 6 byte Unicode */
 400                 /* UCS-4 to UCS-2 */
 401 #endif
 402             }
 403         }
 404
 405         /* High bit set, but not a unicode character! */
 406
 407         /* Non printing DECMCS or ISO Latin-1 character? */
 408         if (*inspec <= 0x9F) {
 409         int hex;
 410             outspec[0] = '^';
 411             outspec++;
 412             hex = (*inspec >> 4) & 0xF;
 413             if (hex < 0xA)
 414                 outspec[1] = hex + '0';
 415             else {
 416                 outspec[1] = (hex - 9) + 'A';
 417             }
 418             hex = *inspec & 0xF;
 419             if (hex < 0xA)
 420                 outspec[2] = hex + '0';
 421             else {
 422                 outspec[2] = (hex - 9) + 'A';
 423             }
 424             *output_cnt = 3;
 425             return 1;
 426         } else if (*inspec == 0xA0) {
 427             outspec[0] = '^';
 428             outspec[1] = 'A';
 429             outspec[2] = '0';
 430             *output_cnt = 3;
 431             return 1;
 432         } else if (*inspec == 0xFF) {
 433             outspec[0] = '^';
 434             outspec[1] = 'F';
 435             outspec[2] = 'F';
 436             *output_cnt = 3;
 437             return 1;
 438         }
 439         *outspec = *inspec;
 440         *output_cnt = 1;
 441         return 1;
 442     }
 443
 444     /* Is this a macro that needs to be passed through?
 445      * Macros start with $( and an alpha character, followed
 446      * by a string of alpha numeric characters ending with a )
 447      * If this does not match, then encode it as ODS-5.
 448      */
 449     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 450     int tcnt;
 451
 452         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 453             tcnt = 3;
 454             outspec[0] = inspec[0];
 455             outspec[1] = inspec[1];
 456             outspec[2] = inspec[2];
 457
 458             while(isalnum(inspec[tcnt]) ||
 459                   (inspec[2] == '.') || (inspec[2] == '_')) {
 460                 outspec[tcnt] = inspec[tcnt];
 461                 tcnt++;
 462             }
 463             if (inspec[tcnt] == ')') {
 464                 outspec[tcnt] = inspec[tcnt];
 465                 tcnt++;
 466                 *output_cnt = tcnt;
 467                 return tcnt;
 468             }
 469         }
 470     }
 471
 472     switch (*inspec) {
 473     case 0x7f:
 474         outspec[0] = '^';
 475         outspec[1] = '7';
 476         outspec[2] = 'F';
 477         *output_cnt = 3;
 478         return 1;
 479         break;
 480     case '?':
 481         if (decc_efs_charset == 0)
 482           outspec[0] = '%';
 483         else
 484           outspec[0] = '?';
 485         *output_cnt = 1;
 486         return 1;
 487         break;
 488     case '.':
 489     case '~':
 490     case '!':
 491     case '#':
 492     case '&':
 493     case '\'':
 494     case '`':
 495     case '(':
 496     case ')':
 497     case '+':
 498     case '@':
 499     case '{':
 500     case '}':
 501     case ',':
 502     case ';':
 503     case '[':
 504     case ']':
 505     case '%':
 506     case '^':
 507     case '=':
 508         /* Assume that this is to be escaped */
 509         outspec[0] = '^';
 510         outspec[1] = *inspec;
 511         *output_cnt = 2;
 512         return 1;
 513         break;
 514     case ' ': /* space */
 515         /* Assume that this is to be escaped */
 516         outspec[0] = '^';
 517         outspec[1] = '_';
 518         *output_cnt = 2;
 519         return 1;
 520         break;
 521     default:
 522         *outspec = *inspec;
 523         *output_cnt = 1;
 524         return 1;
 525         break;
 526     }
 527 }
 528
 529
 530 /* This handles the expansion of a '^' prefix to the proper character
 531  * in a UNIX file specification.
 532  *
 533  * The output count variable contains the number of characters added
 534  * to the output string.
 535  *
 536  * The return value is the number of characters read from the input
 537  * string
 538  */
 539 static int copy_expand_vms_filename_escape
 540   (char *outspec, const char *inspec, int *output_cnt)
 541 {
 542 int count;
 543 int scnt;
 544
 545     count = 0;
 546     *output_cnt = 0;
 547     if (*inspec == '^') {
 548         inspec++;
 549         switch (*inspec) {
 550         case '.':
 551             /* Non trailing dots should just be passed through */
 552             *outspec = *inspec;
 553             count++;
 554             (*output_cnt)++;
 555             break;
 556         case '_': /* space */
 557             *outspec = ' ';
 558             inspec++;
 559             count++;
 560             (*output_cnt)++;
 561             break;
 562         case 'U': /* Unicode - FIX-ME this is wrong. */
 563             inspec++;
 564             count++;
 565             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 566             if (scnt == 4) {
 567                 unsigned int c1, c2;
 568                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 569                 outspec[0] == c1 & 0xff;
 570                 outspec[1] == c2 & 0xff;
 571                 if (scnt > 1) {
 572                     (*output_cnt) += 2;
 573                     count += 4;
 574                 }
 575             }
 576             else {
 577                 /* Error - do best we can to continue */
 578                 *outspec = 'U';
 579                 outspec++;
 580                 (*output_cnt++);
 581                 *outspec = *inspec;
 582                 count++;
 583                 (*output_cnt++);
 584             }
 585             break;
 586         default:
 587             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 588             if (scnt == 2) {
 589                 /* Hex encoded */
 590                 unsigned int c1;
 591                 scnt = sscanf(inspec, "%2x", &c1);
 592                 outspec[0] = c1 & 0xff;
 593                 if (scnt > 0) {
 594                     (*output_cnt++);
 595                     count += 2;
 596                 }
 597             }
 598             else {
 599                 *outspec = *inspec;
 600                 count++;
 601                 (*output_cnt++);
 602             }
 603         }
 604     }
 605     else {
 606         *outspec = *inspec;
 607         count++;
 608         (*output_cnt)++;
 609     }
 610     return count;
 611 }
 612
 613
 614 int SYS$FILESCAN
 615    (const struct dsc$descriptor_s * srcstr,
 616     struct filescan_itmlst_2 * valuelist,
 617     unsigned long * fldflags,
 618     struct dsc$descriptor_s *auxout,
 619     unsigned short * retlen);
 620
 621 /* vms_split_path - Verify that the input file specification is a
 622  * VMS format file specification, and provide pointers to the components of
 623  * it.  With EFS format filenames, this is virtually the only way to
 624  * parse a VMS path specification into components.
 625  *
 626  * If the sum of the components do not add up to the length of the
 627  * string, then the passed file specification is probably a UNIX style
 628  * path.
 629  */
 630 static int vms_split_path
 631    (const char * path,
 632     char * * volume,
 633     int * vol_len,
 634     char * * root,
 635     int * root_len,
 636     char * * dir,
 637     int * dir_len,
 638     char * * name,
 639     int * name_len,
 640     char * * ext,
 641     int * ext_len,
 642     char * * version,
 643     int * ver_len)
 644 {
 645 struct dsc$descriptor path_desc;
 646 int status;
 647 unsigned long flags;
 648 int ret_stat;
 649 struct filescan_itmlst_2 item_list[9];
 650 const int filespec = 0;
 651 const int nodespec = 1;
 652 const int devspec = 2;
 653 const int rootspec = 3;
 654 const int dirspec = 4;
 655 const int namespec = 5;
 656 const int typespec = 6;
 657 const int verspec = 7;
 658
 659     /* Assume the worst for an easy exit */
 660     ret_stat = -1;
 661     *volume = NULL;
 662     *vol_len = 0;
 663     *root = NULL;
 664     *root_len = 0;
 665     *dir = NULL;
 666     *dir_len;
 667     *name = NULL;
 668     *name_len = 0;
 669     *ext = NULL;
 670     *ext_len = 0;
 671     *version = NULL;
 672     *ver_len = 0;
 673
 674     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 675     path_desc.dsc$w_length = strlen(path);
 676     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 677     path_desc.dsc$b_class = DSC$K_CLASS_S;
 678
 679     /* Get the total length, if it is shorter than the string passed
 680      * then this was probably not a VMS formatted file specification
 681      */
 682     item_list[filespec].itmcode = FSCN$_FILESPEC;
 683     item_list[filespec].length = 0;
 684     item_list[filespec].component = NULL;
 685
 686     /* If the node is present, then it gets considered as part of the
 687      * volume name to hopefully make things simple.
 688      */
 689     item_list[nodespec].itmcode = FSCN$_NODE;
 690     item_list[nodespec].length = 0;
 691     item_list[nodespec].component = NULL;
 692
 693     item_list[devspec].itmcode = FSCN$_DEVICE;
 694     item_list[devspec].length = 0;
 695     item_list[devspec].component = NULL;
 696
 697     /* root is a special case,  adding it to either the directory or
 698      * the device components will probalby complicate things for the
 699      * callers of this routine, so leave it separate.
 700      */
 701     item_list[rootspec].itmcode = FSCN$_ROOT;
 702     item_list[rootspec].length = 0;
 703     item_list[rootspec].component = NULL;
 704
 705     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 706     item_list[dirspec].length = 0;
 707     item_list[dirspec].component = NULL;
 708
 709     item_list[namespec].itmcode = FSCN$_NAME;
 710     item_list[namespec].length = 0;
 711     item_list[namespec].component = NULL;
 712
 713     item_list[typespec].itmcode = FSCN$_TYPE;
 714     item_list[typespec].length = 0;
 715     item_list[typespec].component = NULL;
 716
 717     item_list[verspec].itmcode = FSCN$_VERSION;
 718     item_list[verspec].length = 0;
 719     item_list[verspec].component = NULL;
 720
 721     item_list[8].itmcode = 0;
 722     item_list[8].length = 0;
 723     item_list[8].component = NULL;
 724
 725     status = SYS$FILESCAN
 726        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 727         &flags, NULL, NULL);
 728     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 729
 730     /* If we parsed it successfully these two lengths should be the same */
 731     if (path_desc.dsc$w_length != item_list[filespec].length)
 732         return ret_stat;
 733
 734     /* If we got here, then it is a VMS file specification */
 735     ret_stat = 0;
 736
 737     /* set the volume name */
 738     if (item_list[nodespec].length > 0) {
 739         *volume = item_list[nodespec].component;
 740         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 741     }
 742     else {
 743         *volume = item_list[devspec].component;
 744         *vol_len = item_list[devspec].length;
 745     }
 746
 747     *root = item_list[rootspec].component;
 748     *root_len = item_list[rootspec].length;
 749
 750     *dir = item_list[dirspec].component;
 751     *dir_len = item_list[dirspec].length;
 752
 753     /* Now fun with versions and EFS file specifications
 754      * The parser can not tell the difference when a "." is a version
 755      * delimiter or a part of the file specification.
 756      */
 757     if ((decc_efs_charset) &&
 758         (item_list[verspec].length > 0) &&
 759         (item_list[verspec].component[0] == '.')) {
 760         *name = item_list[namespec].component;
 761         *name_len = item_list[namespec].length + item_list[typespec].length;
 762         *ext = item_list[verspec].component;
 763         *ext_len = item_list[verspec].length;
 764         *version = NULL;
 765         *ver_len = 0;
 766     }
 767     else {
 768         *name = item_list[namespec].component;
 769         *name_len = item_list[namespec].length;
 770         *ext = item_list[typespec].component;
 771         *ext_len = item_list[typespec].length;
 772         *version = item_list[verspec].component;
 773         *ver_len = item_list[verspec].length;
 774     }
 775     return ret_stat;
 776 }
 777
 778
 779 /* my_maxidx
 780  * Routine to retrieve the maximum equivalence index for an input
 781  * logical name.  Some calls to this routine have no knowledge if
 782  * the variable is a logical or not.  So on error we return a max
 783  * index of zero.
 784  */
 785 /*{{{int my_maxidx(const char *lnm) */
 786 static int
 787 my_maxidx(const char *lnm)
 788 {
 789     int status;
 790     int midx;
 791     int attr = LNM$M_CASE_BLIND;
 792     struct dsc$descriptor lnmdsc;
 793     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 794                                 {0, 0, 0, 0}};
 795
 796     lnmdsc.dsc$w_length = strlen(lnm);
 797     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 798     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 799     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 800
 801     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 802     if ((status & 1) == 0)
 803        midx = 0;
 804
 805     return (midx);
 806 }
 807 /*}}}*/
 808
 809 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 810 int
 811 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 812   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 813 {
 814     const char *cp1;
 815     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 816     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 817     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 818     int midx;
 819     unsigned char acmode;
 820     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 821                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 822     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 823                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 824                                  {0, 0, 0, 0}};
 825     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 826 #if defined(PERL_IMPLICIT_CONTEXT)
 827     pTHX = NULL;
 828     if (PL_curinterp) {
 829       aTHX = PERL_GET_INTERP;
 830     } else {
 831       aTHX = NULL;
 832     }
 833 #endif
 834
 835     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 836       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 837     }
 838     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 839       *cp2 = _toupper(*cp1);
 840       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 841         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 842         return 0;
 843       }
 844     }
 845     lnmdsc.dsc$w_length = cp1 - lnm;
 846     lnmdsc.dsc$a_pointer = uplnm;
 847     uplnm[lnmdsc.dsc$w_length] = '\0';
 848     secure = flags & PERL__TRNENV_SECURE;
 849     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 850     if (!tabvec || !*tabvec) tabvec = env_tables;
 851
 852     for (curtab = 0; tabvec[curtab]; curtab++) {
 853       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 854         if (!ivenv && !secure) {
 855           char *eq, *end;
 856           int i;
 857           if (!environ) {
 858             ivenv = 1;
 859             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 860             continue;
 861           }
 862           retsts = SS$_NOLOGNAM;
 863           for (i = 0; environ[i]; i++) {
 864             if ((eq = strchr(environ[i],'=')) &&
 865                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 866                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 867               eq++;
 868               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 869               if (!eqvlen) continue;
 870               retsts = SS$_NORMAL;
 871               break;
 872             }
 873           }
 874           if (retsts != SS$_NOLOGNAM) break;
 875         }
 876       }
 877       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 878                !str$case_blind_compare(&tmpdsc,&clisym)) {
 879         if (!ivsym && !secure) {
 880           unsigned short int deflen = LNM$C_NAMLENGTH;
 881           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 882           /* dynamic dsc to accomodate possible long value */
 883           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 884           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 885           if (retsts & 1) {
 886             if (eqvlen > MAX_DCL_SYMBOL) {
 887               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 888               eqvlen = MAX_DCL_SYMBOL;
 889               /* Special hack--we might be called before the interpreter's */
 890               /* fully initialized, in which case either thr or PL_curcop */
 891               /* might be bogus. We have to check, since ckWARN needs them */
 892               /* both to be valid if running threaded */
 893                 if (ckWARN(WARN_MISC)) {
 894                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 895                 }
 896             }
 897             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 898           }
 899           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 900           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 901           if (retsts == LIB$_NOSUCHSYM) continue;
 902           break;
 903         }
 904       }
 905       else if (!ivlnm) {
 906         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 907           midx = my_maxidx(lnm);
 908           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 909             lnmlst[1].bufadr = cp2;
 910             eqvlen = 0;
 911             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 912             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 913             if (retsts == SS$_NOLOGNAM) break;
 914             /* PPFs have a prefix */
 915             if (
 916 #if INTSIZE == 4
 917                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 918 #endif
 919                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 920                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 921                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 922                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 923                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 924               memmove(eqv,eqv+4,eqvlen-4);
 925               eqvlen -= 4;
 926             }
 927             cp2 += eqvlen;
 928             *cp2 = '\0';
 929           }
 930           if ((retsts == SS$_IVLOGNAM) ||
 931               (retsts == SS$_NOLOGNAM)) { continue; }
 932         }
 933         else {
 934           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 935           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 936           if (retsts == SS$_NOLOGNAM) continue;
 937           eqv[eqvlen] = '\0';
 938         }
 939         eqvlen = strlen(eqv);
 940         break;
 941       }
 942     }
 943     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 944     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 945              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 946              retsts == SS$_NOLOGNAM) {
 947       set_errno(EINVAL);  set_vaxc_errno(retsts);
 948     }
 949     else _ckvmssts(retsts);
 950     return 0;
 951 }  /* end of vmstrnenv */
 952 /*}}}*/
 953
 954 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 955 /* Define as a function so we can access statics. */
 956 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 957 {
 958   return vmstrnenv(lnm,eqv,idx,fildev,
 959 #ifdef SECURE_INTERNAL_GETENV
 960                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 961 #else
 962                    0
 963 #endif
 964                                                                               );
 965 }
 966 /*}}}*/
 967
 968 /* my_getenv
 969  * Note: Uses Perl temp to store result so char * can be returned to
 970  * caller; this pointer will be invalidated at next Perl statement
 971  * transition.
 972  * We define this as a function rather than a macro in terms of my_getenv_len()
 973  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 974  * allocate SVs).
 975  */
 976 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 977 char *
 978 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 979 {
 980     const char *cp1;
 981     static char *__my_getenv_eqv = NULL;
 982     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
 983     unsigned long int idx = 0;
 984     int trnsuccess, success, secure, saverr, savvmserr;
 985     int midx, flags;
 986     SV *tmpsv;
 987
 988     midx = my_maxidx(lnm) + 1;
 989
 990     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
 991       /* Set up a temporary buffer for the return value; Perl will
 992        * clean it up at the next statement transition */
 993       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
 994       if (!tmpsv) return NULL;
 995       eqv = SvPVX(tmpsv);
 996     }
 997     else {
 998       /* Assume no interpreter ==> single thread */
 999       if (__my_getenv_eqv != NULL) {
1000         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1001       }
1002       else {
1003         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1004       }
1005       eqv = __my_getenv_eqv;
1006     }
1007
1008     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1009     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1010       int len;
1011       getcwd(eqv,LNM$C_NAMLENGTH);
1012
1013       len = strlen(eqv);
1014
1015       /* Get rid of "000000/ in rooted filespecs */
1016       if (len > 7) {
1017         char * zeros;
1018         zeros = strstr(eqv, "/000000/");
1019         if (zeros != NULL) {
1020           int mlen;
1021           mlen = len - (zeros - eqv) - 7;
1022           memmove(zeros, &zeros[7], mlen);
1023           len = len - 7;
1024           eqv[len] = '\0';
1025         }
1026       }
1027       return eqv;
1028     }
1029     else {
1030       /* Impose security constraints only if tainting */
1031       if (sys) {
1032         /* Impose security constraints only if tainting */
1033         secure = PL_curinterp ? PL_tainting : will_taint;
1034         saverr = errno;  savvmserr = vaxc$errno;
1035       }
1036       else {
1037         secure = 0;
1038       }
1039
1040       flags =
1041 #ifdef SECURE_INTERNAL_GETENV
1042               secure ? PERL__TRNENV_SECURE : 0
1043 #else
1044               0
1045 #endif
1046       ;
1047
1048       /* For the getenv interface we combine all the equivalence names
1049        * of a search list logical into one value to acquire a maximum
1050        * value length of 255*128 (assuming %ENV is using logicals).
1051        */
1052       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1053
1054       /* If the name contains a semicolon-delimited index, parse it
1055        * off and make sure we only retrieve the equivalence name for
1056        * that index.  */
1057       if ((cp2 = strchr(lnm,';')) != NULL) {
1058         strcpy(uplnm,lnm);
1059         uplnm[cp2-lnm] = '\0';
1060         idx = strtoul(cp2+1,NULL,0);
1061         lnm = uplnm;
1062         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1063       }
1064
1065       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1066
1067       /* Discard NOLOGNAM on internal calls since we're often looking
1068        * for an optional name, and this "error" often shows up as the
1069        * (bogus) exit status for a die() call later on.  */
1070       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1071       return success ? eqv : Nullch;
1072     }
1073
1074 }  /* end of my_getenv() */
1075 /*}}}*/
1076
1077
1078 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1079 char *
1080 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1081 {
1082     const char *cp1;
1083     char *buf, *cp2;
1084     unsigned long idx = 0;
1085     int midx, flags;
1086     static char *__my_getenv_len_eqv = NULL;
1087     int secure, saverr, savvmserr;
1088     SV *tmpsv;
1089
1090     midx = my_maxidx(lnm) + 1;
1091
1092     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1093       /* Set up a temporary buffer for the return value; Perl will
1094        * clean it up at the next statement transition */
1095       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1096       if (!tmpsv) return NULL;
1097       buf = SvPVX(tmpsv);
1098     }
1099     else {
1100       /* Assume no interpreter ==> single thread */
1101       if (__my_getenv_len_eqv != NULL) {
1102         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1103       }
1104       else {
1105         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1106       }
1107       buf = __my_getenv_len_eqv;
1108     }
1109
1110     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1111     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1112     char * zeros;
1113
1114       getcwd(buf,LNM$C_NAMLENGTH);
1115       *len = strlen(buf);
1116
1117       /* Get rid of "000000/ in rooted filespecs */
1118       if (*len > 7) {
1119       zeros = strstr(buf, "/000000/");
1120       if (zeros != NULL) {
1121         int mlen;
1122         mlen = *len - (zeros - buf) - 7;
1123         memmove(zeros, &zeros[7], mlen);
1124         *len = *len - 7;
1125         buf[*len] = '\0';
1126         }
1127       }
1128       return buf;
1129     }
1130     else {
1131       if (sys) {
1132         /* Impose security constraints only if tainting */
1133         secure = PL_curinterp ? PL_tainting : will_taint;
1134         saverr = errno;  savvmserr = vaxc$errno;
1135       }
1136       else {
1137         secure = 0;
1138       }
1139
1140       flags =
1141 #ifdef SECURE_INTERNAL_GETENV
1142               secure ? PERL__TRNENV_SECURE : 0
1143 #else
1144               0
1145 #endif
1146       ;
1147
1148       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1149
1150       if ((cp2 = strchr(lnm,';')) != NULL) {
1151         strcpy(buf,lnm);
1152         buf[cp2-lnm] = '\0';
1153         idx = strtoul(cp2+1,NULL,0);
1154         lnm = buf;
1155         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1156       }
1157
1158       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1159
1160       /* Get rid of "000000/ in rooted filespecs */
1161       if (*len > 7) {
1162       char * zeros;
1163         zeros = strstr(buf, "/000000/");
1164         if (zeros != NULL) {
1165           int mlen;
1166           mlen = *len - (zeros - buf) - 7;
1167           memmove(zeros, &zeros[7], mlen);
1168           *len = *len - 7;
1169           buf[*len] = '\0';
1170         }
1171       }
1172
1173       /* Discard NOLOGNAM on internal calls since we're often looking
1174        * for an optional name, and this "error" often shows up as the
1175        * (bogus) exit status for a die() call later on.  */
1176       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1177       return *len ? buf : Nullch;
1178     }
1179
1180 }  /* end of my_getenv_len() */
1181 /*}}}*/
1182
1183 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1184
1185 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1186
1187 /*{{{ void prime_env_iter() */
1188 void
1189 prime_env_iter(void)
1190 /* Fill the %ENV associative array with all logical names we can
1191  * find, in preparation for iterating over it.
1192  */
1193 {
1194   static int primed = 0;
1195   HV *seenhv = NULL, *envhv;
1196   SV *sv = NULL;
1197   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1198   unsigned short int chan;
1199 #ifndef CLI$M_TRUSTED
1200 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1201 #endif
1202   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1203   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1204   long int i;
1205   bool have_sym = FALSE, have_lnm = FALSE;
1206   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1207   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1208   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1209   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1210   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1211 #if defined(PERL_IMPLICIT_CONTEXT)
1212   pTHX;
1213 #endif
1214 #if defined(USE_ITHREADS)
1215   static perl_mutex primenv_mutex;
1216   MUTEX_INIT(&primenv_mutex);
1217 #endif
1218
1219 #if defined(PERL_IMPLICIT_CONTEXT)
1220     /* We jump through these hoops because we can be called at */
1221     /* platform-specific initialization time, which is before anything is */
1222     /* set up--we can't even do a plain dTHX since that relies on the */
1223     /* interpreter structure to be initialized */
1224     if (PL_curinterp) {
1225       aTHX = PERL_GET_INTERP;
1226     } else {
1227       aTHX = NULL;
1228     }
1229 #endif
1230
1231   if (primed || !PL_envgv) return;
1232   MUTEX_LOCK(&primenv_mutex);
1233   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1234   envhv = GvHVn(PL_envgv);
1235   /* Perform a dummy fetch as an lval to insure that the hash table is
1236    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1237   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1238
1239   for (i = 0; env_tables[i]; i++) {
1240      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1241          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1242      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1243   }
1244   if (have_sym || have_lnm) {
1245     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1246     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1247     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1248     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1249   }
1250
1251   for (i--; i >= 0; i--) {
1252     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1253       char *start;
1254       int j;
1255       for (j = 0; environ[j]; j++) {
1256         if (!(start = strchr(environ[j],'='))) {
1257           if (ckWARN(WARN_INTERNAL))
1258             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1259         }
1260         else {
1261           start++;
1262           sv = newSVpv(start,0);
1263           SvTAINTED_on(sv);
1264           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1265         }
1266       }
1267       continue;
1268     }
1269     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1270              !str$case_blind_compare(&tmpdsc,&clisym)) {
1271       strcpy(cmd,"Show Symbol/Global *");
1272       cmddsc.dsc$w_length = 20;
1273       if (env_tables[i]->dsc$w_length == 12 &&
1274           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1275           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1276       flags = defflags | CLI$M_NOLOGNAM;
1277     }
1278     else {
1279       strcpy(cmd,"Show Logical *");
1280       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1281         strcat(cmd," /Table=");
1282         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1283         cmddsc.dsc$w_length = strlen(cmd);
1284       }
1285       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1286       flags = defflags | CLI$M_NOCLISYM;
1287     }
1288
1289     /* Create a new subprocess to execute each command, to exclude the
1290      * remote possibility that someone could subvert a mbx or file used
1291      * to write multiple commands to a single subprocess.
1292      */
1293     do {
1294       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1295                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1296       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1297       defflags &= ~CLI$M_TRUSTED;
1298     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1299     _ckvmssts(retsts);
1300     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1301     if (seenhv) SvREFCNT_dec(seenhv);
1302     seenhv = newHV();
1303     while (1) {
1304       char *cp1, *cp2, *key;
1305       unsigned long int sts, iosb[2], retlen, keylen;
1306       register U32 hash;
1307
1308       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1309       if (sts & 1) sts = iosb[0] & 0xffff;
1310       if (sts == SS$_ENDOFFILE) {
1311         int wakect = 0;
1312         while (substs == 0) { sys$hiber(); wakect++;}
1313         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1314         _ckvmssts(substs);
1315         break;
1316       }
1317       _ckvmssts(sts);
1318       retlen = iosb[0] >> 16;
1319       if (!retlen) continue;  /* blank line */
1320       buf[retlen] = '\0';
1321       if (iosb[1] != subpid) {
1322         if (iosb[1]) {
1323           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1324         }
1325         continue;
1326       }
1327       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1328         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1329
1330       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1331       if (*cp1 == '(' || /* Logical name table name */
1332           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1333       if (*cp1 == '"') cp1++;
1334       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1335       key = cp1;  keylen = cp2 - cp1;
1336       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1337       while (*cp2 && *cp2 != '=') cp2++;
1338       while (*cp2 && *cp2 == '=') cp2++;
1339       while (*cp2 && *cp2 == ' ') cp2++;
1340       if (*cp2 == '"') {  /* String translation; may embed "" */
1341         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1342         cp2++;  cp1--; /* Skip "" surrounding translation */
1343       }
1344       else {  /* Numeric translation */
1345         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1346         cp1--;  /* stop on last non-space char */
1347       }
1348       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1349         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1350         continue;
1351       }
1352       PERL_HASH(hash,key,keylen);
1353
1354       if (cp1 == cp2 && *cp2 == '.') {
1355         /* A single dot usually means an unprintable character, such as a null
1356          * to indicate a zero-length value.  Get the actual value to make sure.
1357          */
1358         char lnm[LNM$C_NAMLENGTH+1];
1359         char eqv[MAX_DCL_SYMBOL+1];
1360         strncpy(lnm, key, keylen);
1361         int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1362         sv = newSVpvn(eqv, strlen(eqv));
1363       }
1364       else {
1365         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1366       }
1367
1368       SvTAINTED_on(sv);
1369       hv_store(envhv,key,keylen,sv,hash);
1370       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1371     }
1372     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1373       /* get the PPFs for this process, not the subprocess */
1374       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1375       char eqv[LNM$C_NAMLENGTH+1];
1376       int trnlen, i;
1377       for (i = 0; ppfs[i]; i++) {
1378         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1379         sv = newSVpv(eqv,trnlen);
1380         SvTAINTED_on(sv);
1381         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1382       }
1383     }
1384   }
1385   primed = 1;
1386   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1387   if (buf) Safefree(buf);
1388   if (seenhv) SvREFCNT_dec(seenhv);
1389   MUTEX_UNLOCK(&primenv_mutex);
1390   return;
1391
1392 }  /* end of prime_env_iter */
1393 /*}}}*/
1394
1395
1396 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1397 /* Define or delete an element in the same "environment" as
1398  * vmstrnenv().  If an element is to be deleted, it's removed from
1399  * the first place it's found.  If it's to be set, it's set in the
1400  * place designated by the first element of the table vector.
1401  * Like setenv() returns 0 for success, non-zero on error.
1402  */
1403 int
1404 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1405 {
1406     const char *cp1;
1407     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1408     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1409     int nseg = 0, j;
1410     unsigned long int retsts, usermode = PSL$C_USER;
1411     struct itmlst_3 *ile, *ilist;
1412     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1413                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1414                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1415     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1416     $DESCRIPTOR(local,"_LOCAL");
1417
1418     if (!lnm) {
1419         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1420         return SS$_IVLOGNAM;
1421     }
1422
1423     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1424       *cp2 = _toupper(*cp1);
1425       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1426         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1427         return SS$_IVLOGNAM;
1428       }
1429     }
1430     lnmdsc.dsc$w_length = cp1 - lnm;
1431     if (!tabvec || !*tabvec) tabvec = env_tables;
1432
1433     if (!eqv) {  /* we're deleting n element */
1434       for (curtab = 0; tabvec[curtab]; curtab++) {
1435         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1436         int i;
1437           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1438             if ((cp1 = strchr(environ[i],'=')) &&
1439                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1440                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1441 #ifdef HAS_SETENV
1442               return setenv(lnm,"",1) ? vaxc$errno : 0;
1443             }
1444           }
1445           ivenv = 1; retsts = SS$_NOLOGNAM;
1446 #else
1447               if (ckWARN(WARN_INTERNAL))
1448                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1449               ivenv = 1; retsts = SS$_NOSUCHPGM;
1450               break;
1451             }
1452           }
1453 #endif
1454         }
1455         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1456                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1457           unsigned int symtype;
1458           if (tabvec[curtab]->dsc$w_length == 12 &&
1459               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1460               !str$case_blind_compare(&tmpdsc,&local))
1461             symtype = LIB$K_CLI_LOCAL_SYM;
1462           else symtype = LIB$K_CLI_GLOBAL_SYM;
1463           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1464           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1465           if (retsts == LIB$_NOSUCHSYM) continue;
1466           break;
1467         }
1468         else if (!ivlnm) {
1469           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1470           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1471           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1472           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1473           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1474         }
1475       }
1476     }
1477     else {  /* we're defining a value */
1478       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1479 #ifdef HAS_SETENV
1480         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1481 #else
1482         if (ckWARN(WARN_INTERNAL))
1483           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1484         retsts = SS$_NOSUCHPGM;
1485 #endif
1486       }
1487       else {
1488         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1489         eqvdsc.dsc$w_length  = strlen(eqv);
1490         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1491             !str$case_blind_compare(&tmpdsc,&clisym)) {
1492           unsigned int symtype;
1493           if (tabvec[0]->dsc$w_length == 12 &&
1494               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1495                !str$case_blind_compare(&tmpdsc,&local))
1496             symtype = LIB$K_CLI_LOCAL_SYM;
1497           else symtype = LIB$K_CLI_GLOBAL_SYM;
1498           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1499         }
1500         else {
1501           if (!*eqv) eqvdsc.dsc$w_length = 1;
1502           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1503
1504             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1505             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1506               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1507                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1508               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1509               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1510             }
1511
1512             Newx(ilist,nseg+1,struct itmlst_3);
1513             ile = ilist;
1514             if (!ile) {
1515               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1516               return SS$_INSFMEM;
1517             }
1518             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1519
1520             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1521               ile->itmcode = LNM$_STRING;
1522               ile->bufadr = c;
1523               if ((j+1) == nseg) {
1524                 ile->buflen = strlen(c);
1525                 /* in case we are truncating one that's too long */
1526                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1527               }
1528               else {
1529                 ile->buflen = LNM$C_NAMLENGTH;
1530               }
1531             }
1532
1533             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1534             Safefree (ilist);
1535           }
1536           else {
1537             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1538           }
1539         }
1540       }
1541     }
1542     if (!(retsts & 1)) {
1543       switch (retsts) {
1544         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1545         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1546           set_errno(EVMSERR); break;
1547         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1548         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1549           set_errno(EINVAL); break;
1550         case SS$_NOPRIV:
1551           set_errno(EACCES); break;
1552         default:
1553           _ckvmssts(retsts);
1554           set_errno(EVMSERR);
1555        }
1556        set_vaxc_errno(retsts);
1557        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1558     }
1559     else {
1560       /* We reset error values on success because Perl does an hv_fetch()
1561        * before each hv_store(), and if the thing we're setting didn't
1562        * previously exist, we've got a leftover error message.  (Of course,
1563        * this fails in the face of
1564        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1565        * in that the error reported in $! isn't spurious,
1566        * but it's right more often than not.)
1567        */
1568       set_errno(0); set_vaxc_errno(retsts);
1569       return 0;
1570     }
1571
1572 }  /* end of vmssetenv() */
1573 /*}}}*/
1574
1575 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1576 /* This has to be a function since there's a prototype for it in proto.h */
1577 void
1578 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1579 {
1580     if (lnm && *lnm) {
1581       int len = strlen(lnm);
1582       if  (len == 7) {
1583         char uplnm[8];
1584         int i;
1585         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1586         if (!strcmp(uplnm,"DEFAULT")) {
1587           if (eqv && *eqv) my_chdir(eqv);
1588           return;
1589         }
1590     }
1591 #ifndef RTL_USES_UTC
1592     if (len == 6 || len == 2) {
1593       char uplnm[7];
1594       int i;
1595       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1596       uplnm[len] = '\0';
1597       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1598       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1599     }
1600 #endif
1601   }
1602   (void) vmssetenv(lnm,eqv,NULL);
1603 }
1604 /*}}}*/
1605
1606 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1607 /*  vmssetuserlnm
1608  *  sets a user-mode logical in the process logical name table
1609  *  used for redirection of sys$error
1610  */
1611 void
1612 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1613 {
1614     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1615     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1616     unsigned long int iss, attr = LNM$M_CONFINE;
1617     unsigned char acmode = PSL$C_USER;
1618     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1619                                  {0, 0, 0, 0}};
1620     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1621     d_name.dsc$w_length = strlen(name);
1622
1623     lnmlst[0].buflen = strlen(eqv);
1624     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1625
1626     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1627     if (!(iss&1)) lib$signal(iss);
1628 }
1629 /*}}}*/
1630
1631
1632 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1633 /* my_crypt - VMS password hashing
1634  * my_crypt() provides an interface compatible with the Unix crypt()
1635  * C library function, and uses sys$hash_password() to perform VMS
1636  * password hashing.  The quadword hashed password value is returned
1637  * as a NUL-terminated 8 character string.  my_crypt() does not change
1638  * the case of its string arguments; in order to match the behavior
1639  * of LOGINOUT et al., alphabetic characters in both arguments must
1640  *  be upcased by the caller.
1641  *
1642  * - fix me to call ACM services when available
1643  */
1644 char *
1645 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1646 {
1647 #   ifndef UAI$C_PREFERRED_ALGORITHM
1648 #     define UAI$C_PREFERRED_ALGORITHM 127
1649 #   endif
1650     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1651     unsigned short int salt = 0;
1652     unsigned long int sts;
1653     struct const_dsc {
1654         unsigned short int dsc$w_length;
1655         unsigned char      dsc$b_type;
1656         unsigned char      dsc$b_class;
1657         const char *       dsc$a_pointer;
1658     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1659        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1660     struct itmlst_3 uailst[3] = {
1661         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1662         { sizeof salt, UAI$_SALT,    &salt, 0},
1663         { 0,           0,            NULL,  NULL}};
1664     static char hash[9];
1665
1666     usrdsc.dsc$w_length = strlen(usrname);
1667     usrdsc.dsc$a_pointer = usrname;
1668     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1669       switch (sts) {
1670         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1671           set_errno(EACCES);
1672           break;
1673         case RMS$_RNF:
1674           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1675           break;
1676         default:
1677           set_errno(EVMSERR);
1678       }
1679       set_vaxc_errno(sts);
1680       if (sts != RMS$_RNF) return NULL;
1681     }
1682
1683     txtdsc.dsc$w_length = strlen(textpasswd);
1684     txtdsc.dsc$a_pointer = textpasswd;
1685     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1686       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1687     }
1688
1689     return (char *) hash;
1690
1691 }  /* end of my_crypt() */
1692 /*}}}*/
1693
1694
1695 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1696 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1697 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1698
1699 /* fixup barenames that are directories for internal use.
1700  * There have been problems with the consistent handling of UNIX
1701  * style directory names when routines are presented with a name that
1702  * has no directory delimitors at all.  So this routine will eventually
1703  * fix the issue.
1704  */
1705 static char * fixup_bare_dirnames(const char * name)
1706 {
1707   if (decc_disable_to_vms_logname_translation) {
1708 /* fix me */
1709   }
1710   return NULL;
1711 }
1712
1713 /* mp_do_kill_file
1714  * A little hack to get around a bug in some implemenation of remove()
1715  * that do not know how to delete a directory
1716  *
1717  * Delete any file to which user has control access, regardless of whether
1718  * delete access is explicitly allowed.
1719  * Limitations: User must have write access to parent directory.
1720  *              Does not block signals or ASTs; if interrupted in midstream
1721  *              may leave file with an altered ACL.
1722  * HANDLE WITH CARE!
1723  */
1724 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1725 static int
1726 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1727 {
1728     char *vmsname, *rspec;
1729     char *remove_name;
1730     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1731     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1732     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1733     struct myacedef {
1734       unsigned char myace$b_length;
1735       unsigned char myace$b_type;
1736       unsigned short int myace$w_flags;
1737       unsigned long int myace$l_access;
1738       unsigned long int myace$l_ident;
1739     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1740                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1741       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1742      struct itmlst_3
1743        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1744                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1745        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1746        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1747        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1748        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1749
1750     /* Expand the input spec using RMS, since the CRTL remove() and
1751      * system services won't do this by themselves, so we may miss
1752      * a file "hiding" behind a logical name or search list. */
1753     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1754     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1755
1756     if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1757       PerlMem_free(vmsname);
1758       return -1;
1759     }
1760
1761     if (decc_posix_compliant_pathnames) {
1762       /* In POSIX mode, we prefer to remove the UNIX name */
1763       rspec = vmsname;
1764       remove_name = (char *)name;
1765     }
1766     else {
1767       rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1768       if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1769       if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1770         PerlMem_free(rspec);
1771         PerlMem_free(vmsname);
1772         return -1;
1773       }
1774       PerlMem_free(vmsname);
1775       remove_name = rspec;
1776     }
1777
1778 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1779     if (dirflag != 0) {
1780         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1781           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1782           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1783
1784           do_pathify_dirspec(name, remove_name, 0, NULL);
1785           if (!rmdir(remove_name)) {
1786
1787             PerlMem_free(remove_name);
1788             PerlMem_free(rspec);
1789             return 0;   /* Can we just get rid of it? */
1790           }
1791         }
1792         else {
1793           if (!rmdir(remove_name)) {
1794             PerlMem_free(rspec);
1795             return 0;   /* Can we just get rid of it? */
1796           }
1797         }
1798     }
1799     else
1800 #endif
1801       if (!remove(remove_name)) {
1802         PerlMem_free(rspec);
1803         return 0;   /* Can we just get rid of it? */
1804       }
1805
1806     /* If not, can changing protections help? */
1807     if (vaxc$errno != RMS$_PRV) {
1808       PerlMem_free(rspec);
1809       return -1;
1810     }
1811
1812     /* No, so we get our own UIC to use as a rights identifier,
1813      * and the insert an ACE at the head of the ACL which allows us
1814      * to delete the file.
1815      */
1816     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1817     fildsc.dsc$w_length = strlen(rspec);
1818     fildsc.dsc$a_pointer = rspec;
1819     cxt = 0;
1820     newace.myace$l_ident = oldace.myace$l_ident;
1821     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1822       switch (aclsts) {
1823         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1824           set_errno(ENOENT); break;
1825         case RMS$_DIR:
1826           set_errno(ENOTDIR); break;
1827         case RMS$_DEV:
1828           set_errno(ENODEV); break;
1829         case RMS$_SYN: case SS$_INVFILFOROP:
1830           set_errno(EINVAL); break;
1831         case RMS$_PRV:
1832           set_errno(EACCES); break;
1833         default:
1834           _ckvmssts(aclsts);
1835       }
1836       set_vaxc_errno(aclsts);
1837       PerlMem_free(rspec);
1838       return -1;
1839     }
1840     /* Grab any existing ACEs with this identifier in case we fail */
1841     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1842     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1843                     || fndsts == SS$_NOMOREACE ) {
1844       /* Add the new ACE . . . */
1845       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1846         goto yourroom;
1847
1848 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1849       if (dirflag != 0)
1850         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1851           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1852           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1853
1854           do_pathify_dirspec(name, remove_name, 0, NULL);
1855           rmsts = rmdir(remove_name);
1856           PerlMem_free(remove_name);
1857         }
1858         else {
1859         rmsts = rmdir(remove_name);
1860         }
1861       else
1862 #endif
1863         rmsts = remove(remove_name);
1864       if (rmsts) {
1865         /* We blew it - dir with files in it, no write priv for
1866          * parent directory, etc.  Put things back the way they were. */
1867         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1868           goto yourroom;
1869         if (fndsts & 1) {
1870           addlst[0].bufadr = &oldace;
1871           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1872             goto yourroom;
1873         }
1874       }
1875     }
1876
1877     yourroom:
1878     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1879     /* We just deleted it, so of course it's not there.  Some versions of
1880      * VMS seem to return success on the unlock operation anyhow (after all
1881      * the unlock is successful), but others don't.
1882      */
1883     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1884     if (aclsts & 1) aclsts = fndsts;
1885     if (!(aclsts & 1)) {
1886       set_errno(EVMSERR);
1887       set_vaxc_errno(aclsts);
1888       PerlMem_free(rspec);
1889       return -1;
1890     }
1891
1892     PerlMem_free(rspec);
1893     return rmsts;
1894
1895 }  /* end of kill_file() */
1896 /*}}}*/
1897
1898
1899 /*{{{int do_rmdir(char *name)*/
1900 int
1901 Perl_do_rmdir(pTHX_ const char *name)
1902 {
1903     char dirfile[NAM$C_MAXRSS+1];
1904     int retval;
1905     Stat_t st;
1906
1907     if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1908     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1909     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1910     return retval;
1911
1912 }  /* end of do_rmdir */
1913 /*}}}*/
1914
1915 /* kill_file
1916  * Delete any file to which user has control access, regardless of whether
1917  * delete access is explicitly allowed.
1918  * Limitations: User must have write access to parent directory.
1919  *              Does not block signals or ASTs; if interrupted in midstream
1920  *              may leave file with an altered ACL.
1921  * HANDLE WITH CARE!
1922  */
1923 /*{{{int kill_file(char *name)*/
1924 int
1925 Perl_kill_file(pTHX_ const char *name)
1926 {
1927     char rspec[NAM$C_MAXRSS+1];
1928     char *tspec;
1929     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1930     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1931     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1932     struct myacedef {
1933       unsigned char myace$b_length;
1934       unsigned char myace$b_type;
1935       unsigned short int myace$w_flags;
1936       unsigned long int myace$l_access;
1937       unsigned long int myace$l_ident;
1938     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1939                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1940       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1941      struct itmlst_3
1942        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1943                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1944        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1945        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1946        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1947        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1948
1949     /* Expand the input spec using RMS, since the CRTL remove() and
1950      * system services won't do this by themselves, so we may miss
1951      * a file "hiding" behind a logical name or search list. */
1952     tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1953     if (tspec == NULL) return -1;
1954     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1955     /* If not, can changing protections help? */
1956     if (vaxc$errno != RMS$_PRV) return -1;
1957
1958     /* No, so we get our own UIC to use as a rights identifier,
1959      * and the insert an ACE at the head of the ACL which allows us
1960      * to delete the file.
1961      */
1962     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1963     fildsc.dsc$w_length = strlen(rspec);
1964     fildsc.dsc$a_pointer = rspec;
1965     cxt = 0;
1966     newace.myace$l_ident = oldace.myace$l_ident;
1967     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1968       switch (aclsts) {
1969         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1970           set_errno(ENOENT); break;
1971         case RMS$_DIR:
1972           set_errno(ENOTDIR); break;
1973         case RMS$_DEV:
1974           set_errno(ENODEV); break;
1975         case RMS$_SYN: case SS$_INVFILFOROP:
1976           set_errno(EINVAL); break;
1977         case RMS$_PRV:
1978           set_errno(EACCES); break;
1979         default:
1980           _ckvmssts(aclsts);
1981       }
1982       set_vaxc_errno(aclsts);
1983       return -1;
1984     }
1985     /* Grab any existing ACEs with this identifier in case we fail */
1986     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1987     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1988                     || fndsts == SS$_NOMOREACE ) {
1989       /* Add the new ACE . . . */
1990       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1991         goto yourroom;
1992       if ((rmsts = remove(name))) {
1993         /* We blew it - dir with files in it, no write priv for
1994          * parent directory, etc.  Put things back the way they were. */
1995         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1996           goto yourroom;
1997         if (fndsts & 1) {
1998           addlst[0].bufadr = &oldace;
1999           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2000             goto yourroom;
2001         }
2002       }
2003     }
2004
2005     yourroom:
2006     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2007     /* We just deleted it, so of course it's not there.  Some versions of
2008      * VMS seem to return success on the unlock operation anyhow (after all
2009      * the unlock is successful), but others don't.
2010      */
2011     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2012     if (aclsts & 1) aclsts = fndsts;
2013     if (!(aclsts & 1)) {
2014       set_errno(EVMSERR);
2015       set_vaxc_errno(aclsts);
2016       return -1;
2017     }
2018
2019     return rmsts;
2020
2021 }  /* end of kill_file() */
2022 /*}}}*/
2023
2024
2025 /*{{{int my_mkdir(char *,Mode_t)*/
2026 int
2027 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2028 {
2029   STRLEN dirlen = strlen(dir);
2030
2031   /* zero length string sometimes gives ACCVIO */
2032   if (dirlen == 0) return -1;
2033
2034   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2035    * null file name/type.  However, it's commonplace under Unix,
2036    * so we'll allow it for a gain in portability.
2037    */
2038   if (dir[dirlen-1] == '/') {
2039     char *newdir = savepvn(dir,dirlen-1);
2040     int ret = mkdir(newdir,mode);
2041     Safefree(newdir);
2042     return ret;
2043   }
2044   else return mkdir(dir,mode);
2045 }  /* end of my_mkdir */
2046 /*}}}*/
2047
2048 /*{{{int my_chdir(char *)*/
2049 int
2050 Perl_my_chdir(pTHX_ const char *dir)
2051 {
2052   STRLEN dirlen = strlen(dir);
2053
2054   /* zero length string sometimes gives ACCVIO */
2055   if (dirlen == 0) return -1;
2056   const char *dir1;
2057
2058   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2059    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2060    * so that existing scripts do not need to be changed.
2061    */
2062   dir1 = dir;
2063   while ((dirlen > 0) && (*dir1 == ' ')) {
2064     dir1++;
2065     dirlen--;
2066   }
2067
2068   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2069    * that implies
2070    * null file name/type.  However, it's commonplace under Unix,
2071    * so we'll allow it for a gain in portability.
2072    *
2073    * - Preview- '/' will be valid soon on VMS
2074    */
2075   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2076     char *newdir = savepvn(dir1,dirlen-1);
2077     int ret = chdir(newdir);
2078     Safefree(newdir);
2079     return ret;
2080   }
2081   else return chdir(dir1);
2082 }  /* end of my_chdir */
2083 /*}}}*/
2084
2085
2086 /*{{{FILE *my_tmpfile()*/
2087 FILE *
2088 my_tmpfile(void)
2089 {
2090   FILE *fp;
2091   char *cp;
2092
2093   if ((fp = tmpfile())) return fp;
2094
2095   cp = PerlMem_malloc(L_tmpnam+24);
2096   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2097
2098   if (decc_filename_unix_only == 0)
2099     strcpy(cp,"Sys$Scratch:");
2100   else
2101     strcpy(cp,"/tmp/");
2102   tmpnam(cp+strlen(cp));
2103   strcat(cp,".Perltmp");
2104   fp = fopen(cp,"w+","fop=dlt");
2105   PerlMem_free(cp);
2106   return fp;
2107 }
2108 /*}}}*/
2109
2110
2111 #ifndef HOMEGROWN_POSIX_SIGNALS
2112 /*
2113  * The C RTL's sigaction fails to check for invalid signal numbers so we
2114  * help it out a bit.  The docs are correct, but the actual routine doesn't
2115  * do what the docs say it will.
2116  */
2117 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2118 int
2119 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2120                    struct sigaction* oact)
2121 {
2122   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2123         SETERRNO(EINVAL, SS$_INVARG);
2124         return -1;
2125   }
2126   return sigaction(sig, act, oact);
2127 }
2128 /*}}}*/
2129 #endif
2130
2131 #ifdef KILL_BY_SIGPRC
2132 #include <errnodef.h>
2133
2134 /* We implement our own kill() using the undocumented system service
2135    sys$sigprc for one of two reasons:
2136
2137    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2138    target process to do a sys$exit, which usually can't be handled
2139    gracefully...certainly not by Perl and the %SIG{} mechanism.
2140
2141    2.) If the kill() in the CRTL can't be called from a signal
2142    handler without disappearing into the ether, i.e., the signal
2143    it purportedly sends is never trapped. Still true as of VMS 7.3.
2144
2145    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2146    in the target process rather than calling sys$exit.
2147
2148    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2149    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2150    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2151    with condition codes C$_SIG0+nsig*8, catching the exception on the
2152    target process and resignaling with appropriate arguments.
2153
2154    But we don't have that VMS 7.0+ exception handler, so if you
2155    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2156
2157    Also note that SIGTERM is listed in the docs as being "unimplemented",
2158    yet always seems to be signaled with a VMS condition code of 4 (and
2159    correctly handled for that code).  So we hardwire it in.
2160
2161    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2162    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2163    than signalling with an unrecognized (and unhandled by CRTL) code.
2164 */
2165
2166 #define _MY_SIG_MAX 28
2167
2168 static unsigned int
2169 Perl_sig_to_vmscondition_int(int sig)
2170 {
2171     static unsigned int sig_code[_MY_SIG_MAX+1] =
2172     {
2173         0,                  /*  0 ZERO     */
2174         SS$_HANGUP,         /*  1 SIGHUP   */
2175         SS$_CONTROLC,       /*  2 SIGINT   */
2176         SS$_CONTROLY,       /*  3 SIGQUIT  */
2177         SS$_RADRMOD,        /*  4 SIGILL   */
2178         SS$_BREAK,          /*  5 SIGTRAP  */
2179         SS$_OPCCUS,         /*  6 SIGABRT  */
2180         SS$_COMPAT,         /*  7 SIGEMT   */
2181 #ifdef __VAX
2182         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2183 #else
2184         SS$_HPARITH,        /*  8 SIGFPE AXP */
2185 #endif
2186         SS$_ABORT,          /*  9 SIGKILL  */
2187         SS$_ACCVIO,         /* 10 SIGBUS   */
2188         SS$_ACCVIO,         /* 11 SIGSEGV  */
2189         SS$_BADPARAM,       /* 12 SIGSYS   */
2190         SS$_NOMBX,          /* 13 SIGPIPE  */
2191         SS$_ASTFLT,         /* 14 SIGALRM  */
2192         4,                  /* 15 SIGTERM  */
2193         0,                  /* 16 SIGUSR1  */
2194         0,                  /* 17 SIGUSR2  */
2195         0,                  /* 18 */
2196         0,                  /* 19 */
2197         0,                  /* 20 SIGCHLD  */
2198         0,                  /* 21 SIGCONT  */
2199         0,                  /* 22 SIGSTOP  */
2200         0,                  /* 23 SIGTSTP  */
2201         0,                  /* 24 SIGTTIN  */
2202         0,                  /* 25 SIGTTOU  */
2203         0,                  /* 26 */
2204         0,                  /* 27 */
2205         0                   /* 28 SIGWINCH  */
2206     };
2207
2208 #if __VMS_VER >= 60200000
2209     static int initted = 0;
2210     if (!initted) {
2211         initted = 1;
2212         sig_code[16] = C$_SIGUSR1;
2213         sig_code[17] = C$_SIGUSR2;
2214 #if __CRTL_VER >= 70000000
2215         sig_code[20] = C$_SIGCHLD;
2216 #endif
2217 #if __CRTL_VER >= 70300000
2218         sig_code[28] = C$_SIGWINCH;
2219 #endif
2220     }
2221 #endif
2222
2223     if (sig < _SIG_MIN) return 0;
2224     if (sig > _MY_SIG_MAX) return 0;
2225     return sig_code[sig];
2226 }
2227
2228 unsigned int
2229 Perl_sig_to_vmscondition(int sig)
2230 {
2231 #ifdef SS$_DEBUG
2232     if (vms_debug_on_exception != 0)
2233         lib$signal(SS$_DEBUG);
2234 #endif
2235     return Perl_sig_to_vmscondition_int(sig);
2236 }
2237
2238
2239 int
2240 Perl_my_kill(int pid, int sig)
2241 {
2242     dTHX;
2243     int iss;
2244     unsigned int code;
2245     int sys$sigprc(unsigned int *pidadr,
2246                      struct dsc$descriptor_s *prcname,
2247                      unsigned int code);
2248
2249      /* sig 0 means validate the PID */
2250     /*------------------------------*/
2251     if (sig == 0) {
2252         const unsigned long int jpicode = JPI$_PID;
2253         pid_t ret_pid;
2254         int status;
2255         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2256         if ($VMS_STATUS_SUCCESS(status))
2257            return 0;
2258         switch (status) {
2259         case SS$_NOSUCHNODE:
2260         case SS$_UNREACHABLE:
2261         case SS$_NONEXPR:
2262            errno = ESRCH;
2263            break;
2264         case SS$_NOPRIV:
2265            errno = EPERM;
2266            break;
2267         default:
2268            errno = EVMSERR;
2269         }
2270         vaxc$errno=status;
2271         return -1;
2272     }
2273
2274     code = Perl_sig_to_vmscondition_int(sig);
2275
2276     if (!code) {
2277         SETERRNO(EINVAL, SS$_BADPARAM);
2278         return -1;
2279     }
2280
2281     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2282      * signals are to be sent to multiple processes.
2283      *  pid = 0 - all processes in group except ones that the system exempts
2284      *  pid = -1 - all processes except ones that the system exempts
2285      *  pid = -n - all processes in group (abs(n)) except ...
2286      * For now, just report as not supported.
2287      */
2288
2289     if (pid <= 0) {
2290         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2291         return -1;
2292     }
2293
2294     iss = sys$sigprc((unsigned int *)&pid,0,code);
2295     if (iss&1) return 0;
2296
2297     switch (iss) {
2298       case SS$_NOPRIV:
2299         set_errno(EPERM);  break;
2300       case SS$_NONEXPR:
2301       case SS$_NOSUCHNODE:
2302       case SS$_UNREACHABLE:
2303         set_errno(ESRCH);  break;
2304       case SS$_INSFMEM:
2305         set_errno(ENOMEM); break;
2306       default:
2307         _ckvmssts(iss);
2308         set_errno(EVMSERR);
2309     }
2310     set_vaxc_errno(iss);
2311
2312     return -1;
2313 }
2314 #endif
2315
2316 /* Routine to convert a VMS status code to a UNIX status code.
2317 ** More tricky than it appears because of conflicting conventions with
2318 ** existing code.
2319 **
2320 ** VMS status codes are a bit mask, with the least significant bit set for
2321 ** success.
2322 **
2323 ** Special UNIX status of EVMSERR indicates that no translation is currently
2324 ** available, and programs should check the VMS status code.
2325 **
2326 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2327 ** decoding.
2328 */
2329
2330 #ifndef C_FACILITY_NO
2331 #define C_FACILITY_NO 0x350000
2332 #endif
2333 #ifndef DCL_IVVERB
2334 #define DCL_IVVERB 0x38090
2335 #endif
2336
2337 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2338 {
2339 int facility;
2340 int fac_sp;
2341 int msg_no;
2342 int msg_status;
2343 int unix_status;
2344
2345   /* Assume the best or the worst */
2346   if (vms_status & STS$M_SUCCESS)
2347     unix_status = 0;
2348   else
2349     unix_status = EVMSERR;
2350
2351   msg_status = vms_status & ~STS$M_CONTROL;
2352
2353   facility = vms_status & STS$M_FAC_NO;
2354   fac_sp = vms_status & STS$M_FAC_SP;
2355   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2356
2357   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2358     switch(msg_no) {
2359     case SS$_NORMAL:
2360         unix_status = 0;
2361         break;
2362     case SS$_ACCVIO:
2363         unix_status = EFAULT;
2364         break;
2365     case SS$_DEVOFFLINE:
2366         unix_status = EBUSY;
2367         break;
2368     case SS$_CLEARED:
2369         unix_status = ENOTCONN;
2370         break;
2371     case SS$_IVCHAN:
2372     case SS$_IVLOGNAM:
2373     case SS$_BADPARAM:
2374     case SS$_IVLOGTAB:
2375     case SS$_NOLOGNAM:
2376     case SS$_NOLOGTAB:
2377     case SS$_INVFILFOROP:
2378     case SS$_INVARG:
2379     case SS$_NOSUCHID:
2380     case SS$_IVIDENT:
2381         unix_status = EINVAL;
2382         break;
2383     case SS$_UNSUPPORTED:
2384         unix_status = ENOTSUP;
2385         break;
2386     case SS$_FILACCERR:
2387     case SS$_NOGRPPRV:
2388     case SS$_NOSYSPRV:
2389         unix_status = EACCES;
2390         break;
2391     case SS$_DEVICEFULL:
2392         unix_status = ENOSPC;
2393         break;
2394     case SS$_NOSUCHDEV:
2395         unix_status = ENODEV;
2396         break;
2397     case SS$_NOSUCHFILE:
2398     case SS$_NOSUCHOBJECT:
2399         unix_status = ENOENT;
2400         break;
2401     case SS$_ABORT:                                 /* Fatal case */
2402     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2403     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2404         unix_status = EINTR;
2405         break;
2406     case SS$_BUFFEROVF:
2407         unix_status = E2BIG;
2408         break;
2409     case SS$_INSFMEM:
2410         unix_status = ENOMEM;
2411         break;
2412     case SS$_NOPRIV:
2413         unix_status = EPERM;
2414         break;
2415     case SS$_NOSUCHNODE:
2416     case SS$_UNREACHABLE:
2417         unix_status = ESRCH;
2418         break;
2419     case SS$_NONEXPR:
2420         unix_status = ECHILD;
2421         break;
2422     default:
2423         if ((facility == 0) && (msg_no < 8)) {
2424           /* These are not real VMS status codes so assume that they are
2425           ** already UNIX status codes
2426           */
2427           unix_status = msg_no;
2428           break;
2429         }
2430     }
2431   }
2432   else {
2433     /* Translate a POSIX exit code to a UNIX exit code */
2434     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2435         unix_status = (msg_no & 0x07F8) >> 3;
2436     }
2437     else {
2438
2439          /* Documented traditional behavior for handling VMS child exits */
2440         /*--------------------------------------------------------------*/
2441         if (child_flag != 0) {
2442
2443              /* Success / Informational return 0 */
2444             /*----------------------------------*/
2445             if (msg_no & STS$K_SUCCESS)
2446                 return 0;
2447
2448              /* Warning returns 1 */
2449             /*-------------------*/
2450             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2451                 return 1;
2452
2453              /* Everything else pass through the severity bits */
2454             /*------------------------------------------------*/
2455             return (msg_no & STS$M_SEVERITY);
2456         }
2457
2458          /* Normal VMS status to ERRNO mapping attempt */
2459         /*--------------------------------------------*/
2460         switch(msg_status) {
2461         /* case RMS$_EOF: */ /* End of File */
2462         case RMS$_FNF:  /* File Not Found */
2463         case RMS$_DNF:  /* Dir Not Found */
2464                 unix_status = ENOENT;
2465                 break;
2466         case RMS$_RNF:  /* Record Not Found */
2467                 unix_status = ESRCH;
2468                 break;
2469         case RMS$_DIR:
2470                 unix_status = ENOTDIR;
2471                 break;
2472         case RMS$_DEV:
2473                 unix_status = ENODEV;
2474                 break;
2475         case RMS$_IFI:
2476         case RMS$_FAC:
2477         case RMS$_ISI:
2478                 unix_status = EBADF;
2479                 break;
2480         case RMS$_FEX:
2481                 unix_status = EEXIST;
2482                 break;
2483         case RMS$_SYN:
2484         case RMS$_FNM:
2485         case LIB$_INVSTRDES:
2486         case LIB$_INVARG:
2487         case LIB$_NOSUCHSYM:
2488         case LIB$_INVSYMNAM:
2489         case DCL_IVVERB:
2490                 unix_status = EINVAL;
2491                 break;
2492         case CLI$_BUFOVF:
2493         case RMS$_RTB:
2494         case CLI$_TKNOVF:
2495         case CLI$_RSLOVF:
2496                 unix_status = E2BIG;
2497                 break;
2498         case RMS$_PRV:  /* No privilege */
2499         case RMS$_ACC:  /* ACP file access failed */
2500         case RMS$_WLK:  /* Device write locked */
2501                 unix_status = EACCES;
2502                 break;
2503         /* case RMS$_NMF: */  /* No more files */
2504         }
2505     }
2506   }
2507
2508   return unix_status;
2509 }
2510
2511 /* Try to guess at what VMS error status should go with a UNIX errno
2512  * value.  This is hard to do as there could be many possible VMS
2513  * error statuses that caused the errno value to be set.
2514  */
2515
2516 int Perl_unix_status_to_vms(int unix_status)
2517 {
2518 int test_unix_status;
2519
2520      /* Trivial cases first */
2521     /*---------------------*/
2522     if (unix_status == EVMSERR)
2523         return vaxc$errno;
2524
2525      /* Is vaxc$errno sane? */
2526     /*---------------------*/
2527     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2528     if (test_unix_status == unix_status)
2529         return vaxc$errno;
2530
2531      /* If way out of range, must be VMS code already */
2532     /*-----------------------------------------------*/
2533     if (unix_status > EVMSERR)
2534         return unix_status;
2535
2536      /* If out of range, punt */
2537     /*-----------------------*/
2538     if (unix_status > __ERRNO_MAX)
2539         return SS$_ABORT;
2540
2541
2542      /* Ok, now we have to do it the hard way. */
2543     /*----------------------------------------*/
2544     switch(unix_status) {
2545     case 0:     return SS$_NORMAL;
2546     case EPERM: return SS$_NOPRIV;
2547     case ENOENT: return SS$_NOSUCHOBJECT;
2548     case ESRCH: return SS$_UNREACHABLE;
2549     case EINTR: return SS$_ABORT;
2550     /* case EIO: */
2551     /* case ENXIO:  */
2552     case E2BIG: return SS$_BUFFEROVF;
2553     /* case ENOEXEC */
2554     case EBADF: return RMS$_IFI;
2555     case ECHILD: return SS$_NONEXPR;
2556     /* case EAGAIN */
2557     case ENOMEM: return SS$_INSFMEM;
2558     case EACCES: return SS$_FILACCERR;
2559     case EFAULT: return SS$_ACCVIO;
2560     /* case ENOTBLK */
2561     case EBUSY: return SS$_DEVOFFLINE;
2562     case EEXIST: return RMS$_FEX;
2563     /* case EXDEV */
2564     case ENODEV: return SS$_NOSUCHDEV;
2565     case ENOTDIR: return RMS$_DIR;
2566     /* case EISDIR */
2567     case EINVAL: return SS$_INVARG;
2568     /* case ENFILE */
2569     /* case EMFILE */
2570     /* case ENOTTY */
2571     /* case ETXTBSY */
2572     /* case EFBIG */
2573     case ENOSPC: return SS$_DEVICEFULL;
2574     case ESPIPE: return LIB$_INVARG;
2575     /* case EROFS: */
2576     /* case EMLINK: */
2577     /* case EPIPE: */
2578     /* case EDOM */
2579     case ERANGE: return LIB$_INVARG;
2580     /* case EWOULDBLOCK */
2581     /* case EINPROGRESS */
2582     /* case EALREADY */
2583     /* case ENOTSOCK */
2584     /* case EDESTADDRREQ */
2585     /* case EMSGSIZE */
2586     /* case EPROTOTYPE */
2587     /* case ENOPROTOOPT */
2588     /* case EPROTONOSUPPORT */
2589     /* case ESOCKTNOSUPPORT */
2590     /* case EOPNOTSUPP */
2591     /* case EPFNOSUPPORT */
2592     /* case EAFNOSUPPORT */
2593     /* case EADDRINUSE */
2594     /* case EADDRNOTAVAIL */
2595     /* case ENETDOWN */
2596     /* case ENETUNREACH */
2597     /* case ENETRESET */
2598     /* case ECONNABORTED */
2599     /* case ECONNRESET */
2600     /* case ENOBUFS */
2601     /* case EISCONN */
2602     case ENOTCONN: return SS$_CLEARED;
2603     /* case ESHUTDOWN */
2604     /* case ETOOMANYREFS */
2605     /* case ETIMEDOUT */
2606     /* case ECONNREFUSED */
2607     /* case ELOOP */
2608     /* case ENAMETOOLONG */
2609     /* case EHOSTDOWN */
2610     /* case EHOSTUNREACH */
2611     /* case ENOTEMPTY */
2612     /* case EPROCLIM */
2613     /* case EUSERS  */
2614     /* case EDQUOT  */
2615     /* case ENOMSG  */
2616     /* case EIDRM */
2617     /* case EALIGN */
2618     /* case ESTALE */
2619     /* case EREMOTE */
2620     /* case ENOLCK */
2621     /* case ENOSYS */
2622     /* case EFTYPE */
2623     /* case ECANCELED */
2624     /* case EFAIL */
2625     /* case EINPROG */
2626     case ENOTSUP:
2627         return SS$_UNSUPPORTED;
2628     /* case EDEADLK */
2629     /* case ENWAIT */
2630     /* case EILSEQ */
2631     /* case EBADCAT */
2632     /* case EBADMSG */
2633     /* case EABANDONED */
2634     default:
2635         return SS$_ABORT; /* punt */
2636     }
2637
2638   return SS$_ABORT; /* Should not get here */
2639 }
2640
2641
2642 /* default piping mailbox size */
2643 #define PERL_BUFSIZ        512
2644
2645
2646 static void
2647 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2648 {
2649   unsigned long int mbxbufsiz;
2650   static unsigned long int syssize = 0;
2651   unsigned long int dviitm = DVI$_DEVNAM;
2652   char csize[LNM$C_NAMLENGTH+1];
2653   int sts;
2654
2655   if (!syssize) {
2656     unsigned long syiitm = SYI$_MAXBUF;
2657     /*
2658      * Get the SYSGEN parameter MAXBUF
2659      *
2660      * If the logical 'PERL_MBX_SIZE' is defined
2661      * use the value of the logical instead of PERL_BUFSIZ, but
2662      * keep the size between 128 and MAXBUF.
2663      *
2664      */
2665     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2666   }
2667
2668   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2669       mbxbufsiz = atoi(csize);
2670   } else {
2671       mbxbufsiz = PERL_BUFSIZ;
2672   }
2673   if (mbxbufsiz < 128) mbxbufsiz = 128;
2674   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2675
2676   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2677
2678   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2679   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2680
2681 }  /* end of create_mbx() */
2682
2683
2684 /*{{{  my_popen and my_pclose*/
2685
2686 typedef struct _iosb           IOSB;
2687 typedef struct _iosb*         pIOSB;
2688 typedef struct _pipe           Pipe;
2689 typedef struct _pipe*         pPipe;
2690 typedef struct pipe_details    Info;
2691 typedef struct pipe_details*  pInfo;
2692 typedef struct _srqp            RQE;
2693 typedef struct _srqp*          pRQE;
2694 typedef struct _tochildbuf      CBuf;
2695 typedef struct _tochildbuf*    pCBuf;
2696
2697 struct _iosb {
2698     unsigned short status;
2699     unsigned short count;
2700     unsigned long  dvispec;
2701 };
2702
2703 #pragma member_alignment save
2704 #pragma nomember_alignment quadword
2705 struct _srqp {          /* VMS self-relative queue entry */
2706     unsigned long qptr[2];
2707 };
2708 #pragma member_alignment restore
2709 static RQE  RQE_ZERO = {0,0};
2710
2711 struct _tochildbuf {
2712     RQE             q;
2713     int             eof;
2714     unsigned short  size;
2715     char            *buf;
2716 };
2717
2718 struct _pipe {
2719     RQE            free;
2720     RQE            wait;
2721     int            fd_out;
2722     unsigned short chan_in;
2723     unsigned short chan_out;
2724     char          *buf;
2725     unsigned int   bufsize;
2726     IOSB           iosb;
2727     IOSB           iosb2;
2728     int           *pipe_done;
2729     int            retry;
2730     int            type;
2731     int            shut_on_empty;
2732     int            need_wake;
2733     pPipe         *home;
2734     pInfo          info;
2735     pCBuf          curr;
2736     pCBuf          curr2;
2737 #if defined(PERL_IMPLICIT_CONTEXT)
2738     void            *thx;           /* Either a thread or an interpreter */
2739                                     /* pointer, depending on how we're built */
2740 #endif
2741 };
2742
2743
2744 struct pipe_details
2745 {
2746     pInfo           next;
2747     PerlIO *fp;  /* file pointer to pipe mailbox */
2748     int useFILE; /* using stdio, not perlio */
2749     int pid;   /* PID of subprocess */
2750     int mode;  /* == 'r' if pipe open for reading */
2751     int done;  /* subprocess has completed */
2752     int waiting; /* waiting for completion/closure */
2753     int             closing;        /* my_pclose is closing this pipe */
2754     unsigned long   completion;     /* termination status of subprocess */
2755     pPipe           in;             /* pipe in to sub */
2756     pPipe           out;            /* pipe out of sub */
2757     pPipe           err;            /* pipe of sub's sys$error */
2758     int             in_done;        /* true when in pipe finished */
2759     int             out_done;
2760     int             err_done;
2761 };
2762
2763 struct exit_control_block
2764 {
2765     struct exit_control_block *flink;
2766     unsigned long int   (*exit_routine)();
2767     unsigned long int arg_count;
2768     unsigned long int *status_address;
2769     unsigned long int exit_status;
2770 };
2771
2772 typedef struct _closed_pipes    Xpipe;
2773 typedef struct _closed_pipes*  pXpipe;
2774
2775 struct _closed_pipes {
2776     int             pid;            /* PID of subprocess */
2777     unsigned long   completion;     /* termination status of subprocess */
2778 };
2779 #define NKEEPCLOSED 50
2780 static Xpipe closed_list[NKEEPCLOSED];
2781 static int   closed_index = 0;
2782 static int   closed_num = 0;
2783
2784 #define RETRY_DELAY     "0 ::0.20"
2785 #define MAX_RETRY              50
2786
2787 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2788 static unsigned long mypid;
2789 static unsigned long delaytime[2];
2790
2791 static pInfo open_pipes = NULL;
2792 static $DESCRIPTOR(nl_desc, "NL:");
2793
2794 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2795
2796
2797
2798 static unsigned long int
2799 pipe_exit_routine(pTHX)
2800 {
2801     pInfo info;
2802     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2803     int sts, did_stuff, need_eof, j;
2804
2805     /*
2806         flush any pending i/o
2807     */
2808     info = open_pipes;
2809     while (info) {
2810         if (info->fp) {
2811            if (!info->useFILE)
2812                PerlIO_flush(info->fp);   /* first, flush data */
2813            else
2814                fflush((FILE *)info->fp);
2815         }
2816         info = info->next;
2817     }
2818
2819     /*
2820      next we try sending an EOF...ignore if doesn't work, make sure we
2821      don't hang
2822     */
2823     did_stuff = 0;
2824     info = open_pipes;
2825
2826     while (info) {
2827       int need_eof;
2828       _ckvmssts_noperl(sys$setast(0));
2829       if (info->in && !info->in->shut_on_empty) {
2830         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2831                           0, 0, 0, 0, 0, 0));
2832         info->waiting = 1;
2833         did_stuff = 1;
2834       }
2835       _ckvmssts_noperl(sys$setast(1));
2836       info = info->next;
2837     }
2838
2839     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2840
2841     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2842         int nwait = 0;
2843
2844         info = open_pipes;
2845         while (info) {
2846           _ckvmssts_noperl(sys$setast(0));
2847           if (info->waiting && info->done)
2848                 info->waiting = 0;
2849           nwait += info->waiting;
2850           _ckvmssts_noperl(sys$setast(1));
2851           info = info->next;
2852         }
2853         if (!nwait) break;
2854         sleep(1);
2855     }
2856
2857     did_stuff = 0;
2858     info = open_pipes;
2859     while (info) {
2860       _ckvmssts_noperl(sys$setast(0));
2861       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2862         sts = sys$forcex(&info->pid,0,&abort);
2863         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2864         did_stuff = 1;
2865       }
2866       _ckvmssts_noperl(sys$setast(1));
2867       info = info->next;
2868     }
2869
2870     /* again, wait for effect */
2871
2872     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2873         int nwait = 0;
2874
2875         info = open_pipes;
2876         while (info) {
2877           _ckvmssts_noperl(sys$setast(0));
2878           if (info->waiting && info->done)
2879                 info->waiting = 0;
2880           nwait += info->waiting;
2881           _ckvmssts_noperl(sys$setast(1));
2882           info = info->next;
2883         }
2884         if (!nwait) break;
2885         sleep(1);
2886     }
2887
2888     info = open_pipes;
2889     while (info) {
2890       _ckvmssts_noperl(sys$setast(0));
2891       if (!info->done) {  /* We tried to be nice . . . */
2892         sts = sys$delprc(&info->pid,0);
2893         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2894       }
2895       _ckvmssts_noperl(sys$setast(1));
2896       info = info->next;
2897     }
2898
2899     while(open_pipes) {
2900       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2901       else if (!(sts & 1)) retsts = sts;
2902     }
2903     return retsts;
2904 }
2905
2906 static struct exit_control_block pipe_exitblock =
2907        {(struct exit_control_block *) 0,
2908         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2909
2910 static void pipe_mbxtofd_ast(pPipe p);
2911 static void pipe_tochild1_ast(pPipe p);
2912 static void pipe_tochild2_ast(pPipe p);
2913
2914 static void
2915 popen_completion_ast(pInfo info)
2916 {
2917   pInfo i = open_pipes;
2918   int iss;
2919   int sts;
2920   pXpipe x;
2921
2922   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2923   closed_list[closed_index].pid = info->pid;
2924   closed_list[closed_index].completion = info->completion;
2925   closed_index++;
2926   if (closed_index == NKEEPCLOSED)
2927     closed_index = 0;
2928   closed_num++;
2929
2930   while (i) {
2931     if (i == info) break;
2932     i = i->next;
2933   }
2934   if (!i) return;       /* unlinked, probably freed too */
2935
2936   info->done = TRUE;
2937
2938 /*
2939     Writing to subprocess ...
2940             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2941
2942             chan_out may be waiting for "done" flag, or hung waiting
2943             for i/o completion to child...cancel the i/o.  This will
2944             put it into "snarf mode" (done but no EOF yet) that discards
2945             input.
2946
2947     Output from subprocess (stdout, stderr) needs to be flushed and
2948     shut down.   We try sending an EOF, but if the mbx is full the pipe
2949     routine should still catch the "shut_on_empty" flag, telling it to
2950     use immediate-style reads so that "mbx empty" -> EOF.
2951
2952
2953 */
2954   if (info->in && !info->in_done) {               /* only for mode=w */
2955         if (info->in->shut_on_empty && info->in->need_wake) {
2956             info->in->need_wake = FALSE;
2957             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2958         } else {
2959             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2960         }
2961   }
2962
2963   if (info->out && !info->out_done) {             /* were we also piping output? */
2964       info->out->shut_on_empty = TRUE;
2965       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2966       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2967       _ckvmssts_noperl(iss);
2968   }
2969
2970   if (info->err && !info->err_done) {        /* we were piping stderr */
2971         info->err->shut_on_empty = TRUE;
2972         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2973         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2974         _ckvmssts_noperl(iss);
2975   }
2976   _ckvmssts_noperl(sys$setef(pipe_ef));
2977
2978 }
2979
2980 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2981 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2982
2983 /*
2984     we actually differ from vmstrnenv since we use this to
2985     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2986     are pointing to the same thing
2987 */
2988
2989 static unsigned short
2990 popen_translate(pTHX_ char *logical, char *result)
2991 {
2992     int iss;
2993     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2994     $DESCRIPTOR(d_log,"");
2995     struct _il3 {
2996         unsigned short length;
2997         unsigned short code;
2998         char *         buffer_addr;
2999         unsigned short *retlenaddr;
3000     } itmlst[2];
3001     unsigned short l, ifi;
3002
3003     d_log.dsc$a_pointer = logical;
3004     d_log.dsc$w_length  = strlen(logical);
3005
3006     itmlst[0].code = LNM$_STRING;
3007     itmlst[0].length = 255;
3008     itmlst[0].buffer_addr = result;
3009     itmlst[0].retlenaddr = &l;
3010
3011     itmlst[1].code = 0;
3012     itmlst[1].length = 0;
3013     itmlst[1].buffer_addr = 0;
3014     itmlst[1].retlenaddr = 0;
3015
3016     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3017     if (iss == SS$_NOLOGNAM) {
3018         iss = SS$_NORMAL;
3019         l = 0;
3020     }
3021     if (!(iss&1)) lib$signal(iss);
3022     result[l] = '\0';
3023 /*
3024     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3025     strip it off and return the ifi, if any
3026 */
3027     ifi  = 0;
3028     if (result[0] == 0x1b && result[1] == 0x00) {
3029         memmove(&ifi,result+2,2);
3030         strcpy(result,result+4);
3031     }
3032     return ifi;     /* this is the RMS internal file id */
3033 }
3034
3035 static void pipe_infromchild_ast(pPipe p);
3036
3037 /*
3038     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3039     inside an AST routine without worrying about reentrancy and which Perl
3040     memory allocator is being used.
3041
3042     We read data and queue up the buffers, then spit them out one at a
3043     time to the output mailbox when the output mailbox is ready for one.
3044
3045 */
3046 #define INITIAL_TOCHILDQUEUE  2
3047
3048 static pPipe
3049 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3050 {
3051     pPipe p;
3052     pCBuf b;
3053     char mbx1[64], mbx2[64];
3054     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3055                                       DSC$K_CLASS_S, mbx1},
3056                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3057                                       DSC$K_CLASS_S, mbx2};
3058     unsigned int dviitm = DVI$_DEVBUFSIZ;
3059     int j, n;
3060
3061     n = sizeof(Pipe);
3062     _ckvmssts(lib$get_vm(&n, &p));
3063
3064     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3065     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3066     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3067
3068     p->buf           = 0;
3069     p->shut_on_empty = FALSE;
3070     p->need_wake     = FALSE;
3071     p->type          = 0;
3072     p->retry         = 0;
3073     p->iosb.status   = SS$_NORMAL;
3074     p->iosb2.status  = SS$_NORMAL;
3075     p->free          = RQE_ZERO;
3076     p->wait          = RQE_ZERO;
3077     p->curr          = 0;
3078     p->curr2         = 0;
3079     p->info          = 0;
3080 #ifdef PERL_IMPLICIT_CONTEXT
3081     p->thx           = aTHX;
3082 #endif
3083
3084     n = sizeof(CBuf) + p->bufsize;
3085
3086     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3087         _ckvmssts(lib$get_vm(&n, &b));
3088         b->buf = (char *) b + sizeof(CBuf);
3089         _ckvmssts(lib$insqhi(b, &p->free));
3090     }
3091
3092     pipe_tochild2_ast(p);
3093     pipe_tochild1_ast(p);
3094     strcpy(wmbx, mbx1);
3095     strcpy(rmbx, mbx2);
3096     return p;
3097 }
3098
3099 /*  reads the MBX Perl is writing, and queues */
3100
3101 static void
3102 pipe_tochild1_ast(pPipe p)
3103 {
3104     pCBuf b = p->curr;
3105     int iss = p->iosb.status;
3106     int eof = (iss == SS$_ENDOFFILE);
3107     int sts;
3108 #ifdef PERL_IMPLICIT_CONTEXT
3109     pTHX = p->thx;
3110 #endif
3111
3112     if (p->retry) {
3113         if (eof) {
3114             p->shut_on_empty = TRUE;
3115             b->eof     = TRUE;
3116             _ckvmssts(sys$dassgn(p->chan_in));
3117         } else  {
3118             _ckvmssts(iss);
3119         }
3120
3121         b->eof  = eof;
3122         b->size = p->iosb.count;
3123         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3124         if (p->need_wake) {
3125             p->need_wake = FALSE;
3126             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3127         }
3128     } else {
3129         p->retry = 1;   /* initial call */
3130     }
3131
3132     if (eof) {                  /* flush the free queue, return when done */
3133         int n = sizeof(CBuf) + p->bufsize;
3134         while (1) {
3135             iss = lib$remqti(&p->free, &b);
3136             if (iss == LIB$_QUEWASEMP) return;
3137             _ckvmssts(iss);
3138             _ckvmssts(lib$free_vm(&n, &b));
3139         }
3140     }
3141
3142     iss = lib$remqti(&p->free, &b);
3143     if (iss == LIB$_QUEWASEMP) {
3144         int n = sizeof(CBuf) + p->bufsize;
3145         _ckvmssts(lib$get_vm(&n, &b));
3146         b->buf = (char *) b + sizeof(CBuf);
3147     } else {
3148        _ckvmssts(iss);
3149     }
3150
3151     p->curr = b;
3152     iss = sys$qio(0,p->chan_in,
3153              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3154              &p->iosb,
3155              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3156     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3157     _ckvmssts(iss);
3158 }
3159
3160
3161 /* writes queued buffers to output, waits for each to complete before
3162    doing the next */
3163
3164 static void
3165 pipe_tochild2_ast(pPipe p)
3166 {
3167     pCBuf b = p->curr2;
3168     int iss = p->iosb2.status;
3169     int n = sizeof(CBuf) + p->bufsize;
3170     int done = (p->info && p->info->done) ||
3171               iss == SS$_CANCEL || iss == SS$_ABORT;
3172 #if defined(PERL_IMPLICIT_CONTEXT)
3173     pTHX = p->thx;
3174 #endif
3175
3176     do {
3177         if (p->type) {         /* type=1 has old buffer, dispose */
3178             if (p->shut_on_empty) {
3179                 _ckvmssts(lib$free_vm(&n, &b));
3180             } else {
3181                 _ckvmssts(lib$insqhi(b, &p->free));
3182             }
3183             p->type = 0;
3184         }
3185
3186         iss = lib$remqti(&p->wait, &b);
3187         if (iss == LIB$_QUEWASEMP) {
3188             if (p->shut_on_empty) {
3189                 if (done) {
3190                     _ckvmssts(sys$dassgn(p->chan_out));
3191                     *p->pipe_done = TRUE;
3192                     _ckvmssts(sys$setef(pipe_ef));
3193                 } else {
3194                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3195                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3196                 }
3197                 return;
3198             }
3199             p->need_wake = TRUE;
3200             return;
3201         }
3202         _ckvmssts(iss);
3203         p->type = 1;
3204     } while (done);
3205
3206
3207     p->curr2 = b;
3208     if (b->eof) {
3209         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3210             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3211     } else {
3212         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3213             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3214     }
3215
3216     return;
3217
3218 }
3219
3220
3221 static pPipe
3222 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3223 {
3224     pPipe p;
3225     char mbx1[64], mbx2[64];
3226     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3227                                       DSC$K_CLASS_S, mbx1},
3228                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3229                                       DSC$K_CLASS_S, mbx2};
3230     unsigned int dviitm = DVI$_DEVBUFSIZ;
3231
3232     int n = sizeof(Pipe);
3233     _ckvmssts(lib$get_vm(&n, &p));
3234     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3235     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3236
3237     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3238     n = p->bufsize * sizeof(char);
3239     _ckvmssts(lib$get_vm(&n, &p->buf));
3240     p->shut_on_empty = FALSE;
3241     p->info   = 0;
3242     p->type   = 0;
3243     p->iosb.status = SS$_NORMAL;
3244 #if defined(PERL_IMPLICIT_CONTEXT)
3245     p->thx = aTHX;
3246 #endif
3247     pipe_infromchild_ast(p);
3248
3249     strcpy(wmbx, mbx1);
3250     strcpy(rmbx, mbx2);
3251     return p;
3252 }
3253
3254 static void
3255 pipe_infromchild_ast(pPipe p)
3256 {
3257     int iss = p->iosb.status;
3258     int eof = (iss == SS$_ENDOFFILE);
3259     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3260     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3261 #if defined(PERL_IMPLICIT_CONTEXT)
3262     pTHX = p->thx;
3263 #endif
3264
3265     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3266         _ckvmssts(sys$dassgn(p->chan_out));
3267         p->chan_out = 0;
3268     }
3269
3270     /* read completed:
3271             input shutdown if EOF from self (done or shut_on_empty)
3272             output shutdown if closing flag set (my_pclose)
3273             send data/eof from child or eof from self
3274             otherwise, re-read (snarf of data from child)
3275     */
3276
3277     if (p->type == 1) {
3278         p->type = 0;
3279         if (myeof && p->chan_in) {                  /* input shutdown */
3280             _ckvmssts(sys$dassgn(p->chan_in));
3281             p->chan_in = 0;
3282         }
3283
3284         if (p->chan_out) {
3285             if (myeof || kideof) {      /* pass EOF to parent */
3286                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3287                               pipe_infromchild_ast, p,
3288                               0, 0, 0, 0, 0, 0));
3289                 return;
3290             } else if (eof) {       /* eat EOF --- fall through to read*/
3291
3292             } else {                /* transmit data */
3293                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3294                               pipe_infromchild_ast,p,
3295                               p->buf, p->iosb.count, 0, 0, 0, 0));
3296                 return;
3297             }
3298         }
3299     }
3300
3301     /*  everything shut? flag as done */
3302
3303     if (!p->chan_in && !p->chan_out) {
3304         *p->pipe_done = TRUE;
3305         _ckvmssts(sys$setef(pipe_ef));
3306         return;
3307     }
3308
3309     /* write completed (or read, if snarfing from child)
3310             if still have input active,
3311                queue read...immediate mode if shut_on_empty so we get EOF if empty
3312             otherwise,
3313                check if Perl reading, generate EOFs as needed
3314     */
3315
3316     if (p->type == 0) {
3317         p->type = 1;
3318         if (p->chan_in) {
3319             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3320                           pipe_infromchild_ast,p,
3321                           p->buf, p->bufsize, 0, 0, 0, 0);
3322             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3323             _ckvmssts(iss);
3324         } else {           /* send EOFs for extra reads */
3325             p->iosb.status = SS$_ENDOFFILE;
3326             p->iosb.dvispec = 0;
3327             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3328                       0, 0, 0,
3329                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3330         }
3331     }
3332 }
3333
3334 static pPipe
3335 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3336 {
3337     pPipe p;
3338     char mbx[64];
3339     unsigned long dviitm = DVI$_DEVBUFSIZ;
3340     struct stat s;
3341     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3342                                       DSC$K_CLASS_S, mbx};
3343     int n = sizeof(Pipe);
3344
3345     /* things like terminals and mbx's don't need this filter */
3346     if (fd && fstat(fd,&s) == 0) {
3347         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3348         char device[65];
3349         unsigned short dev_len;
3350         struct dsc$descriptor_s d_dev;
3351         char * cptr;
3352         struct item_list_3 items[3];
3353         int status;
3354         unsigned short dvi_iosb[4];
3355
3356         cptr = getname(fd, out, 1);
3357         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3358         d_dev.dsc$a_pointer = out;
3359         d_dev.dsc$w_length = strlen(out);
3360         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3361         d_dev.dsc$b_class = DSC$K_CLASS_S;
3362
3363         items[0].len = 4;
3364         items[0].code = DVI$_DEVCHAR;
3365         items[0].bufadr = &devchar;
3366         items[0].retadr = NULL;
3367         items[1].len = 64;
3368         items[1].code = DVI$_FULLDEVNAM;
3369         items[1].bufadr = device;
3370         items[1].retadr = &dev_len;
3371         items[2].len = 0;
3372         items[2].code = 0;
3373
3374         status = sys$getdviw
3375                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3376         _ckvmssts(status);
3377         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3378             device[dev_len] = 0;
3379
3380             if (!(devchar & DEV$M_DIR)) {
3381                 strcpy(out, device);
3382                 return 0;
3383             }
3384         }
3385     }
3386
3387     _ckvmssts(lib$get_vm(&n, &p));
3388     p->fd_out = dup(fd);
3389     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3390     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3391     n = (p->bufsize+1) * sizeof(char);
3392     _ckvmssts(lib$get_vm(&n, &p->buf));
3393     p->shut_on_empty = FALSE;
3394     p->retry = 0;
3395     p->info  = 0;
3396     strcpy(out, mbx);
3397
3398     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3399                   pipe_mbxtofd_ast, p,
3400                   p->buf, p->bufsize, 0, 0, 0, 0));
3401
3402     return p;
3403 }
3404
3405 static void
3406 pipe_mbxtofd_ast(pPipe p)
3407 {
3408     int iss = p->iosb.status;
3409     int done = p->info->done;
3410     int iss2;
3411     int eof = (iss == SS$_ENDOFFILE);
3412     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3413     int err = !(iss&1) && !eof;
3414 #if defined(PERL_IMPLICIT_CONTEXT)
3415     pTHX = p->thx;
3416 #endif
3417
3418     if (done && myeof) {               /* end piping */
3419         close(p->fd_out);
3420         sys$dassgn(p->chan_in);
3421         *p->pipe_done = TRUE;
3422         _ckvmssts(sys$setef(pipe_ef));
3423         return;
3424     }
3425
3426     if (!err && !eof) {             /* good data to send to file */
3427         p->buf[p->iosb.count] = '\n';
3428         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3429         if (iss2 < 0) {
3430             p->retry++;
3431             if (p->retry < MAX_RETRY) {
3432                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3433                 return;
3434             }
3435         }
3436         p->retry = 0;
3437     } else if (err) {
3438         _ckvmssts(iss);
3439     }
3440
3441
3442     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3443           pipe_mbxtofd_ast, p,
3444           p->buf, p->bufsize, 0, 0, 0, 0);
3445     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3446     _ckvmssts(iss);
3447 }
3448
3449
3450 typedef struct _pipeloc     PLOC;
3451 typedef struct _pipeloc*   pPLOC;
3452
3453 struct _pipeloc {
3454     pPLOC   next;
3455     char    dir[NAM$C_MAXRSS+1];
3456 };
3457 static pPLOC  head_PLOC = 0;
3458
3459 void
3460 free_pipelocs(pTHX_ void *head)
3461 {
3462     pPLOC p, pnext;
3463     pPLOC *pHead = (pPLOC *)head;
3464
3465     p = *pHead;
3466     while (p) {
3467         pnext = p->next;
3468         PerlMem_free(p);
3469         p = pnext;
3470     }
3471     *pHead = 0;
3472 }
3473
3474 static void
3475 store_pipelocs(pTHX)
3476 {
3477     int    i;
3478     pPLOC  p;
3479     AV    *av = 0;
3480     SV    *dirsv;
3481     GV    *gv;
3482     char  *dir, *x;
3483     char  *unixdir;
3484     char  temp[NAM$C_MAXRSS+1];
3485     STRLEN n_a;
3486
3487     if (head_PLOC)
3488         free_pipelocs(aTHX_ &head_PLOC);
3489
3490 /*  the . directory from @INC comes last */
3491
3492     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3493     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3494     p->next = head_PLOC;
3495     head_PLOC = p;
3496     strcpy(p->dir,"./");
3497
3498 /*  get the directory from $^X */
3499
3500     unixdir = PerlMem_malloc(VMS_MAXRSS);
3501     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3502
3503 #ifdef PERL_IMPLICIT_CONTEXT
3504     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3505 #else
3506     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3507 #endif
3508         strcpy(temp, PL_origargv[0]);
3509         x = strrchr(temp,']');
3510         if (x == NULL) {
3511         x = strrchr(temp,'>');
3512           if (x == NULL) {
3513             /* It could be a UNIX path */
3514             x = strrchr(temp,'/');
3515           }
3516         }
3517         if (x)
3518           x[1] = '\0';
3519         else {
3520           /* Got a bare name, so use default directory */
3521           temp[0] = '.';
3522           temp[1] = '\0';
3523         }
3524
3525         if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3526             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3527             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3528             p->next = head_PLOC;
3529             head_PLOC = p;
3530             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3531             p->dir[NAM$C_MAXRSS] = '\0';
3532         }
3533     }
3534
3535 /*  reverse order of @INC entries, skip "." since entered above */
3536
3537 #ifdef PERL_IMPLICIT_CONTEXT
3538     if (aTHX)
3539 #endif
3540     if (PL_incgv) av = GvAVn(PL_incgv);
3541
3542     for (i = 0; av && i <= AvFILL(av); i++) {
3543         dirsv = *av_fetch(av,i,TRUE);
3544
3545         if (SvROK(dirsv)) continue;
3546         dir = SvPVx(dirsv,n_a);
3547         if (strcmp(dir,".") == 0) continue;
3548         if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3549             continue;
3550
3551         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3552         p->next = head_PLOC;
3553         head_PLOC = p;
3554         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3555         p->dir[NAM$C_MAXRSS] = '\0';
3556     }
3557
3558 /* most likely spot (ARCHLIB) put first in the list */
3559
3560 #ifdef ARCHLIB_EXP
3561     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3562         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3563         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3564         p->next = head_PLOC;
3565         head_PLOC = p;
3566         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3567         p->dir[NAM$C_MAXRSS] = '\0';
3568     }
3569 #endif
3570     PerlMem_free(unixdir);
3571 }
3572
3573 static I32
3574 Perl_cando_by_name_int
3575    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3576 #if !defined(PERL_IMPLICIT_CONTEXT)
3577 #define cando_by_name_int               Perl_cando_by_name_int
3578 #else
3579 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3580 #endif
3581
3582 static char *
3583 find_vmspipe(pTHX)
3584 {
3585     static int   vmspipe_file_status = 0;
3586     static char  vmspipe_file[NAM$C_MAXRSS+1];
3587
3588     /* already found? Check and use ... need read+execute permission */
3589
3590     if (vmspipe_file_status == 1) {
3591         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3592          && cando_by_name_int
3593            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3594             return vmspipe_file;
3595         }
3596         vmspipe_file_status = 0;
3597     }
3598
3599     /* scan through stored @INC, $^X */
3600
3601     if (vmspipe_file_status == 0) {
3602         char file[NAM$C_MAXRSS+1];
3603         pPLOC  p = head_PLOC;
3604
3605         while (p) {
3606             char * exp_res;
3607             int dirlen;
3608             strcpy(file, p->dir);
3609             dirlen = strlen(file);
3610             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3611             file[NAM$C_MAXRSS] = '\0';
3612             p = p->next;
3613
3614             exp_res = do_rmsexpand
3615                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3616             if (!exp_res) continue;
3617
3618             if (cando_by_name_int
3619                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3620              && cando_by_name_int
3621                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3622                 vmspipe_file_status = 1;
3623                 return vmspipe_file;
3624             }
3625         }
3626         vmspipe_file_status = -1;   /* failed, use tempfiles */
3627     }
3628
3629     return 0;
3630 }
3631
3632 static FILE *
3633 vmspipe_tempfile(pTHX)
3634 {
3635     char file[NAM$C_MAXRSS+1];
3636     FILE *fp;
3637     static int index = 0;
3638     Stat_t s0, s1;
3639     int cmp_result;
3640
3641     /* create a tempfile */
3642
3643     /* we can't go from   W, shr=get to  R, shr=get without
3644        an intermediate vulnerable state, so don't bother trying...
3645
3646        and lib$spawn doesn't shr=put, so have to close the write
3647
3648        So... match up the creation date/time and the FID to
3649        make sure we're dealing with the same file
3650
3651     */
3652
3653     index++;
3654     if (!decc_filename_unix_only) {
3655       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3656       fp = fopen(file,"w");
3657       if (!fp) {
3658         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3659         fp = fopen(file,"w");
3660         if (!fp) {
3661             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3662             fp = fopen(file,"w");
3663         }
3664       }
3665      }
3666      else {
3667       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3668       fp = fopen(file,"w");
3669       if (!fp) {
3670         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3671         fp = fopen(file,"w");
3672         if (!fp) {
3673           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3674           fp = fopen(file,"w");
3675         }
3676       }
3677     }
3678     if (!fp) return 0;  /* we're hosed */
3679
3680     fprintf(fp,"$! 'f$verify(0)'\n");
3681     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3682     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3683     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3684     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3685     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3686     fprintf(fp,"$ perl_del    = \"delete\"\n");
3687     fprintf(fp,"$ pif         = \"if\"\n");
3688     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3689     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3690     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3691     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3692     fprintf(fp,"$!  --- build command line to get max possible length\n");
3693     fprintf(fp,"$c=perl_popen_cmd0\n");
3694     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3695     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3696     fprintf(fp,"$x=perl_popen_cmd3\n");
3697     fprintf(fp,"$c=c+x\n");
3698     fprintf(fp,"$ perl_on\n");
3699     fprintf(fp,"$ 'c'\n");
3700     fprintf(fp,"$ perl_status = $STATUS\n");
3701     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3702     fprintf(fp,"$ perl_exit 'perl_status'\n");
3703     fsync(fileno(fp));
3704
3705     fgetname(fp, file, 1);
3706     fstat(fileno(fp), (struct stat *)&s0);
3707     fclose(fp);
3708
3709     if (decc_filename_unix_only)
3710         do_tounixspec(file, file, 0, NULL);
3711     fp = fopen(file,"r","shr=get");
3712     if (!fp) return 0;
3713     fstat(fileno(fp), (struct stat *)&s1);
3714
3715     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3716     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3717         fclose(fp);
3718         return 0;
3719     }
3720
3721     return fp;
3722 }
3723
3724
3725
3726 static PerlIO *
3727 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3728 {
3729     static int handler_set_up = FALSE;
3730     unsigned long int sts, flags = CLI$M_NOWAIT;
3731     /* The use of a GLOBAL table (as was done previously) rendered
3732      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3733      * environment.  Hence we've switched to LOCAL symbol table.
3734      */
3735     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3736     int j, wait = 0, n;
3737     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3738     char *in, *out, *err, mbx[512];
3739     FILE *tpipe = 0;
3740     char tfilebuf[NAM$C_MAXRSS+1];
3741     pInfo info = NULL;
3742     char cmd_sym_name[20];
3743     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3744                                       DSC$K_CLASS_S, symbol};
3745     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3746                                       DSC$K_CLASS_S, 0};
3747     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3748                                       DSC$K_CLASS_S, cmd_sym_name};
3749     struct dsc$descriptor_s *vmscmd;
3750     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3751     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3752     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3753
3754     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
3755
3756     /* once-per-program initialization...
3757        note that the SETAST calls and the dual test of pipe_ef
3758        makes sure that only the FIRST thread through here does
3759        the initialization...all other threads wait until it's
3760        done.
3761
3762        Yeah, uglier than a pthread call, it's got all the stuff inline
3763        rather than in a separate routine.
3764     */
3765
3766     if (!pipe_ef) {
3767         _ckvmssts(sys$setast(0));
3768         if (!pipe_ef) {
3769             unsigned long int pidcode = JPI$_PID;
3770             $DESCRIPTOR(d_delay, RETRY_DELAY);
3771             _ckvmssts(lib$get_ef(&pipe_ef));
3772             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3773             _ckvmssts(sys$bintim(&d_delay, delaytime));
3774         }
3775         if (!handler_set_up) {
3776           _ckvmssts(sys$dclexh(&pipe_exitblock));
3777           handler_set_up = TRUE;
3778         }
3779         _ckvmssts(sys$setast(1));
3780     }
3781
3782     /* see if we can find a VMSPIPE.COM */
3783
3784     tfilebuf[0] = '@';
3785     vmspipe = find_vmspipe(aTHX);
3786     if (vmspipe) {
3787         strcpy(tfilebuf+1,vmspipe);
3788     } else {        /* uh, oh...we're in tempfile hell */
3789         tpipe = vmspipe_tempfile(aTHX);
3790         if (!tpipe) {       /* a fish popular in Boston */
3791             if (ckWARN(WARN_PIPE)) {
3792                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3793             }
3794         return Nullfp;
3795         }
3796         fgetname(tpipe,tfilebuf+1,1);
3797     }
3798     vmspipedsc.dsc$a_pointer = tfilebuf;
3799     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
3800
3801     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3802     if (!(sts & 1)) {
3803       switch (sts) {
3804         case RMS$_FNF:  case RMS$_DNF:
3805           set_errno(ENOENT); break;
3806         case RMS$_DIR:
3807           set_errno(ENOTDIR); break;
3808         case RMS$_DEV:
3809           set_errno(ENODEV); break;
3810         case RMS$_PRV:
3811           set_errno(EACCES); break;
3812         case RMS$_SYN:
3813           set_errno(EINVAL); break;
3814         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3815           set_errno(E2BIG); break;
3816         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3817           _ckvmssts(sts); /* fall through */
3818         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3819           set_errno(EVMSERR);
3820       }
3821       set_vaxc_errno(sts);
3822       if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3823         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3824       }
3825       *psts = sts;
3826       return Nullfp;
3827     }
3828     n = sizeof(Info);
3829     _ckvmssts(lib$get_vm(&n, &info));
3830
3831     strcpy(mode,in_mode);
3832     info->mode = *mode;
3833     info->done = FALSE;
3834     info->completion = 0;
3835     info->closing    = FALSE;
3836     info->in         = 0;
3837     info->out        = 0;
3838     info->err        = 0;
3839     info->fp         = Nullfp;
3840     info->useFILE    = 0;
3841     info->waiting    = 0;
3842     info->in_done    = TRUE;
3843     info->out_done   = TRUE;
3844     info->err_done   = TRUE;
3845
3846     in = PerlMem_malloc(VMS_MAXRSS);
3847     if (in == NULL) _ckvmssts(SS$_INSFMEM);
3848     out = PerlMem_malloc(VMS_MAXRSS);
3849     if (out == NULL) _ckvmssts(SS$_INSFMEM);
3850     err = PerlMem_malloc(VMS_MAXRSS);
3851     if (err == NULL) _ckvmssts(SS$_INSFMEM);
3852
3853     in[0] = out[0] = err[0] = '\0';
3854
3855     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
3856         info->useFILE = 1;
3857         strcpy(p,p+1);
3858     }
3859     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
3860         wait = 1;
3861         strcpy(p,p+1);
3862     }
3863
3864     if (*mode == 'r') {             /* piping from subroutine */
3865
3866         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3867         if (info->out) {
3868             info->out->pipe_done = &info->out_done;
3869             info->out_done = FALSE;
3870             info->out->info = info;
3871         }
3872         if (!info->useFILE) {
3873         info->fp  = PerlIO_open(mbx, mode);
3874         } else {
3875             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3876             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3877         }
3878
3879         if (!info->fp && info->out) {
3880             sys$cancel(info->out->chan_out);
3881
3882             while (!info->out_done) {
3883                 int done;
3884                 _ckvmssts(sys$setast(0));
3885                 done = info->out_done;
3886                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3887                 _ckvmssts(sys$setast(1));
3888                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3889             }
3890
3891             if (info->out->buf) {
3892                 n = info->out->bufsize * sizeof(char);
3893                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3894             }
3895             n = sizeof(Pipe);
3896             _ckvmssts(lib$free_vm(&n, &info->out));
3897             n = sizeof(Info);
3898             _ckvmssts(lib$free_vm(&n, &info));
3899             *psts = RMS$_FNF;
3900             return Nullfp;
3901         }
3902
3903         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3904         if (info->err) {
3905             info->err->pipe_done = &info->err_done;
3906             info->err_done = FALSE;
3907             info->err->info = info;
3908         }
3909
3910     } else if (*mode == 'w') {      /* piping to subroutine */
3911
3912         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3913         if (info->out) {
3914             info->out->pipe_done = &info->out_done;
3915             info->out_done = FALSE;
3916             info->out->info = info;
3917         }
3918
3919         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3920         if (info->err) {
3921             info->err->pipe_done = &info->err_done;
3922             info->err_done = FALSE;
3923             info->err->info = info;
3924         }
3925
3926         info->in = pipe_tochild_setup(aTHX_ in,mbx);
3927         if (!info->useFILE) {
3928             info->fp  = PerlIO_open(mbx, mode);
3929         } else {
3930             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3931             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3932         }
3933
3934         if (info->in) {
3935             info->in->pipe_done = &info->in_done;
3936             info->in_done = FALSE;
3937             info->in->info = info;
3938         }
3939
3940         /* error cleanup */
3941         if (!info->fp && info->in) {
3942             info->done = TRUE;
3943             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3944                               0, 0, 0, 0, 0, 0, 0, 0));
3945
3946             while (!info->in_done) {
3947                 int done;
3948                 _ckvmssts(sys$setast(0));
3949                 done = info->in_done;
3950                 if (!done) _ckvmssts(sys$clref(pipe_ef));
3951                 _ckvmssts(sys$setast(1));
3952                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3953             }
3954
3955             if (info->in->buf) {
3956                 n = info->in->bufsize * sizeof(char);
3957                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3958             }
3959             n = sizeof(Pipe);
3960             _ckvmssts(lib$free_vm(&n, &info->in));
3961             n = sizeof(Info);
3962             _ckvmssts(lib$free_vm(&n, &info));
3963             *psts = RMS$_FNF;
3964             return Nullfp;
3965         }
3966
3967
3968     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
3969         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3970         if (info->out) {
3971             info->out->pipe_done = &info->out_done;
3972             info->out_done = FALSE;
3973             info->out->info = info;
3974         }
3975
3976         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3977         if (info->err) {
3978             info->err->pipe_done = &info->err_done;
3979             info->err_done = FALSE;
3980             info->err->info = info;
3981         }
3982     }
3983
3984     symbol[MAX_DCL_SYMBOL] = '\0';
3985
3986     strncpy(symbol, in, MAX_DCL_SYMBOL);
3987     d_symbol.dsc$w_length = strlen(symbol);
3988     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3989
3990     strncpy(symbol, err, MAX_DCL_SYMBOL);
3991     d_symbol.dsc$w_length = strlen(symbol);
3992     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3993
3994     strncpy(symbol, out, MAX_DCL_SYMBOL);
3995     d_symbol.dsc$w_length = strlen(symbol);
3996     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3997
3998     /* Done with the names for the pipes */
3999     PerlMem_free(err);
4000     PerlMem_free(out);
4001     PerlMem_free(in);
4002
4003     p = vmscmd->dsc$a_pointer;
4004     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4005     if (*p == '$') p++;                         /* remove leading $ */
4006     while (*p == ' ' || *p == '\t') p++;
4007
4008     for (j = 0; j < 4; j++) {
4009         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4010         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4011
4012     strncpy(symbol, p, MAX_DCL_SYMBOL);
4013     d_symbol.dsc$w_length = strlen(symbol);
4014     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4015
4016         if (strlen(p) > MAX_DCL_SYMBOL) {
4017             p += MAX_DCL_SYMBOL;
4018         } else {
4019             p += strlen(p);
4020         }
4021     }
4022     _ckvmssts(sys$setast(0));
4023     info->next=open_pipes;  /* prepend to list */
4024     open_pipes=info;
4025     _ckvmssts(sys$setast(1));
4026     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4027      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4028      * have SYS$COMMAND if we need it.
4029      */
4030     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4031                       0, &info->pid, &info->completion,
4032                       0, popen_completion_ast,info,0,0,0));
4033
4034     /* if we were using a tempfile, close it now */
4035
4036     if (tpipe) fclose(tpipe);
4037
4038     /* once the subprocess is spawned, it has copied the symbols and
4039        we can get rid of ours */
4040
4041     for (j = 0; j < 4; j++) {
4042         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4043         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4044     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4045     }
4046     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4047     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4048     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4049     vms_execfree(vmscmd);
4050
4051 #ifdef PERL_IMPLICIT_CONTEXT
4052     if (aTHX)
4053 #endif
4054     PL_forkprocess = info->pid;
4055
4056     if (wait) {
4057          int done = 0;
4058          while (!done) {
4059              _ckvmssts(sys$setast(0));
4060              done = info->done;
4061              if (!done) _ckvmssts(sys$clref(pipe_ef));
4062              _ckvmssts(sys$setast(1));
4063              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4064          }
4065         *psts = info->completion;
4066 /* Caller thinks it is open and tries to close it. */
4067 /* This causes some problems, as it changes the error status */
4068 /*        my_pclose(info->fp); */
4069     } else {
4070         *psts = SS$_NORMAL;
4071     }
4072     return info->fp;
4073 }  /* end of safe_popen */
4074
4075
4076 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4077 PerlIO *
4078 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4079 {
4080     int sts;
4081     TAINT_ENV();
4082     TAINT_PROPER("popen");
4083     PERL_FLUSHALL_FOR_CHILD;
4084     return safe_popen(aTHX_ cmd,mode,&sts);
4085 }
4086
4087 /*}}}*/
4088
4089 /*{{{  I32 my_pclose(PerlIO *fp)*/
4090 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4091 {
4092     pInfo info, last = NULL;
4093     unsigned long int retsts;
4094     int done, iss, n;
4095
4096     for (info = open_pipes; info != NULL; last = info, info = info->next)
4097         if (info->fp == fp) break;
4098
4099     if (info == NULL) {  /* no such pipe open */
4100       set_errno(ECHILD); /* quoth POSIX */
4101       set_vaxc_errno(SS$_NONEXPR);
4102       return -1;
4103     }
4104
4105     /* If we were writing to a subprocess, insure that someone reading from
4106      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4107      * produce an EOF record in the mailbox.
4108      *
4109      *  well, at least sometimes it *does*, so we have to watch out for
4110      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4111      */
4112      if (info->fp) {
4113         if (!info->useFILE)
4114             PerlIO_flush(info->fp);   /* first, flush data */
4115         else
4116             fflush((FILE *)info->fp);
4117     }
4118
4119     _ckvmssts(sys$setast(0));
4120      info->closing = TRUE;
4121      done = info->done && info->in_done && info->out_done && info->err_done;
4122      /* hanging on write to Perl's input? cancel it */
4123      if (info->mode == 'r' && info->out && !info->out_done) {
4124         if (info->out->chan_out) {
4125             _ckvmssts(sys$cancel(info->out->chan_out));
4126             if (!info->out->chan_in) {   /* EOF generation, need AST */
4127                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4128             }
4129         }
4130      }
4131      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4132          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4133                            0, 0, 0, 0, 0, 0));
4134     _ckvmssts(sys$setast(1));
4135     if (info->fp) {
4136      if (!info->useFILE)
4137         PerlIO_close(info->fp);
4138      else
4139         fclose((FILE *)info->fp);
4140     }
4141      /*
4142         we have to wait until subprocess completes, but ALSO wait until all
4143         the i/o completes...otherwise we'll be freeing the "info" structure
4144         that the i/o ASTs could still be using...
4145      */
4146
4147      while (!done) {
4148          _ckvmssts(sys$setast(0));
4149          done = info->done && info->in_done && info->out_done && info->err_done;
4150          if (!done) _ckvmssts(sys$clref(pipe_ef));
4151          _ckvmssts(sys$setast(1));
4152          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4153      }
4154      retsts = info->completion;
4155
4156     /* remove from list of open pipes */
4157     _ckvmssts(sys$setast(0));
4158     if (last) last->next = info->next;
4159     else open_pipes = info->next;
4160     _ckvmssts(sys$setast(1));
4161
4162     /* free buffers and structures */
4163
4164     if (info->in) {
4165         if (info->in->buf) {
4166             n = info->in->bufsize * sizeof(char);
4167             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4168         }
4169         n = sizeof(Pipe);
4170         _ckvmssts(lib$free_vm(&n, &info->in));
4171     }
4172     if (info->out) {
4173         if (info->out->buf) {
4174             n = info->out->bufsize * sizeof(char);
4175             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4176         }
4177         n = sizeof(Pipe);
4178         _ckvmssts(lib$free_vm(&n, &info->out));
4179     }
4180     if (info->err) {
4181         if (info->err->buf) {
4182             n = info->err->bufsize * sizeof(char);
4183             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4184         }
4185         n = sizeof(Pipe);
4186         _ckvmssts(lib$free_vm(&n, &info->err));
4187     }
4188     n = sizeof(Info);
4189     _ckvmssts(lib$free_vm(&n, &info));
4190
4191     return retsts;
4192
4193 }  /* end of my_pclose() */
4194
4195 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4196   /* Roll our own prototype because we want this regardless of whether
4197    * _VMS_WAIT is defined.
4198    */
4199   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4200 #endif
4201 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4202    created with popen(); otherwise partially emulate waitpid() unless
4203    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4204    Also check processes not considered by the CRTL waitpid().
4205  */
4206 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4207 Pid_t
4208 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4209 {
4210     pInfo info;
4211     int done;
4212     int sts;
4213     int j;
4214
4215     if (statusp) *statusp = 0;
4216
4217     for (info = open_pipes; info != NULL; info = info->next)
4218         if (info->pid == pid) break;
4219
4220     if (info != NULL) {  /* we know about this child */
4221       while (!info->done) {
4222           _ckvmssts(sys$setast(0));
4223           done = info->done;
4224           if (!done) _ckvmssts(sys$clref(pipe_ef));
4225           _ckvmssts(sys$setast(1));
4226           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4227       }
4228
4229       if (statusp) *statusp = info->completion;
4230       return pid;
4231     }
4232
4233     /* child that already terminated? */
4234
4235     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4236         if (closed_list[j].pid == pid) {
4237             if (statusp) *statusp = closed_list[j].completion;
4238             return pid;
4239         }
4240     }
4241
4242     /* fall through if this child is not one of our own pipe children */
4243
4244 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4245
4246       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4247        * in 7.2 did we get a version that fills in the VMS completion
4248        * status as Perl has always tried to do.
4249        */
4250
4251       sts = __vms_waitpid( pid, statusp, flags );
4252
4253       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4254          return sts;
4255
4256       /* If the real waitpid tells us the child does not exist, we
4257        * fall through here to implement waiting for a child that
4258        * was created by some means other than exec() (say, spawned
4259        * from DCL) or to wait for a process that is not a subprocess
4260        * of the current process.
4261        */
4262
4263 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4264
4265     {
4266       $DESCRIPTOR(intdsc,"0 00:00:01");
4267       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4268       unsigned long int pidcode = JPI$_PID, mypid;
4269       unsigned long int interval[2];
4270       unsigned int jpi_iosb[2];
4271       struct itmlst_3 jpilist[2] = {
4272           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4273           {                      0,         0,                 0, 0}
4274       };
4275
4276       if (pid <= 0) {
4277         /* Sorry folks, we don't presently implement rooting around for
4278            the first child we can find, and we definitely don't want to
4279            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4280          */
4281         set_errno(ENOTSUP);
4282         return -1;
4283       }
4284
4285       /* Get the owner of the child so I can warn if it's not mine. If the
4286        * process doesn't exist or I don't have the privs to look at it,
4287        * I can go home early.
4288        */
4289       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4290       if (sts & 1) sts = jpi_iosb[0];
4291       if (!(sts & 1)) {
4292         switch (sts) {
4293             case SS$_NONEXPR:
4294                 set_errno(ECHILD);
4295                 break;
4296             case SS$_NOPRIV:
4297                 set_errno(EACCES);
4298                 break;
4299             default:
4300                 _ckvmssts(sts);
4301         }
4302         set_vaxc_errno(sts);
4303         return -1;
4304       }
4305
4306       if (ckWARN(WARN_EXEC)) {
4307         /* remind folks they are asking for non-standard waitpid behavior */
4308         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4309         if (ownerpid != mypid)
4310           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4311                       "waitpid: process %x is not a child of process %x",
4312                       pid,mypid);
4313       }
4314
4315       /* simply check on it once a second until it's not there anymore. */
4316
4317       _ckvmssts(sys$bintim(&intdsc,interval));
4318       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4319             _ckvmssts(sys$schdwk(0,0,interval,0));
4320             _ckvmssts(sys$hiber());
4321       }
4322       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4323
4324       _ckvmssts(sts);
4325       return pid;
4326     }
4327 }  /* end of waitpid() */
4328 /*}}}*/
4329 /*}}}*/
4330 /*}}}*/
4331
4332 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4333 char *
4334 my_gconvert(double val, int ndig, int trail, char *buf)
4335 {
4336   static char __gcvtbuf[DBL_DIG+1];
4337   char *loc;
4338
4339   loc = buf ? buf : __gcvtbuf;
4340
4341 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4342   if (val < 1) {
4343     sprintf(loc,"%.*g",ndig,val);
4344     return loc;
4345   }
4346 #endif
4347
4348   if (val) {
4349     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4350     return gcvt(val,ndig,loc);
4351   }
4352   else {
4353     loc[0] = '0'; loc[1] = '\0';
4354     return loc;
4355   }
4356
4357 }
4358 /*}}}*/
4359
4360 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4361 static int rms_free_search_context(struct FAB * fab)
4362 {
4363 struct NAM * nam;
4364
4365     nam = fab->fab$l_nam;
4366     nam->nam$b_nop |= NAM$M_SYNCHK;
4367     nam->nam$l_rlf = NULL;
4368     fab->fab$b_dns = 0;
4369     return sys$parse(fab, NULL, NULL);
4370 }
4371
4372 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4373 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4374 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4375 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4376 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4377 #define rms_nam_esll(nam) nam.nam$b_esl
4378 #define rms_nam_esl(nam) nam.nam$b_esl
4379 #define rms_nam_name(nam) nam.nam$l_name
4380 #define rms_nam_namel(nam) nam.nam$l_name
4381 #define rms_nam_type(nam) nam.nam$l_type
4382 #define rms_nam_typel(nam) nam.nam$l_type
4383 #define rms_nam_ver(nam) nam.nam$l_ver
4384 #define rms_nam_verl(nam) nam.nam$l_ver
4385 #define rms_nam_rsll(nam) nam.nam$b_rsl
4386 #define rms_nam_rsl(nam) nam.nam$b_rsl
4387 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4388 #define rms_set_fna(fab, nam, name, size) \
4389         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4390 #define rms_get_fna(fab, nam) fab.fab$l_fna
4391 #define rms_set_dna(fab, nam, name, size) \
4392         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4393 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4394 #define rms_set_esa(fab, nam, name, size) \
4395         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4396 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4397         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4398 #define rms_set_rsa(nam, name, size) \
4399         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4400 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4401         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4402 #define rms_nam_name_type_l_size(nam) \
4403         (nam.nam$b_name + nam.nam$b_type)
4404 #else
4405 static int rms_free_search_context(struct FAB * fab)
4406 {
4407 struct NAML * nam;
4408
4409     nam = fab->fab$l_naml;
4410     nam->naml$b_nop |= NAM$M_SYNCHK;
4411     nam->naml$l_rlf = NULL;
4412     nam->naml$l_long_defname_size = 0;
4413
4414     fab->fab$b_dns = 0;
4415     return sys$parse(fab, NULL, NULL);
4416 }
4417
4418 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4419 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4420 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4421 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4422 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4423 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4424 #define rms_nam_esl(nam) nam.naml$b_esl
4425 #define rms_nam_name(nam) nam.naml$l_name
4426 #define rms_nam_namel(nam) nam.naml$l_long_name
4427 #define rms_nam_type(nam) nam.naml$l_type
4428 #define rms_nam_typel(nam) nam.naml$l_long_type
4429 #define rms_nam_ver(nam) nam.naml$l_ver
4430 #define rms_nam_verl(nam) nam.naml$l_long_ver
4431 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4432 #define rms_nam_rsl(nam) nam.naml$b_rsl
4433 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4434 #define rms_set_fna(fab, nam, name, size) \
4435         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4436         nam.naml$l_long_filename_size = size; \
4437         nam.naml$l_long_filename = name;}
4438 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4439 #define rms_set_dna(fab, nam, name, size) \
4440         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4441         nam.naml$l_long_defname_size = size; \
4442         nam.naml$l_long_defname = name; }
4443 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4444 #define rms_set_esa(fab, nam, name, size) \
4445         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4446         nam.naml$l_long_expand_alloc = size; \
4447         nam.naml$l_long_expand = name; }
4448 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4449         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4450         nam.naml$l_long_expand = l_name; \
4451         nam.naml$l_long_expand_alloc = l_size; }
4452 #define rms_set_rsa(nam, name, size) \
4453         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4454         nam.naml$l_long_result = name; \
4455         nam.naml$l_long_result_alloc = size; }
4456 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4457         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4458         nam.naml$l_long_result = l_name; \
4459         nam.naml$l_long_result_alloc = l_size; }
4460 #define rms_nam_name_type_l_size(nam) \
4461         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4462 #endif
4463
4464
4465 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4466 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4467  * to expand file specification.  Allows for a single default file
4468  * specification and a simple mask of options.  If outbuf is non-NULL,
4469  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4470  * the resultant file specification is placed.  If outbuf is NULL, the
4471  * resultant file specification is placed into a static buffer.
4472  * The third argument, if non-NULL, is taken to be a default file
4473  * specification string.  The fourth argument is unused at present.
4474  * rmesexpand() returns the address of the resultant string if
4475  * successful, and NULL on error.
4476  *
4477  * New functionality for previously unused opts value:
4478  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4479  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
4480  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4481  */
4482 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4483
4484 static char *
4485 mp_do_rmsexpand
4486    (pTHX_ const char *filespec,
4487     char *outbuf,
4488     int ts,
4489     const char *defspec,
4490     unsigned opts,
4491     int * fs_utf8,
4492     int * dfs_utf8)
4493 {
4494   static char __rmsexpand_retbuf[VMS_MAXRSS];
4495   char * vmsfspec, *tmpfspec;
4496   char * esa, *cp, *out = NULL;
4497   char * tbuf;
4498   char * esal;
4499   char * outbufl;
4500   struct FAB myfab = cc$rms_fab;
4501   rms_setup_nam(mynam);
4502   STRLEN speclen;
4503   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4504   int sts;
4505
4506   /* temp hack until UTF8 is actually implemented */
4507   if (fs_utf8 != NULL)
4508     *fs_utf8 = 0;
4509
4510   if (!filespec || !*filespec) {
4511     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4512     return NULL;
4513   }
4514   if (!outbuf) {
4515     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4516     else    outbuf = __rmsexpand_retbuf;
4517   }
4518
4519   vmsfspec = NULL;
4520   tmpfspec = NULL;
4521   outbufl = NULL;
4522
4523   isunix = 0;
4524   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4525     isunix = is_unix_filespec(filespec);
4526     if (isunix) {
4527       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4528       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4529       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4530         PerlMem_free(vmsfspec);
4531         if (out)
4532            Safefree(out);
4533         return NULL;
4534       }
4535       filespec = vmsfspec;
4536
4537       /* Unless we are forcing to VMS format, a UNIX input means
4538        * UNIX output, and that requires long names to be used
4539        */
4540       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4541         opts |= PERL_RMSEXPAND_M_LONG;
4542       else {
4543         isunix = 0;
4544       }
4545     }
4546   }
4547
4548   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4549   rms_bind_fab_nam(myfab, mynam);
4550
4551   if (defspec && *defspec) {
4552     int t_isunix;
4553     t_isunix = is_unix_filespec(defspec);
4554     if (t_isunix) {
4555       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4556       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4557       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4558         PerlMem_free(tmpfspec);
4559         if (vmsfspec != NULL)
4560             PerlMem_free(vmsfspec);
4561         if (out)
4562            Safefree(out);
4563         return NULL;
4564       }
4565       defspec = tmpfspec;
4566     }
4567     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4568   }
4569
4570   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4571   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4572 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4573   esal = PerlMem_malloc(VMS_MAXRSS);
4574   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4575 #endif
4576   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4577
4578   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4579     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4580   }
4581   else {
4582 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4583     outbufl = PerlMem_malloc(VMS_MAXRSS);
4584     if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4585     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4586 #else
4587     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4588 #endif
4589   }
4590
4591 #ifdef NAM$M_NO_SHORT_UPCASE
4592   if (decc_efs_case_preserve)
4593     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4594 #endif
4595
4596   /* First attempt to parse as an existing file */
4597   retsts = sys$parse(&myfab,0,0);
4598   if (!(retsts & STS$K_SUCCESS)) {
4599
4600     /* Could not find the file, try as syntax only if error is not fatal */
4601     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4602     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4603       retsts = sys$parse(&myfab,0,0);
4604       if (retsts & STS$K_SUCCESS) goto expanded;
4605     }
4606
4607      /* Still could not parse the file specification */
4608     /*----------------------------------------------*/
4609     sts = rms_free_search_context(&myfab); /* Free search context */
4610     if (out) Safefree(out);
4611     if (tmpfspec != NULL)
4612         PerlMem_free(tmpfspec);
4613     if (vmsfspec != NULL)
4614         PerlMem_free(vmsfspec);
4615     if (outbufl != NULL)
4616         PerlMem_free(outbufl);
4617     PerlMem_free(esa);
4618     PerlMem_free(esal);
4619     set_vaxc_errno(retsts);
4620     if      (retsts == RMS$_PRV) set_errno(EACCES);
4621     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4622     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4623     else                         set_errno(EVMSERR);
4624     return NULL;
4625   }
4626   retsts = sys$search(&myfab,0,0);
4627   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4628     sts = rms_free_search_context(&myfab); /* Free search context */
4629     if (out) Safefree(out);
4630     if (tmpfspec != NULL)
4631         PerlMem_free(tmpfspec);
4632     if (vmsfspec != NULL)
4633         PerlMem_free(vmsfspec);
4634     if (outbufl != NULL)
4635         PerlMem_free(outbufl);
4636     PerlMem_free(esa);
4637     PerlMem_free(esal);
4638     set_vaxc_errno(retsts);
4639     if      (retsts == RMS$_PRV) set_errno(EACCES);
4640     else                         set_errno(EVMSERR);
4641     return NULL;
4642   }
4643
4644   /* If the input filespec contained any lowercase characters,
4645    * downcase the result for compatibility with Unix-minded code. */
4646   expanded:
4647   if (!decc_efs_case_preserve) {
4648     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4649       if (islower(*tbuf)) { haslower = 1; break; }
4650   }
4651
4652    /* Is a long or a short name expected */
4653   /*------------------------------------*/
4654   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4655     if (rms_nam_rsll(mynam)) {
4656         tbuf = outbuf;
4657         speclen = rms_nam_rsll(mynam);
4658     }
4659     else {
4660         tbuf = esal; /* Not esa */
4661         speclen = rms_nam_esll(mynam);
4662     }
4663   }
4664   else {
4665     if (rms_nam_rsl(mynam)) {
4666         tbuf = outbuf;
4667         speclen = rms_nam_rsl(mynam);
4668     }
4669     else {
4670         tbuf = esa; /* Not esal */
4671         speclen = rms_nam_esl(mynam);
4672     }
4673   }
4674   tbuf[speclen] = '\0';
4675
4676   /* Trim off null fields added by $PARSE
4677    * If type > 1 char, must have been specified in original or default spec
4678    * (not true for version; $SEARCH may have added version of existing file).
4679    */
4680   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4681   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4682     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4683              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4684   }
4685   else {
4686     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4687              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4688   }
4689   if (trimver || trimtype) {
4690     if (defspec && *defspec) {
4691       char *defesal = NULL;
4692       defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4693       if (defesal != NULL) {
4694         struct FAB deffab = cc$rms_fab;
4695         rms_setup_nam(defnam);
4696
4697         rms_bind_fab_nam(deffab, defnam);
4698
4699         /* Cast ok */
4700         rms_set_fna
4701             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4702
4703         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4704
4705         rms_clear_nam_nop(defnam);
4706         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4707 #ifdef NAM$M_NO_SHORT_UPCASE
4708         if (decc_efs_case_preserve)
4709           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4710 #endif
4711         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4712           if (trimver) {
4713              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4714           }
4715           if (trimtype) {
4716             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4717           }
4718         }
4719         PerlMem_free(defesal);
4720       }
4721     }
4722     if (trimver) {
4723       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4724         if (*(rms_nam_verl(mynam)) != '\"')
4725           speclen = rms_nam_verl(mynam) - tbuf;
4726       }
4727       else {
4728         if (*(rms_nam_ver(mynam)) != '\"')
4729           speclen = rms_nam_ver(mynam) - tbuf;
4730       }
4731     }
4732     if (trimtype) {
4733       /* If we didn't already trim version, copy down */
4734       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4735         if (speclen > rms_nam_verl(mynam) - tbuf)
4736           memmove
4737            (rms_nam_typel(mynam),
4738             rms_nam_verl(mynam),
4739             speclen - (rms_nam_verl(mynam) - tbuf));
4740           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4741       }
4742       else {
4743         if (speclen > rms_nam_ver(mynam) - tbuf)
4744           memmove
4745            (rms_nam_type(mynam),
4746             rms_nam_ver(mynam),
4747             speclen - (rms_nam_ver(mynam) - tbuf));
4748           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4749       }
4750     }
4751   }
4752
4753    /* Done with these copies of the input files */
4754   /*-------------------------------------------*/
4755   if (vmsfspec != NULL)
4756         PerlMem_free(vmsfspec);
4757   if (tmpfspec != NULL)
4758         PerlMem_free(tmpfspec);
4759
4760   /* If we just had a directory spec on input, $PARSE "helpfully"
4761    * adds an empty name and type for us */
4762   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4763     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4764         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
4765         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4766       speclen = rms_nam_namel(mynam) - tbuf;
4767   }
4768   else {
4769     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4770         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
4771         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4772       speclen = rms_nam_name(mynam) - tbuf;
4773   }
4774
4775   /* Posix format specifications must have matching quotes */
4776   if (speclen < (VMS_MAXRSS - 1)) {
4777     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
4778       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
4779         tbuf[speclen] = '\"';
4780         speclen++;
4781       }
4782     }
4783   }
4784   tbuf[speclen] = '\0';
4785   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
4786
4787   /* Have we been working with an expanded, but not resultant, spec? */
4788   /* Also, convert back to Unix syntax if necessary. */
4789
4790   if (!rms_nam_rsll(mynam)) {
4791     if (isunix) {
4792       if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
4793         if (out) Safefree(out);
4794         PerlMem_free(esal);
4795         PerlMem_free(esa);
4796         if (outbufl != NULL)
4797             PerlMem_free(outbufl);
4798         return NULL;
4799       }
4800     }
4801     else strcpy(outbuf,esa);
4802   }
4803   else if (isunix) {
4804     tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4805     if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4806     if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
4807         if (out) Safefree(out);
4808         PerlMem_free(esa);
4809         PerlMem_free(esal);
4810         PerlMem_free(tmpfspec);
4811         if (outbufl != NULL)
4812             PerlMem_free(outbufl);
4813         return NULL;
4814     }
4815     strcpy(outbuf,tmpfspec);
4816     PerlMem_free(tmpfspec);
4817   }
4818
4819   rms_set_rsal(mynam, NULL, 0, NULL, 0);
4820   sts = rms_free_search_context(&myfab); /* Free search context */
4821   PerlMem_free(esa);
4822   PerlMem_free(esal);
4823   if (outbufl != NULL)
4824      PerlMem_free(outbufl);
4825   return outbuf;
4826 }
4827 /*}}}*/
4828 /* External entry points */
4829 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4830 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
4831 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4832 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
4833 char *Perl_rmsexpand_utf8
4834   (pTHX_ const char *spec, char *buf, const char *def,
4835    unsigned opt, int * fs_utf8, int * dfs_utf8)
4836 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
4837 char *Perl_rmsexpand_utf8_ts
4838   (pTHX_ const char *spec, char *buf, const char *def,
4839    unsigned opt, int * fs_utf8, int * dfs_utf8)
4840 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
4841
4842
4843 /*
4844 ** The following routines are provided to make life easier when
4845 ** converting among VMS-style and Unix-style directory specifications.
4846 ** All will take input specifications in either VMS or Unix syntax. On
4847 ** failure, all return NULL.  If successful, the routines listed below
4848 ** return a pointer to a buffer containing the appropriately
4849 ** reformatted spec (and, therefore, subsequent calls to that routine
4850 ** will clobber the result), while the routines of the same names with
4851 ** a _ts suffix appended will return a pointer to a mallocd string
4852 ** containing the appropriately reformatted spec.
4853 ** In all cases, only explicit syntax is altered; no check is made that
4854 ** the resulting string is valid or that the directory in question
4855 ** actually exists.
4856 **
4857 **   fileify_dirspec() - convert a directory spec into the name of the
4858 **     directory file (i.e. what you can stat() to see if it's a dir).
4859 **     The style (VMS or Unix) of the result is the same as the style
4860 **     of the parameter passed in.
4861 **   pathify_dirspec() - convert a directory spec into a path (i.e.
4862 **     what you prepend to a filename to indicate what directory it's in).
4863 **     The style (VMS or Unix) of the result is the same as the style
4864 **     of the parameter passed in.
4865 **   tounixpath() - convert a directory spec into a Unix-style path.
4866 **   tovmspath() - convert a directory spec into a VMS-style path.
4867 **   tounixspec() - convert any file spec into a Unix-style file spec.
4868 **   tovmsspec() - convert any file spec into a VMS-style spec.
4869 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
4870 **
4871 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
4872 ** Permission is given to distribute this code as part of the Perl
4873 ** standard distribution under the terms of the GNU General Public
4874 ** License or the Perl Artistic License.  Copies of each may be
4875 ** found in the Perl standard distribution.
4876  */
4877
4878 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
4879 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
4880 {
4881     static char __fileify_retbuf[VMS_MAXRSS];
4882     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4883     char *retspec, *cp1, *cp2, *lastdir;
4884     char *trndir, *vmsdir;
4885     unsigned short int trnlnm_iter_count;
4886     int sts;
4887     if (utf8_fl != NULL)
4888         *utf8_fl = 0;
4889
4890     if (!dir || !*dir) {
4891       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4892     }
4893     dirlen = strlen(dir);
4894     while (dirlen && dir[dirlen-1] == '/') --dirlen;
4895     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4896       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4897         dir = "/sys$disk";
4898         dirlen = 9;
4899       }
4900       else
4901         dirlen = 1;
4902     }
4903     if (dirlen > (VMS_MAXRSS - 1)) {
4904       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4905       return NULL;
4906     }
4907     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
4908     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
4909     if (!strpbrk(dir+1,"/]>:")  &&
4910         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4911       strcpy(trndir,*dir == '/' ? dir + 1: dir);
4912       trnlnm_iter_count = 0;
4913       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4914         trnlnm_iter_count++;
4915         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4916       }
4917       dirlen = strlen(trndir);
4918     }
4919     else {
4920       strncpy(trndir,dir,dirlen);
4921       trndir[dirlen] = '\0';
4922     }
4923
4924     /* At this point we are done with *dir and use *trndir which is a
4925      * copy that can be modified.  *dir must not be modified.
4926      */
4927
4928     /* If we were handed a rooted logical name or spec, treat it like a
4929      * simple directory, so that
4930      *    $ Define myroot dev:[dir.]
4931      *    ... do_fileify_dirspec("myroot",buf,1) ...
4932      * does something useful.
4933      */
4934     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4935       trndir[--dirlen] = '\0';
4936       trndir[dirlen-1] = ']';
4937     }
4938     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4939       trndir[--dirlen] = '\0';
4940       trndir[dirlen-1] = '>';
4941     }
4942
4943     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4944       /* If we've got an explicit filename, we can just shuffle the string. */
4945       if (*(cp1+1)) hasfilename = 1;
4946       /* Similarly, we can just back up a level if we've got multiple levels
4947          of explicit directories in a VMS spec which ends with directories. */
4948       else {
4949         for (cp2 = cp1; cp2 > trndir; cp2--) {
4950           if (*cp2 == '.') {
4951             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4952 /* fix-me, can not scan EFS file specs backward like this */
4953               *cp2 = *cp1; *cp1 = '\0';
4954               hasfilename = 1;
4955               break;
4956             }
4957           }
4958           if (*cp2 == '[' || *cp2 == '<') break;
4959         }
4960       }
4961     }
4962
4963     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
4964     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
4965     cp1 = strpbrk(trndir,"]:>");
4966     if (hasfilename || !cp1) { /* Unix-style path or filename */
4967       if (trndir[0] == '.') {
4968         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4969           PerlMem_free(trndir);
4970           PerlMem_free(vmsdir);
4971           return do_fileify_dirspec("[]",buf,ts,NULL);
4972         }
4973         else if (trndir[1] == '.' &&
4974                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4975           PerlMem_free(trndir);
4976           PerlMem_free(vmsdir);
4977           return do_fileify_dirspec("[-]",buf,ts,NULL);
4978         }
4979       }
4980       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
4981         dirlen -= 1;                 /* to last element */
4982         lastdir = strrchr(trndir,'/');
4983       }
4984       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4985         /* If we have "/." or "/..", VMSify it and let the VMS code
4986          * below expand it, rather than repeating the code to handle
4987          * relative components of a filespec here */
4988         do {
4989           if (*(cp1+2) == '.') cp1++;
4990           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4991             char * ret_chr;
4992             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
4993                 PerlMem_free(trndir);
4994                 PerlMem_free(vmsdir);
4995                 return NULL;
4996             }
4997             if (strchr(vmsdir,'/') != NULL) {
4998               /* If do_tovmsspec() returned it, it must have VMS syntax
4999                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5000                * the time to check this here only so we avoid a recursion
5001                * loop; otherwise, gigo.
5002                */
5003               PerlMem_free(trndir);
5004               PerlMem_free(vmsdir);
5005               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5006               return NULL;
5007             }
5008             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5009                 PerlMem_free(trndir);
5010                 PerlMem_free(vmsdir);
5011                 return NULL;
5012             }
5013             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5014             PerlMem_free(trndir);
5015             PerlMem_free(vmsdir);
5016             return ret_chr;
5017           }
5018           cp1++;
5019         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5020         lastdir = strrchr(trndir,'/');
5021       }
5022       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5023         char * ret_chr;
5024         /* Ditto for specs that end in an MFD -- let the VMS code
5025          * figure out whether it's a real device or a rooted logical. */
5026
5027         /* This should not happen any more.  Allowing the fake /000000
5028          * in a UNIX pathname causes all sorts of problems when trying
5029          * to run in UNIX emulation.  So the VMS to UNIX conversions
5030          * now remove the fake /000000 directories.
5031          */
5032
5033         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5034         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5035             PerlMem_free(trndir);
5036             PerlMem_free(vmsdir);
5037             return NULL;
5038         }
5039         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5040             PerlMem_free(trndir);
5041             PerlMem_free(vmsdir);
5042             return NULL;
5043         }
5044         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5045         PerlMem_free(trndir);
5046         PerlMem_free(vmsdir);
5047         return ret_chr;
5048       }
5049       else {
5050
5051         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5052              !(lastdir = cp1 = strrchr(trndir,']')) &&
5053              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5054         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5055           int ver; char *cp3;
5056
5057           /* For EFS or ODS-5 look for the last dot */
5058           if (decc_efs_charset) {
5059               cp2 = strrchr(cp1,'.');
5060           }
5061           if (vms_process_case_tolerant) {
5062               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5063                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5064                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5065                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5066                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5067                             (ver || *cp3)))))) {
5068                   PerlMem_free(trndir);
5069                   PerlMem_free(vmsdir);
5070                   set_errno(ENOTDIR);
5071                   set_vaxc_errno(RMS$_DIR);
5072                   return NULL;
5073               }
5074           }
5075           else {
5076               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5077                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5078                   !*(cp2+3) || *(cp2+3) != 'R' ||
5079                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5080                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5081                             (ver || *cp3)))))) {
5082                  PerlMem_free(trndir);
5083                  PerlMem_free(vmsdir);
5084                  set_errno(ENOTDIR);
5085                  set_vaxc_errno(RMS$_DIR);
5086                  return NULL;
5087               }
5088           }
5089           dirlen = cp2 - trndir;
5090         }
5091       }
5092
5093       retlen = dirlen + 6;
5094       if (buf) retspec = buf;
5095       else if (ts) Newx(retspec,retlen+1,char);
5096       else retspec = __fileify_retbuf;
5097       memcpy(retspec,trndir,dirlen);
5098       retspec[dirlen] = '\0';
5099
5100       /* We've picked up everything up to the directory file name.
5101          Now just add the type and version, and we're set. */
5102       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5103         strcat(retspec,".dir;1");
5104       else
5105         strcat(retspec,".DIR;1");
5106       PerlMem_free(trndir);
5107       PerlMem_free(vmsdir);
5108       return retspec;
5109     }
5110     else {  /* VMS-style directory spec */
5111
5112       char *esa, term, *cp;
5113       unsigned long int sts, cmplen, haslower = 0;
5114       unsigned int nam_fnb;
5115       char * nam_type;
5116       struct FAB dirfab = cc$rms_fab;
5117       rms_setup_nam(savnam);
5118       rms_setup_nam(dirnam);
5119
5120       esa = PerlMem_malloc(VMS_MAXRSS + 1);
5121       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5122       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5123       rms_bind_fab_nam(dirfab, dirnam);
5124       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5125       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5126 #ifdef NAM$M_NO_SHORT_UPCASE
5127       if (decc_efs_case_preserve)
5128         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5129 #endif
5130
5131       for (cp = trndir; *cp; cp++)
5132         if (islower(*cp)) { haslower = 1; break; }
5133       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5134         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5135           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5136           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5137         }
5138         if (!sts) {
5139           PerlMem_free(esa);
5140           PerlMem_free(trndir);
5141           PerlMem_free(vmsdir);
5142           set_errno(EVMSERR);
5143           set_vaxc_errno(dirfab.fab$l_sts);
5144           return NULL;
5145         }
5146       }
5147       else {
5148         savnam = dirnam;
5149         /* Does the file really exist? */
5150         if (sys$search(&dirfab)& STS$K_SUCCESS) {
5151           /* Yes; fake the fnb bits so we'll check type below */
5152         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5153         }
5154         else { /* No; just work with potential name */
5155           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5156           else {
5157             int fab_sts;
5158             fab_sts = dirfab.fab$l_sts;
5159             sts = rms_free_search_context(&dirfab);
5160             PerlMem_free(esa);
5161             PerlMem_free(trndir);
5162             PerlMem_free(vmsdir);
5163             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
5164             return NULL;
5165           }
5166         }
5167       }
5168       esa[rms_nam_esll(dirnam)] = '\0';
5169       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5170         cp1 = strchr(esa,']');
5171         if (!cp1) cp1 = strchr(esa,'>');
5172         if (cp1) {  /* Should always be true */
5173           rms_nam_esll(dirnam) -= cp1 - esa - 1;
5174           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5175         }
5176       }
5177       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5178         /* Yep; check version while we're at it, if it's there. */
5179         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5180         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5181           /* Something other than .DIR[;1].  Bzzt. */
5182           sts = rms_free_search_context(&dirfab);
5183           PerlMem_free(esa);
5184           PerlMem_free(trndir);
5185           PerlMem_free(vmsdir);
5186           set_errno(ENOTDIR);
5187           set_vaxc_errno(RMS$_DIR);
5188           return NULL;
5189         }
5190       }
5191
5192       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5193         /* They provided at least the name; we added the type, if necessary, */
5194         if (buf) retspec = buf;                            /* in sys$parse() */
5195         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5196         else retspec = __fileify_retbuf;
5197         strcpy(retspec,esa);
5198         sts = rms_free_search_context(&dirfab);
5199         PerlMem_free(trndir);
5200         PerlMem_free(esa);
5201         PerlMem_free(vmsdir);
5202         return retspec;
5203       }
5204       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5205         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5206         *cp1 = '\0';
5207         rms_nam_esll(dirnam) -= 9;
5208       }
5209       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5210       if (cp1 == NULL) { /* should never happen */
5211         sts = rms_free_search_context(&dirfab);
5212         PerlMem_free(trndir);
5213         PerlMem_free(esa);
5214         PerlMem_free(vmsdir);
5215         return NULL;
5216       }
5217       term = *cp1;
5218       *cp1 = '\0';
5219       retlen = strlen(esa);
5220       cp1 = strrchr(esa,'.');
5221       /* ODS-5 directory specifications can have extra "." in them. */
5222       /* Fix-me, can not scan EFS file specifications backwards */
5223       while (cp1 != NULL) {
5224         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5225           break;
5226         else {
5227            cp1--;
5228            while ((cp1 > esa) && (*cp1 != '.'))
5229              cp1--;
5230         }
5231         if (cp1 == esa)
5232           cp1 = NULL;
5233       }
5234
5235       if ((cp1) != NULL) {
5236         /* There's more than one directory in the path.  Just roll back. */
5237         *cp1 = term;
5238         if (buf) retspec = buf;
5239         else if (ts) Newx(retspec,retlen+7,char);
5240         else retspec = __fileify_retbuf;
5241         strcpy(retspec,esa);
5242       }
5243       else {
5244         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5245           /* Go back and expand rooted logical name */
5246           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5247 #ifdef NAM$M_NO_SHORT_UPCASE
5248           if (decc_efs_case_preserve)
5249             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5250 #endif
5251           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5252             sts = rms_free_search_context(&dirfab);
5253             PerlMem_free(esa);
5254             PerlMem_free(trndir);
5255             PerlMem_free(vmsdir);
5256             set_errno(EVMSERR);
5257             set_vaxc_errno(dirfab.fab$l_sts);
5258             return NULL;
5259           }
5260           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5261           if (buf) retspec = buf;
5262           else if (ts) Newx(retspec,retlen+16,char);
5263           else retspec = __fileify_retbuf;
5264           cp1 = strstr(esa,"][");
5265           if (!cp1) cp1 = strstr(esa,"]<");
5266           dirlen = cp1 - esa;
5267           memcpy(retspec,esa,dirlen);
5268           if (!strncmp(cp1+2,"000000]",7)) {
5269             retspec[dirlen-1] = '\0';
5270             /* fix-me Not full ODS-5, just extra dots in directories for now */
5271             cp1 = retspec + dirlen - 1;
5272             while (cp1 > retspec)
5273             {
5274               if (*cp1 == '[')
5275                 break;
5276               if (*cp1 == '.') {
5277                 if (*(cp1-1) != '^')
5278                   break;
5279               }
5280               cp1--;
5281             }
5282             if (*cp1 == '.') *cp1 = ']';
5283             else {
5284               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5285               memmove(cp1+1,"000000]",7);
5286             }
5287           }
5288           else {
5289             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5290             retspec[retlen] = '\0';
5291             /* Convert last '.' to ']' */
5292             cp1 = retspec+retlen-1;
5293             while (*cp != '[') {
5294               cp1--;
5295               if (*cp1 == '.') {
5296                 /* Do not trip on extra dots in ODS-5 directories */
5297                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5298                 break;
5299               }
5300             }
5301             if (*cp1 == '.') *cp1 = ']';
5302             else {
5303               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5304               memmove(cp1+1,"000000]",7);
5305             }
5306           }
5307         }
5308         else {  /* This is a top-level dir.  Add the MFD to the path. */
5309           if (buf) retspec = buf;
5310           else if (ts) Newx(retspec,retlen+16,char);
5311           else retspec = __fileify_retbuf;
5312           cp1 = esa;
5313           cp2 = retspec;
5314           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5315           strcpy(cp2,":[000000]");
5316           cp1 += 2;
5317           strcpy(cp2+9,cp1);
5318         }
5319       }
5320       sts = rms_free_search_context(&dirfab);
5321       /* We've set up the string up through the filename.  Add the
5322          type and version, and we're done. */
5323       strcat(retspec,".DIR;1");
5324
5325       /* $PARSE may have upcased filespec, so convert output to lower
5326        * case if input contained any lowercase characters. */
5327       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5328       PerlMem_free(trndir);
5329       PerlMem_free(esa);
5330       PerlMem_free(vmsdir);
5331       return retspec;
5332     }
5333 }  /* end of do_fileify_dirspec() */
5334 /*}}}*/
5335 /* External entry points */
5336 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5337 { return do_fileify_dirspec(dir,buf,0,NULL); }
5338 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5339 { return do_fileify_dirspec(dir,buf,1,NULL); }
5340 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5341 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5342 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5343 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5344
5345 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5346 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5347 {
5348     static char __pathify_retbuf[VMS_MAXRSS];
5349     unsigned long int retlen;
5350     char *retpath, *cp1, *cp2, *trndir;
5351     unsigned short int trnlnm_iter_count;
5352     STRLEN trnlen;
5353     int sts;
5354     if (utf8_fl != NULL)
5355         *utf8_fl = 0;
5356
5357     if (!dir || !*dir) {
5358       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5359     }
5360
5361     trndir = PerlMem_malloc(VMS_MAXRSS);
5362     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5363     if (*dir) strcpy(trndir,dir);
5364     else getcwd(trndir,VMS_MAXRSS - 1);
5365
5366     trnlnm_iter_count = 0;
5367     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5368            && my_trnlnm(trndir,trndir,0)) {
5369       trnlnm_iter_count++;
5370       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5371       trnlen = strlen(trndir);
5372
5373       /* Trap simple rooted lnms, and return lnm:[000000] */
5374       if (!strcmp(trndir+trnlen-2,".]")) {
5375         if (buf) retpath = buf;
5376         else if (ts) Newx(retpath,strlen(dir)+10,char);
5377         else retpath = __pathify_retbuf;
5378         strcpy(retpath,dir);
5379         strcat(retpath,":[000000]");
5380         PerlMem_free(trndir);
5381         return retpath;
5382       }
5383     }
5384
5385     /* At this point we do not work with *dir, but the copy in
5386      * *trndir that is modifiable.
5387      */
5388
5389     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5390       if (*trndir == '.' && (*(trndir+1) == '\0' ||
5391                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5392         retlen = 2 + (*(trndir+1) != '\0');
5393       else {
5394         if ( !(cp1 = strrchr(trndir,'/')) &&
5395              !(cp1 = strrchr(trndir,']')) &&
5396              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5397         if ((cp2 = strchr(cp1,'.')) != NULL &&
5398             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
5399              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
5400               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5401               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5402           int ver; char *cp3;
5403
5404           /* For EFS or ODS-5 look for the last dot */
5405           if (decc_efs_charset) {
5406             cp2 = strrchr(cp1,'.');
5407           }
5408           if (vms_process_case_tolerant) {
5409               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5410                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5411                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5412                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5413                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5414                             (ver || *cp3)))))) {
5415                 PerlMem_free(trndir);
5416                 set_errno(ENOTDIR);
5417                 set_vaxc_errno(RMS$_DIR);
5418                 return NULL;
5419               }
5420           }
5421           else {
5422               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5423                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5424                   !*(cp2+3) || *(cp2+3) != 'R' ||
5425                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5426                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5427                             (ver || *cp3)))))) {
5428                 PerlMem_free(trndir);
5429                 set_errno(ENOTDIR);
5430                 set_vaxc_errno(RMS$_DIR);
5431                 return NULL;
5432               }
5433           }
5434           retlen = cp2 - trndir + 1;
5435         }
5436         else {  /* No file type present.  Treat the filename as a directory. */
5437           retlen = strlen(trndir) + 1;
5438         }
5439       }
5440       if (buf) retpath = buf;
5441       else if (ts) Newx(retpath,retlen+1,char);
5442       else retpath = __pathify_retbuf;
5443       strncpy(retpath, trndir, retlen-1);
5444       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5445         retpath[retlen-1] = '/';      /* with '/', add it. */
5446         retpath[retlen] = '\0';
5447       }
5448       else retpath[retlen-1] = '\0';
5449     }
5450     else {  /* VMS-style directory spec */
5451       char *esa, *cp;
5452       unsigned long int sts, cmplen, haslower;
5453       struct FAB dirfab = cc$rms_fab;
5454       int dirlen;
5455       rms_setup_nam(savnam);
5456       rms_setup_nam(dirnam);
5457
5458       /* If we've got an explicit filename, we can just shuffle the string. */
5459       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5460              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
5461         if ((cp2 = strchr(cp1,'.')) != NULL) {
5462           int ver; char *cp3;
5463           if (vms_process_case_tolerant) {
5464               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5465                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5466                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5467                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5468                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5469                             (ver || *cp3)))))) {
5470                PerlMem_free(trndir);
5471                set_errno(ENOTDIR);
5472                set_vaxc_errno(RMS$_DIR);
5473                return NULL;
5474              }
5475           }
5476           else {
5477               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5478                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5479                   !*(cp2+3) || *(cp2+3) != 'R' ||
5480                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5481                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5482                             (ver || *cp3)))))) {
5483                PerlMem_free(trndir);
5484                set_errno(ENOTDIR);
5485                set_vaxc_errno(RMS$_DIR);
5486                return NULL;
5487              }
5488           }
5489         }
5490         else {  /* No file type, so just draw name into directory part */
5491           for (cp2 = cp1; *cp2; cp2++) ;
5492         }
5493         *cp2 = *cp1;
5494         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5495         *cp1 = '.';
5496         /* We've now got a VMS 'path'; fall through */
5497       }
5498
5499       dirlen = strlen(trndir);
5500       if (trndir[dirlen-1] == ']' ||
5501           trndir[dirlen-1] == '>' ||
5502           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5503         if (buf) retpath = buf;
5504         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5505         else retpath = __pathify_retbuf;
5506         strcpy(retpath,trndir);
5507         PerlMem_free(trndir);
5508         return retpath;
5509       }
5510       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5511       esa = PerlMem_malloc(VMS_MAXRSS);
5512       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5513       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5514       rms_bind_fab_nam(dirfab, dirnam);
5515       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5516 #ifdef NAM$M_NO_SHORT_UPCASE
5517       if (decc_efs_case_preserve)
5518           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5519 #endif
5520
5521       for (cp = trndir; *cp; cp++)
5522         if (islower(*cp)) { haslower = 1; break; }
5523
5524       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5525         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5526           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5527           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5528         }
5529         if (!sts) {
5530           PerlMem_free(trndir);
5531           PerlMem_free(esa);
5532           set_errno(EVMSERR);
5533           set_vaxc_errno(dirfab.fab$l_sts);
5534           return NULL;
5535         }
5536       }
5537       else {
5538         savnam = dirnam;
5539         /* Does the file really exist? */
5540         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5541           if (dirfab.fab$l_sts != RMS$_FNF) {
5542             int sts1;
5543             sts1 = rms_free_search_context(&dirfab);
5544             PerlMem_free(trndir);
5545             PerlMem_free(esa);
5546             set_errno(EVMSERR);
5547             set_vaxc_errno(dirfab.fab$l_sts);
5548             return NULL;
5549           }
5550           dirnam = savnam; /* No; just work with potential name */
5551         }
5552       }
5553       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5554         /* Yep; check version while we're at it, if it's there. */
5555         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5556         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5557           int sts2;
5558           /* Something other than .DIR[;1].  Bzzt. */
5559           sts2 = rms_free_search_context(&dirfab);
5560           PerlMem_free(trndir);
5561           PerlMem_free(esa);
5562           set_errno(ENOTDIR);
5563           set_vaxc_errno(RMS$_DIR);
5564           return NULL;
5565         }
5566       }
5567       /* OK, the type was fine.  Now pull any file name into the
5568          directory path. */
5569       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5570       else {
5571         cp1 = strrchr(esa,'>');
5572         *(rms_nam_typel(dirnam)) = '>';
5573       }
5574       *cp1 = '.';
5575       *(rms_nam_typel(dirnam) + 1) = '\0';
5576       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5577       if (buf) retpath = buf;
5578       else if (ts) Newx(retpath,retlen,char);
5579       else retpath = __pathify_retbuf;
5580       strcpy(retpath,esa);
5581       PerlMem_free(esa);
5582       sts = rms_free_search_context(&dirfab);
5583       /* $PARSE may have upcased filespec, so convert output to lower
5584        * case if input contained any lowercase characters. */
5585       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5586     }
5587
5588     PerlMem_free(trndir);
5589     return retpath;
5590 }  /* end of do_pathify_dirspec() */
5591 /*}}}*/
5592 /* External entry points */
5593 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5594 { return do_pathify_dirspec(dir,buf,0,NULL); }
5595 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5596 { return do_pathify_dirspec(dir,buf,1,NULL); }
5597 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5598 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5599 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5600 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5601
5602 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5603 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5604 {
5605   static char __tounixspec_retbuf[VMS_MAXRSS];
5606   char *dirend, *rslt, *cp1, *cp3, *tmp;
5607   const char *cp2;
5608   int devlen, dirlen, retlen = VMS_MAXRSS;
5609   int expand = 1; /* guarantee room for leading and trailing slashes */
5610   unsigned short int trnlnm_iter_count;
5611   int cmp_rslt;
5612   if (utf8_fl != NULL)
5613     *utf8_fl = 0;
5614
5615   if (spec == NULL) return NULL;
5616   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5617   if (buf) rslt = buf;
5618   else if (ts) {
5619     Newx(rslt, VMS_MAXRSS, char);
5620   }
5621   else rslt = __tounixspec_retbuf;
5622
5623   /* New VMS specific format needs translation
5624    * glob passes filenames with trailing '\n' and expects this preserved.
5625    */
5626   if (decc_posix_compliant_pathnames) {
5627     if (strncmp(spec, "\"^UP^", 5) == 0) {
5628       char * uspec;
5629       char *tunix;
5630       int tunix_len;
5631       int nl_flag;
5632
5633       tunix = PerlMem_malloc(VMS_MAXRSS);
5634       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5635       strcpy(tunix, spec);
5636       tunix_len = strlen(tunix);
5637       nl_flag = 0;
5638       if (tunix[tunix_len - 1] == '\n') {
5639         tunix[tunix_len - 1] = '\"';
5640         tunix[tunix_len] = '\0';
5641         tunix_len--;
5642         nl_flag = 1;
5643       }
5644       uspec = decc$translate_vms(tunix);
5645       PerlMem_free(tunix);
5646       if ((int)uspec > 0) {
5647         strcpy(rslt,uspec);
5648         if (nl_flag) {
5649           strcat(rslt,"\n");
5650         }
5651         else {
5652           /* If we can not translate it, makemaker wants as-is */
5653           strcpy(rslt, spec);
5654         }
5655         return rslt;
5656       }
5657     }
5658   }
5659
5660   cmp_rslt = 0; /* Presume VMS */
5661   cp1 = strchr(spec, '/');
5662   if (cp1 == NULL)
5663     cmp_rslt = 0;
5664
5665     /* Look for EFS ^/ */
5666     if (decc_efs_charset) {
5667       while (cp1 != NULL) {
5668         cp2 = cp1 - 1;
5669         if (*cp2 != '^') {
5670           /* Found illegal VMS, assume UNIX */
5671           cmp_rslt = 1;
5672           break;
5673         }
5674       cp1++;
5675       cp1 = strchr(cp1, '/');
5676     }
5677   }
5678
5679   /* Look for "." and ".." */
5680   if (decc_filename_unix_report) {
5681     if (spec[0] == '.') {
5682       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5683         cmp_rslt = 1;
5684       }
5685       else {
5686         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5687           cmp_rslt = 1;
5688         }
5689       }
5690     }
5691   }
5692   /* This is already UNIX or at least nothing VMS understands */
5693   if (cmp_rslt) {
5694     strcpy(rslt,spec);
5695     return rslt;
5696   }
5697
5698   cp1 = rslt;
5699   cp2 = spec;
5700   dirend = strrchr(spec,']');
5701   if (dirend == NULL) dirend = strrchr(spec,'>');
5702   if (dirend == NULL) dirend = strchr(spec,':');
5703   if (dirend == NULL) {
5704     strcpy(rslt,spec);
5705     return rslt;
5706   }
5707
5708   /* Special case 1 - sys$posix_root = / */
5709 #if __CRTL_VER >= 70000000
5710   if (!decc_disable_posix_root) {
5711     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5712       *cp1 = '/';
5713       cp1++;
5714       cp2 = cp2 + 15;
5715       }
5716   }
5717 #endif
5718
5719   /* Special case 2 - Convert NLA0: to /dev/null */
5720 #if __CRTL_VER < 70000000
5721   cmp_rslt = strncmp(spec,"NLA0:", 5);
5722   if (cmp_rslt != 0)
5723      cmp_rslt = strncmp(spec,"nla0:", 5);
5724 #else
5725   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5726 #endif
5727   if (cmp_rslt == 0) {
5728     strcpy(rslt, "/dev/null");
5729     cp1 = cp1 + 9;
5730     cp2 = cp2 + 5;
5731     if (spec[6] != '\0') {
5732       cp1[9] == '/';
5733       cp1++;
5734       cp2++;
5735     }
5736   }
5737
5738    /* Also handle special case "SYS$SCRATCH:" */
5739 #if __CRTL_VER < 70000000
5740   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5741   if (cmp_rslt != 0)
5742      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5743 #else
5744   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5745 #endif
5746   tmp = PerlMem_malloc(VMS_MAXRSS);
5747   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
5748   if (cmp_rslt == 0) {
5749   int islnm;
5750
5751     islnm = my_trnlnm(tmp, "TMP", 0);
5752     if (!islnm) {
5753       strcpy(rslt, "/tmp");
5754       cp1 = cp1 + 4;
5755       cp2 = cp2 + 12;
5756       if (spec[12] != '\0') {
5757         cp1[4] == '/';
5758         cp1++;
5759         cp2++;
5760       }
5761     }
5762   }
5763
5764   if (*cp2 != '[' && *cp2 != '<') {
5765     *(cp1++) = '/';
5766   }
5767   else {  /* the VMS spec begins with directories */
5768     cp2++;
5769     if (*cp2 == ']' || *cp2 == '>') {
5770       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5771       PerlMem_free(tmp);
5772       return rslt;
5773     }
5774     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5775       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
5776         if (ts) Safefree(rslt);
5777         PerlMem_free(tmp);
5778         return NULL;
5779       }
5780       trnlnm_iter_count = 0;
5781       do {
5782         cp3 = tmp;
5783         while (*cp3 != ':' && *cp3) cp3++;
5784         *(cp3++) = '\0';
5785         if (strchr(cp3,']') != NULL) break;
5786         trnlnm_iter_count++;
5787         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5788       } while (vmstrnenv(tmp,tmp,0,fildev,0));
5789       if (ts && !buf &&
5790           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5791         retlen = devlen + dirlen;
5792         Renew(rslt,retlen+1+2*expand,char);
5793         cp1 = rslt;
5794       }
5795       cp3 = tmp;
5796       *(cp1++) = '/';
5797       while (*cp3) {
5798         *(cp1++) = *(cp3++);
5799         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
5800             PerlMem_free(tmp);
5801             return NULL; /* No room */
5802         }
5803       }
5804       *(cp1++) = '/';
5805     }
5806     if ((*cp2 == '^')) {
5807         /* EFS file escape, pass the next character as is */
5808         /* Fix me: HEX encoding for UNICODE not implemented */
5809         cp2++;
5810     }
5811     else if ( *cp2 == '.') {
5812       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5813         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5814         cp2 += 3;
5815       }
5816       else cp2++;
5817     }
5818   }
5819   PerlMem_free(tmp);
5820   for (; cp2 <= dirend; cp2++) {
5821     if ((*cp2 == '^')) {
5822         /* EFS file escape, pass the next character as is */
5823         /* Fix me: HEX encoding for UNICODE not implemented */
5824         cp2++;
5825         *(cp1++) = *cp2;
5826     }
5827     if (*cp2 == ':') {
5828       *(cp1++) = '/';
5829       if (*(cp2+1) == '[') cp2++;
5830     }
5831     else if (*cp2 == ']' || *cp2 == '>') {
5832       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5833     }
5834     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5835       *(cp1++) = '/';
5836       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5837         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5838                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5839         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5840             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5841       }
5842       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5843         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5844         cp2 += 2;
5845       }
5846     }
5847     else if (*cp2 == '-') {
5848       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5849         while (*cp2 == '-') {
5850           cp2++;
5851           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5852         }
5853         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5854           if (ts) Safefree(rslt);                        /* filespecs like */
5855           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
5856           return NULL;
5857         }
5858       }
5859       else *(cp1++) = *cp2;
5860     }
5861     else *(cp1++) = *cp2;
5862   }
5863   while (*cp2) *(cp1++) = *(cp2++);
5864   *cp1 = '\0';
5865
5866   /* This still leaves /000000/ when working with a
5867    * VMS device root or concealed root.
5868    */
5869   {
5870   int ulen;
5871   char * zeros;
5872
5873       ulen = strlen(rslt);
5874
5875       /* Get rid of "000000/ in rooted filespecs */
5876       if (ulen > 7) {
5877         zeros = strstr(rslt, "/000000/");
5878         if (zeros != NULL) {
5879           int mlen;
5880           mlen = ulen - (zeros - rslt) - 7;
5881           memmove(zeros, &zeros[7], mlen);
5882           ulen = ulen - 7;
5883           rslt[ulen] = '\0';
5884         }
5885       }
5886   }
5887
5888   return rslt;
5889
5890 }  /* end of do_tounixspec() */
5891 /*}}}*/
5892 /* External entry points */
5893 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
5894   { return do_tounixspec(spec,buf,0, NULL); }
5895 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
5896   { return do_tounixspec(spec,buf,1, NULL); }
5897 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
5898   { return do_tounixspec(spec,buf,0, utf8_fl); }
5899 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
5900   { return do_tounixspec(spec,buf,1, utf8_fl); }
5901
5902 #if __CRTL_VER >= 70200000 && !defined(__VAX)
5903
5904 /*
5905  This procedure is used to identify if a path is based in either
5906  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
5907  it returns the OpenVMS format directory for it.
5908
5909  It is expecting specifications of only '/' or '/xxxx/'
5910
5911  If a posix root does not exist, or 'xxxx' is not a directory
5912  in the posix root, it returns a failure.
5913
5914  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
5915
5916  It is used only internally by posix_to_vmsspec_hardway().
5917  */
5918
5919 static int posix_root_to_vms
5920   (char *vmspath, int vmspath_len,
5921    const char *unixpath,
5922    const int * utf8_fl) {
5923 int sts;
5924 struct FAB myfab = cc$rms_fab;
5925 struct NAML mynam = cc$rms_naml;
5926 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5927  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5928 char *esa;
5929 char *vms_delim;
5930 int dir_flag;
5931 int unixlen;
5932
5933     dir_flag = 0;
5934     unixlen = strlen(unixpath);
5935     if (unixlen == 0) {
5936       vmspath[0] = '\0';
5937       return RMS$_FNF;
5938     }
5939
5940 #if __CRTL_VER >= 80200000
5941   /* If not a posix spec already, convert it */
5942   if (decc_posix_compliant_pathnames) {
5943     if (strncmp(unixpath,"\"^UP^",5) != 0) {
5944       sprintf(vmspath,"\"^UP^%s\"",unixpath);
5945     }
5946     else {
5947       /* This is already a VMS specification, no conversion */
5948       unixlen--;
5949       strncpy(vmspath,unixpath, vmspath_len);
5950     }
5951   }
5952   else
5953 #endif
5954   {
5955   int path_len;
5956   int i,j;
5957
5958      /* Check to see if this is under the POSIX root */
5959      if (decc_disable_posix_root) {
5960         return RMS$_FNF;
5961      }
5962
5963      /* Skip leading / */
5964      if (unixpath[0] == '/') {
5965         unixpath++;
5966         unixlen--;
5967      }
5968
5969
5970      strcpy(vmspath,"SYS$POSIX_ROOT:");
5971
5972      /* If this is only the / , or blank, then... */
5973      if (unixpath[0] == '\0') {
5974         /* by definition, this is the answer */
5975         return SS$_NORMAL;
5976      }
5977
5978      /* Need to look up a directory */
5979      vmspath[15] = '[';
5980      vmspath[16] = '\0';
5981
5982      /* Copy and add '^' escape characters as needed */
5983      j = 16;
5984      i = 0;
5985      while (unixpath[i] != 0) {
5986      int k;
5987
5988         j += copy_expand_unix_filename_escape
5989             (&vmspath[j], &unixpath[i], &k, utf8_fl);
5990         i += k;
5991      }
5992
5993      path_len = strlen(vmspath);
5994      if (vmspath[path_len - 1] == '/')
5995         path_len--;
5996      vmspath[path_len] = ']';
5997      path_len++;
5998      vmspath[path_len] = '\0';
5999
6000   }
6001   vmspath[vmspath_len] = 0;
6002   if (unixpath[unixlen - 1] == '/')
6003   dir_flag = 1;
6004   esa = PerlMem_malloc(VMS_MAXRSS);
6005   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6006   myfab.fab$l_fna = vmspath;
6007   myfab.fab$b_fns = strlen(vmspath);
6008   myfab.fab$l_naml = &mynam;
6009   mynam.naml$l_esa = NULL;
6010   mynam.naml$b_ess = 0;
6011   mynam.naml$l_long_expand = esa;
6012   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6013   mynam.naml$l_rsa = NULL;
6014   mynam.naml$b_rss = 0;
6015   if (decc_efs_case_preserve)
6016     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6017 #ifdef NAML$M_OPEN_SPECIAL
6018   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6019 #endif
6020
6021   /* Set up the remaining naml fields */
6022   sts = sys$parse(&myfab);
6023
6024   /* It failed! Try again as a UNIX filespec */
6025   if (!(sts & 1)) {
6026     PerlMem_free(esa);
6027     return sts;
6028   }
6029
6030    /* get the Device ID and the FID */
6031    sts = sys$search(&myfab);
6032    /* on any failure, returned the POSIX ^UP^ filespec */
6033    if (!(sts & 1)) {
6034       PerlMem_free(esa);
6035       return sts;
6036    }
6037    specdsc.dsc$a_pointer = vmspath;
6038    specdsc.dsc$w_length = vmspath_len;
6039
6040    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6041    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6042    sts = lib$fid_to_name
6043       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6044
6045   /* on any failure, returned the POSIX ^UP^ filespec */
6046   if (!(sts & 1)) {
6047      /* This can happen if user does not have permission to read directories */
6048      if (strncmp(unixpath,"\"^UP^",5) != 0)
6049        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6050      else
6051        strcpy(vmspath, unixpath);
6052   }
6053   else {
6054     vmspath[specdsc.dsc$w_length] = 0;
6055
6056     /* Are we expecting a directory? */
6057     if (dir_flag != 0) {
6058     int i;
6059     char *eptr;
6060
6061       eptr = NULL;
6062
6063       i = specdsc.dsc$w_length - 1;
6064       while (i > 0) {
6065       int zercnt;
6066         zercnt = 0;
6067         /* Version must be '1' */
6068         if (vmspath[i--] != '1')
6069           break;
6070         /* Version delimiter is one of ".;" */
6071         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6072           break;
6073         i--;
6074         if (vmspath[i--] != 'R')
6075           break;
6076         if (vmspath[i--] != 'I')
6077           break;
6078         if (vmspath[i--] != 'D')
6079           break;
6080         if (vmspath[i--] != '.')
6081           break;
6082         eptr = &vmspath[i+1];
6083         while (i > 0) {
6084           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6085             if (vmspath[i-1] != '^') {
6086               if (zercnt != 6) {
6087                 *eptr = vmspath[i];
6088                 eptr[1] = '\0';
6089                 vmspath[i] = '.';
6090                 break;
6091               }
6092               else {
6093                 /* Get rid of 6 imaginary zero directory filename */
6094                 vmspath[i+1] = '\0';
6095               }
6096             }
6097           }
6098           if (vmspath[i] == '0')
6099             zercnt++;
6100           else
6101             zercnt = 10;
6102           i--;
6103         }
6104         break;
6105       }
6106     }
6107   }
6108   PerlMem_free(esa);
6109   return sts;
6110 }
6111
6112 /* /dev/mumble needs to be handled special.
6113    /dev/null becomes NLA0:, And there is the potential for other stuff
6114    like /dev/tty which may need to be mapped to something.
6115 */
6116
6117 static int
6118 slash_dev_special_to_vms
6119    (const char * unixptr,
6120     char * vmspath,
6121     int vmspath_len)
6122 {
6123 char * nextslash;
6124 int len;
6125 int cmp;
6126 int islnm;
6127
6128     unixptr += 4;
6129     nextslash = strchr(unixptr, '/');
6130     len = strlen(unixptr);
6131     if (nextslash != NULL)
6132         len = nextslash - unixptr;
6133     cmp = strncmp("null", unixptr, 5);
6134     if (cmp == 0) {
6135         if (vmspath_len >= 6) {
6136             strcpy(vmspath, "_NLA0:");
6137             return SS$_NORMAL;
6138         }
6139     }
6140 }
6141
6142
6143 /* The built in routines do not understand perl's special needs, so
6144     doing a manual conversion from UNIX to VMS
6145
6146     If the utf8_fl is not null and points to a non-zero value, then
6147     treat 8 bit characters as UTF-8.
6148
6149     The sequence starting with '$(' and ending with ')' will be passed
6150     through with out interpretation instead of being escaped.
6151
6152   */
6153 static int posix_to_vmsspec_hardway
6154   (char *vmspath, int vmspath_len,
6155    const char *unixpath,
6156    int dir_flag,
6157    int * utf8_fl) {
6158
6159 char *esa;
6160 const char *unixptr;
6161 const char *unixend;
6162 char *vmsptr;
6163 const char *lastslash;
6164 const char *lastdot;
6165 int unixlen;
6166 int vmslen;
6167 int dir_start;
6168 int dir_dot;
6169 int quoted;
6170 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6171 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6172
6173   if (utf8_fl != NULL)
6174     *utf8_fl = 0;
6175
6176   unixptr = unixpath;
6177   dir_dot = 0;
6178
6179   /* Ignore leading "/" characters */
6180   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6181     unixptr++;
6182   }
6183   unixlen = strlen(unixptr);
6184
6185   /* Do nothing with blank paths */
6186   if (unixlen == 0) {
6187     vmspath[0] = '\0';
6188     return SS$_NORMAL;
6189   }
6190
6191   quoted = 0;
6192   /* This could have a "^UP^ on the front */
6193   if (strncmp(unixptr,"\"^UP^",5) == 0) {
6194     quoted = 1;
6195     unixptr+= 5;
6196     unixlen-= 5;
6197   }
6198
6199   lastslash = strrchr(unixptr,'/');
6200   lastdot = strrchr(unixptr,'.');
6201   unixend = strrchr(unixptr,'\"');
6202   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6203     unixend = unixptr + unixlen;
6204   }
6205
6206   /* last dot is last dot or past end of string */
6207   if (lastdot == NULL)
6208     lastdot = unixptr + unixlen;
6209
6210   /* if no directories, set last slash to beginning of string */
6211   if (lastslash == NULL) {
6212     lastslash = unixptr;
6213   }
6214   else {
6215     /* Watch out for trailing "." after last slash, still a directory */
6216     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6217       lastslash = unixptr + unixlen;
6218     }
6219
6220     /* Watch out for traiing ".." after last slash, still a directory */
6221     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6222       lastslash = unixptr + unixlen;
6223     }
6224
6225     /* dots in directories are aways escaped */
6226     if (lastdot < lastslash)
6227       lastdot = unixptr + unixlen;
6228   }
6229
6230   /* if (unixptr < lastslash) then we are in a directory */
6231
6232   dir_start = 0;
6233
6234   vmsptr = vmspath;
6235   vmslen = 0;
6236
6237   /* Start with the UNIX path */
6238   if (*unixptr != '/') {
6239     /* relative paths */
6240
6241     /* If allowing logical names on relative pathnames, then handle here */
6242     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6243         !decc_posix_compliant_pathnames) {
6244     char * nextslash;
6245     int seg_len;
6246     char * trn;
6247     int islnm;
6248
6249         /* Find the next slash */
6250         nextslash = strchr(unixptr,'/');
6251
6252         esa = PerlMem_malloc(vmspath_len);
6253         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6254
6255         trn = PerlMem_malloc(VMS_MAXRSS);
6256         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6257
6258         if (nextslash != NULL) {
6259
6260             seg_len = nextslash - unixptr;
6261             strncpy(esa, unixptr, seg_len);
6262             esa[seg_len] = 0;
6263         }
6264         else {
6265             strcpy(esa, unixptr);
6266             seg_len = strlen(unixptr);
6267         }
6268         /* trnlnm(section) */
6269         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6270
6271         if (islnm) {
6272             /* Now fix up the directory */
6273
6274             /* Split up the path to find the components */
6275             sts = vms_split_path
6276                   (trn,
6277                    &v_spec,
6278                    &v_len,
6279                    &r_spec,
6280                    &r_len,
6281                    &d_spec,
6282                    &d_len,
6283                    &n_spec,
6284                    &n_len,
6285                    &e_spec,
6286                    &e_len,
6287                    &vs_spec,
6288                    &vs_len);
6289
6290             while (sts == 0) {
6291             char * strt;
6292             int cmp;
6293
6294                 /* A logical name must be a directory  or the full
6295                    specification.  It is only a full specification if
6296                    it is the only component */
6297                 if ((unixptr[seg_len] == '\0') ||
6298                     (unixptr[seg_len+1] == '\0')) {
6299
6300                     /* Is a directory being required? */
6301                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6302                         /* Not a logical name */
6303                         break;
6304                     }
6305
6306
6307                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6308                         /* This must be a directory */
6309                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6310                             strcpy(vmsptr, esa);
6311                             vmslen=strlen(vmsptr);
6312                             vmsptr[vmslen] = ':';
6313                             vmslen++;
6314                             vmsptr[vmslen] = '\0';
6315                             return SS$_NORMAL;
6316                         }
6317                     }
6318
6319                 }
6320
6321
6322                 /* must be dev/directory - ignore version */
6323                 if ((n_len + e_len) != 0)
6324                     break;
6325
6326                 /* transfer the volume */
6327                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6328                     strncpy(vmsptr, v_spec, v_len);
6329                     vmsptr += v_len;
6330                     vmsptr[0] = '\0';
6331                     vmslen += v_len;
6332                 }
6333
6334                 /* unroot the rooted directory */
6335                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6336                     r_spec[0] = '[';
6337                     r_spec[r_len - 1] = ']';
6338
6339                     /* This should not be there, but nothing is perfect */
6340                     if (r_len > 9) {
6341                         cmp = strcmp(&r_spec[1], "000000.");
6342                         if (cmp == 0) {
6343                             r_spec += 7;
6344                             r_spec[7] = '[';
6345                             r_len -= 7;
6346                             if (r_len == 2)
6347                                 r_len = 0;
6348                         }
6349                     }
6350                     if (r_len > 0) {
6351                         strncpy(vmsptr, r_spec, r_len);
6352                         vmsptr += r_len;
6353                         vmslen += r_len;
6354                         vmsptr[0] = '\0';
6355                     }
6356                 }
6357                 /* Bring over the directory. */
6358                 if ((d_len > 0) &&
6359                     ((d_len + vmslen) < vmspath_len)) {
6360                     d_spec[0] = '[';
6361                     d_spec[d_len - 1] = ']';
6362                     if (d_len > 9) {
6363                         cmp = strcmp(&d_spec[1], "000000.");
6364                         if (cmp == 0) {
6365                             d_spec += 7;
6366                             d_spec[7] = '[';
6367                             d_len -= 7;
6368                             if (d_len == 2)
6369                                 d_len = 0;
6370                         }
6371                     }
6372
6373                     if (r_len > 0) {
6374                         /* Remove the redundant root */
6375                         if (r_len > 0) {
6376                             /* remove the ][ */
6377                             vmsptr--;
6378                             vmslen--;
6379                             d_spec++;
6380                             d_len--;
6381                         }
6382                         strncpy(vmsptr, d_spec, d_len);
6383                             vmsptr += d_len;
6384                             vmslen += d_len;
6385                             vmsptr[0] = '\0';
6386                     }
6387                 }
6388                 break;
6389             }
6390         }
6391
6392         PerlMem_free(esa);
6393         PerlMem_free(trn);
6394     }
6395
6396     if (lastslash > unixptr) {
6397     int dotdir_seen;
6398
6399       /* skip leading ./ */
6400       dotdir_seen = 0;
6401       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6402         dotdir_seen = 1;
6403         unixptr++;
6404         unixptr++;
6405       }
6406
6407       /* Are we still in a directory? */
6408       if (unixptr <= lastslash) {
6409         *vmsptr++ = '[';
6410         vmslen = 1;
6411         dir_start = 1;
6412
6413         /* if not backing up, then it is relative forward. */
6414         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6415               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6416           *vmsptr++ = '.';
6417           vmslen++;
6418           dir_dot = 1;
6419           }
6420        }
6421        else {
6422          if (dotdir_seen) {
6423            /* Perl wants an empty directory here to tell the difference
6424             * between a DCL commmand and a filename
6425             */
6426           *vmsptr++ = '[';
6427           *vmsptr++ = ']';
6428           vmslen = 2;
6429         }
6430       }
6431     }
6432     else {
6433       /* Handle two special files . and .. */
6434       if (unixptr[0] == '.') {
6435         if (&unixptr[1] == unixend) {
6436           *vmsptr++ = '[';
6437           *vmsptr++ = ']';
6438           vmslen += 2;
6439           *vmsptr++ = '\0';
6440           return SS$_NORMAL;
6441         }
6442         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6443           *vmsptr++ = '[';
6444           *vmsptr++ = '-';
6445           *vmsptr++ = ']';
6446           vmslen += 3;
6447           *vmsptr++ = '\0';
6448           return SS$_NORMAL;
6449         }
6450       }
6451     }
6452   }
6453   else {        /* Absolute PATH handling */
6454   int sts;
6455   char * nextslash;
6456   int seg_len;
6457     /* Need to find out where root is */
6458
6459     /* In theory, this procedure should never get an absolute POSIX pathname
6460      * that can not be found on the POSIX root.
6461      * In practice, that can not be relied on, and things will show up
6462      * here that are a VMS device name or concealed logical name instead.
6463      * So to make things work, this procedure must be tolerant.
6464      */
6465     esa = PerlMem_malloc(vmspath_len);
6466     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6467
6468     sts = SS$_NORMAL;
6469     nextslash = strchr(&unixptr[1],'/');
6470     seg_len = 0;
6471     if (nextslash != NULL) {
6472     int cmp;
6473       seg_len = nextslash - &unixptr[1];
6474       strncpy(vmspath, unixptr, seg_len + 1);
6475       vmspath[seg_len+1] = 0;
6476       cmp = 1;
6477       if (seg_len == 3) {
6478         cmp = strncmp(vmspath, "dev", 4);
6479         if (cmp == 0) {
6480             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6481             if (sts = SS$_NORMAL)
6482                 return SS$_NORMAL;
6483         }
6484       }
6485       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6486     }
6487
6488     if ($VMS_STATUS_SUCCESS(sts)) {
6489       /* This is verified to be a real path */
6490
6491       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6492       if ($VMS_STATUS_SUCCESS(sts)) {
6493         strcpy(vmspath, esa);
6494         vmslen = strlen(vmspath);
6495         vmsptr = vmspath + vmslen;
6496         unixptr++;
6497         if (unixptr < lastslash) {
6498         char * rptr;
6499           vmsptr--;
6500           *vmsptr++ = '.';
6501           dir_start = 1;
6502           dir_dot = 1;
6503           if (vmslen > 7) {
6504           int cmp;
6505             rptr = vmsptr - 7;
6506             cmp = strcmp(rptr,"000000.");
6507             if (cmp == 0) {
6508               vmslen -= 7;
6509               vmsptr -= 7;
6510               vmsptr[1] = '\0';
6511             } /* removing 6 zeros */
6512           } /* vmslen < 7, no 6 zeros possible */
6513         } /* Not in a directory */
6514       } /* Posix root found */
6515       else {
6516         /* No posix root, fall back to default directory */
6517         strcpy(vmspath, "SYS$DISK:[");
6518         vmsptr = &vmspath[10];
6519         vmslen = 10;
6520         if (unixptr > lastslash) {
6521            *vmsptr = ']';
6522            vmsptr++;
6523            vmslen++;
6524         }
6525         else {
6526            dir_start = 1;
6527         }
6528       }
6529     } /* end of verified real path handling */
6530     else {
6531     int add_6zero;
6532     int islnm;
6533
6534       /* Ok, we have a device or a concealed root that is not in POSIX
6535        * or we have garbage.  Make the best of it.
6536        */
6537
6538       /* Posix to VMS destroyed this, so copy it again */
6539       strncpy(vmspath, &unixptr[1], seg_len);
6540       vmspath[seg_len] = 0;
6541       vmslen = seg_len;
6542       vmsptr = &vmsptr[vmslen];
6543       islnm = 0;
6544
6545       /* Now do we need to add the fake 6 zero directory to it? */
6546       add_6zero = 1;
6547       if ((*lastslash == '/') && (nextslash < lastslash)) {
6548         /* No there is another directory */
6549         add_6zero = 0;
6550       }
6551       else {
6552       int trnend;
6553       int cmp;
6554
6555         /* now we have foo:bar or foo:[000000]bar to decide from */
6556         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6557
6558         if (!islnm && !decc_posix_compliant_pathnames) {
6559
6560             cmp = strncmp("bin", vmspath, 4);
6561             if (cmp == 0) {
6562                 /* bin => SYS$SYSTEM: */
6563                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6564             }
6565             else {
6566                 /* tmp => SYS$SCRATCH: */
6567                 cmp = strncmp("tmp", vmspath, 4);
6568                 if (cmp == 0) {
6569                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6570                 }
6571             }
6572         }
6573
6574         trnend = islnm ? islnm - 1 : 0;
6575
6576         /* if this was a logical name, ']' or '>' must be present */
6577         /* if not a logical name, then assume a device and hope. */
6578         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6579
6580         /* if log name and trailing '.' then rooted - treat as device */
6581         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6582
6583         /* Fix me, if not a logical name, a device lookup should be
6584          * done to see if the device is file structured.  If the device
6585          * is not file structured, the 6 zeros should not be put on.
6586          *
6587          * As it is, perl is occasionally looking for dev:[000000]tty.
6588          * which looks a little strange.
6589          *
6590          * Not that easy to detect as "/dev" may be file structured with
6591          * special device files.
6592          */
6593
6594         if ((add_6zero == 0) && (*nextslash == '/') &&
6595             (&nextslash[1] == unixend)) {
6596           /* No real directory present */
6597           add_6zero = 1;
6598         }
6599       }
6600
6601       /* Put the device delimiter on */
6602       *vmsptr++ = ':';
6603       vmslen++;
6604       unixptr = nextslash;
6605       unixptr++;
6606
6607       /* Start directory if needed */
6608       if (!islnm || add_6zero) {
6609         *vmsptr++ = '[';
6610         vmslen++;
6611         dir_start = 1;
6612       }
6613
6614       /* add fake 000000] if needed */
6615       if (add_6zero) {
6616         *vmsptr++ = '0';
6617         *vmsptr++ = '0';
6618         *vmsptr++ = '0';
6619         *vmsptr++ = '0';
6620         *vmsptr++ = '0';
6621         *vmsptr++ = '0';
6622         *vmsptr++ = ']';
6623         vmslen += 7;
6624         dir_start = 0;
6625       }
6626
6627     } /* non-POSIX translation */
6628     PerlMem_free(esa);
6629   } /* End of relative/absolute path handling */
6630
6631   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6632   int dash_flag;
6633   int in_cnt;
6634   int out_cnt;
6635
6636     dash_flag = 0;
6637
6638     if (dir_start != 0) {
6639
6640       /* First characters in a directory are handled special */
6641       while ((*unixptr == '/') ||
6642              ((*unixptr == '.') &&
6643               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6644                 (&unixptr[1]==unixend)))) {
6645       int loop_flag;
6646
6647         loop_flag = 0;
6648
6649         /* Skip redundant / in specification */
6650         while ((*unixptr == '/') && (dir_start != 0)) {
6651           loop_flag = 1;
6652           unixptr++;
6653           if (unixptr == lastslash)
6654             break;
6655         }
6656         if (unixptr == lastslash)
6657           break;
6658
6659         /* Skip redundant ./ characters */
6660         while ((*unixptr == '.') &&
6661                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6662           loop_flag = 1;
6663           unixptr++;
6664           if (unixptr == lastslash)
6665             break;
6666           if (*unixptr == '/')
6667             unixptr++;
6668         }
6669         if (unixptr == lastslash)
6670           break;
6671
6672         /* Skip redundant ../ characters */
6673         while ((*unixptr == '.') && (unixptr[1] == '.') &&
6674              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6675           /* Set the backing up flag */
6676           loop_flag = 1;
6677           dir_dot = 0;
6678           dash_flag = 1;
6679           *vmsptr++ = '-';
6680           vmslen++;
6681           unixptr++; /* first . */
6682           unixptr++; /* second . */
6683           if (unixptr == lastslash)
6684             break;
6685           if (*unixptr == '/') /* The slash */
6686             unixptr++;
6687         }
6688         if (unixptr == lastslash)
6689           break;
6690
6691         /* To do: Perl expects /.../ to be translated to [...] on VMS */
6692         /* Not needed when VMS is pretending to be UNIX. */
6693
6694         /* Is this loop stuck because of too many dots? */
6695         if (loop_flag == 0) {
6696           /* Exit the loop and pass the rest through */
6697           break;
6698         }
6699       }
6700
6701       /* Are we done with directories yet? */
6702       if (unixptr >= lastslash) {
6703
6704         /* Watch out for trailing dots */
6705         if (dir_dot != 0) {
6706             vmslen --;
6707             vmsptr--;
6708         }
6709         *vmsptr++ = ']';
6710         vmslen++;
6711         dash_flag = 0;
6712         dir_start = 0;
6713         if (*unixptr == '/')
6714           unixptr++;
6715       }
6716       else {
6717         /* Have we stopped backing up? */
6718         if (dash_flag) {
6719           *vmsptr++ = '.';
6720           vmslen++;
6721           dash_flag = 0;
6722           /* dir_start continues to be = 1 */
6723         }
6724         if (*unixptr == '-') {
6725           *vmsptr++ = '^';
6726           *vmsptr++ = *unixptr++;
6727           vmslen += 2;
6728           dir_start = 0;
6729
6730           /* Now are we done with directories yet? */
6731           if (unixptr >= lastslash) {
6732
6733             /* Watch out for trailing dots */
6734             if (dir_dot != 0) {
6735               vmslen --;
6736               vmsptr--;
6737             }
6738
6739             *vmsptr++ = ']';
6740             vmslen++;
6741             dash_flag = 0;
6742             dir_start = 0;
6743           }
6744         }
6745       }
6746     }
6747
6748     /* All done? */
6749     if (unixptr >= unixend)
6750       break;
6751
6752     /* Normal characters - More EFS work probably needed */
6753     dir_start = 0;
6754     dir_dot = 0;
6755
6756     switch(*unixptr) {
6757     case '/':
6758         /* remove multiple / */
6759         while (unixptr[1] == '/') {
6760            unixptr++;
6761         }
6762         if (unixptr == lastslash) {
6763           /* Watch out for trailing dots */
6764           if (dir_dot != 0) {
6765             vmslen --;
6766             vmsptr--;
6767           }
6768           *vmsptr++ = ']';
6769         }
6770         else {
6771           dir_start = 1;
6772           *vmsptr++ = '.';
6773           dir_dot = 1;
6774
6775           /* To do: Perl expects /.../ to be translated to [...] on VMS */
6776           /* Not needed when VMS is pretending to be UNIX. */
6777
6778         }
6779         dash_flag = 0;
6780         if (unixptr != unixend)
6781           unixptr++;
6782         vmslen++;
6783         break;
6784     case '.':
6785         if ((unixptr < lastdot) || (unixptr < lastslash) ||
6786             (&unixptr[1] == unixend)) {
6787           *vmsptr++ = '^';
6788           *vmsptr++ = '.';
6789           vmslen += 2;
6790           unixptr++;
6791
6792           /* trailing dot ==> '^..' on VMS */
6793           if (unixptr == unixend) {
6794             *vmsptr++ = '.';
6795             vmslen++;
6796             unixptr++;
6797           }
6798           break;
6799         }
6800
6801         *vmsptr++ = *unixptr++;
6802         vmslen ++;
6803         break;
6804     case '"':
6805         if (quoted && (&unixptr[1] == unixend)) {
6806             unixptr++;
6807             break;
6808         }
6809         in_cnt = copy_expand_unix_filename_escape
6810                 (vmsptr, unixptr, &out_cnt, utf8_fl);
6811         vmsptr += out_cnt;
6812         unixptr += in_cnt;
6813         break;
6814     case '~':
6815     case ';':
6816     case '\\':
6817     case '?':
6818     case ' ':
6819     default:
6820         in_cnt = copy_expand_unix_filename_escape
6821                 (vmsptr, unixptr, &out_cnt, utf8_fl);
6822         vmsptr += out_cnt;
6823         unixptr += in_cnt;
6824         break;
6825     }
6826   }
6827
6828   /* Make sure directory is closed */
6829   if (unixptr == lastslash) {
6830     char *vmsptr2;
6831     vmsptr2 = vmsptr - 1;
6832
6833     if (*vmsptr2 != ']') {
6834       *vmsptr2--;
6835
6836       /* directories do not end in a dot bracket */
6837       if (*vmsptr2 == '.') {
6838         vmsptr2--;
6839
6840         /* ^. is allowed */
6841         if (*vmsptr2 != '^') {
6842           vmsptr--; /* back up over the dot */
6843         }
6844       }
6845       *vmsptr++ = ']';
6846     }
6847   }
6848   else {
6849     char *vmsptr2;
6850     /* Add a trailing dot if a file with no extension */
6851     vmsptr2 = vmsptr - 1;
6852     if ((vmslen > 1) &&
6853         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6854         (*vmsptr2 != ')') && (*lastdot != '.')) {
6855         *vmsptr++ = '.';
6856         vmslen++;
6857     }
6858   }
6859
6860   *vmsptr = '\0';
6861   return SS$_NORMAL;
6862 }
6863 #endif
6864
6865  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
6866 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
6867 {
6868 char * result;
6869 int utf8_flag;
6870
6871    /* If a UTF8 flag is being passed, honor it */
6872    utf8_flag = 0;
6873    if (utf8_fl != NULL) {
6874      utf8_flag = *utf8_fl;
6875     *utf8_fl = 0;
6876    }
6877
6878    if (utf8_flag) {
6879      /* If there is a possibility of UTF8, then if any UTF8 characters
6880         are present, then they must be converted to VTF-7
6881       */
6882      result = strcpy(rslt, path); /* FIX-ME */
6883    }
6884    else
6885      result = strcpy(rslt, path);
6886
6887    return result;
6888 }
6889
6890
6891 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
6892 static char *mp_do_tovmsspec
6893    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
6894   static char __tovmsspec_retbuf[VMS_MAXRSS];
6895   char *rslt, *dirend;
6896   char *lastdot;
6897   char *vms_delim;
6898   register char *cp1;
6899   const char *cp2;
6900   unsigned long int infront = 0, hasdir = 1;
6901   int rslt_len;
6902   int no_type_seen;
6903   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6904   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6905
6906   if (path == NULL) return NULL;
6907   rslt_len = VMS_MAXRSS-1;
6908   if (buf) rslt = buf;
6909   else if (ts) Newx(rslt, VMS_MAXRSS, char);
6910   else rslt = __tovmsspec_retbuf;
6911
6912   /* '.' and '..' are "[]" and "[-]" for a quick check */
6913   if (path[0] == '.') {
6914     if (path[1] == '\0') {
6915       strcpy(rslt,"[]");
6916       if (utf8_flag != NULL)
6917         *utf8_flag = 0;
6918       return rslt;
6919     }
6920     else {
6921       if (path[1] == '.' && path[2] == '\0') {
6922         strcpy(rslt,"[-]");
6923         if (utf8_flag != NULL)
6924            *utf8_flag = 0;
6925         return rslt;
6926       }
6927     }
6928   }
6929
6930    /* Posix specifications are now a native VMS format */
6931   /*--------------------------------------------------*/
6932 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6933   if (decc_posix_compliant_pathnames) {
6934     if (strncmp(path,"\"^UP^",5) == 0) {
6935       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
6936       return rslt;
6937     }
6938   }
6939 #endif
6940
6941   /* This is really the only way to see if this is already in VMS format */
6942   sts = vms_split_path
6943        (path,
6944         &v_spec,
6945         &v_len,
6946         &r_spec,
6947         &r_len,
6948         &d_spec,
6949         &d_len,
6950         &n_spec,
6951         &n_len,
6952         &e_spec,
6953         &e_len,
6954         &vs_spec,
6955         &vs_len);
6956   if (sts == 0) {
6957     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
6958        replacement, because the above parse just took care of most of
6959        what is needed to do vmspath when the specification is already
6960        in VMS format.
6961
6962        And if it is not already, it is easier to do the conversion as
6963        part of this routine than to call this routine and then work on
6964        the result.
6965      */
6966
6967     /* If VMS punctuation was found, it is already VMS format */
6968     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
6969       if (utf8_flag != NULL)
6970         *utf8_flag = 0;
6971       strcpy(rslt, path);
6972       return rslt;
6973     }
6974     /* Now, what to do with trailing "." cases where there is no
6975        extension?  If this is a UNIX specification, and EFS characters
6976        are enabled, then the trailing "." should be converted to a "^.".
6977        But if this was already a VMS specification, then it should be
6978        left alone.
6979
6980        So in the case of ambiguity, leave the specification alone.
6981      */
6982
6983
6984     /* If there is a possibility of UTF8, then if any UTF8 characters
6985         are present, then they must be converted to VTF-7
6986      */
6987     if (utf8_flag != NULL)
6988       *utf8_flag = 0;
6989     strcpy(rslt, path);
6990     return rslt;
6991   }
6992
6993   dirend = strrchr(path,'/');
6994
6995   if (dirend == NULL) {
6996      /* If we get here with no UNIX directory delimiters, then this is
6997         not a complete file specification, either garbage a UNIX glob
6998         specification that can not be converted to a VMS wildcard, or
6999         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7000         so apparently other programs expect this also.
7001
7002         utf8 flag setting needs to be preserved.
7003       */
7004       strcpy(rslt, path);
7005       return rslt;
7006   }
7007
7008 /* If POSIX mode active, handle the conversion */
7009 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7010   if (decc_efs_charset) {
7011     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7012     return rslt;
7013   }
7014 #endif
7015
7016   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7017     if (!*(dirend+2)) dirend +=2;
7018     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7019     if (decc_efs_charset == 0) {
7020       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7021     }
7022   }
7023
7024   cp1 = rslt;
7025   cp2 = path;
7026   lastdot = strrchr(cp2,'.');
7027   if (*cp2 == '/') {
7028     char *trndev;
7029     int islnm, rooted;
7030     STRLEN trnend;
7031
7032     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7033     if (!*(cp2+1)) {
7034       if (decc_disable_posix_root) {
7035         strcpy(rslt,"sys$disk:[000000]");
7036       }
7037       else {
7038         strcpy(rslt,"sys$posix_root:[000000]");
7039       }
7040       if (utf8_flag != NULL)
7041         *utf8_flag = 0;
7042       return rslt;
7043     }
7044     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7045     *cp1 = '\0';
7046     trndev = PerlMem_malloc(VMS_MAXRSS);
7047     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7048     islnm =  my_trnlnm(rslt,trndev,0);
7049
7050      /* DECC special handling */
7051     if (!islnm) {
7052       if (strcmp(rslt,"bin") == 0) {
7053         strcpy(rslt,"sys$system");
7054         cp1 = rslt + 10;
7055         *cp1 = 0;
7056         islnm =  my_trnlnm(rslt,trndev,0);
7057       }
7058       else if (strcmp(rslt,"tmp") == 0) {
7059         strcpy(rslt,"sys$scratch");
7060         cp1 = rslt + 11;
7061         *cp1 = 0;
7062         islnm =  my_trnlnm(rslt,trndev,0);
7063       }
7064       else if (!decc_disable_posix_root) {
7065         strcpy(rslt, "sys$posix_root");
7066         cp1 = rslt + 13;
7067         *cp1 = 0;
7068         cp2 = path;
7069         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7070         islnm =  my_trnlnm(rslt,trndev,0);
7071       }
7072       else if (strcmp(rslt,"dev") == 0) {
7073         if (strncmp(cp2,"/null", 5) == 0) {
7074           if ((cp2[5] == 0) || (cp2[5] == '/')) {
7075             strcpy(rslt,"NLA0");
7076             cp1 = rslt + 4;
7077             *cp1 = 0;
7078             cp2 = cp2 + 5;
7079             islnm =  my_trnlnm(rslt,trndev,0);
7080           }
7081         }
7082       }
7083     }
7084
7085     trnend = islnm ? strlen(trndev) - 1 : 0;
7086     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7087     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7088     /* If the first element of the path is a logical name, determine
7089      * whether it has to be translated so we can add more directories. */
7090     if (!islnm || rooted) {
7091       *(cp1++) = ':';
7092       *(cp1++) = '[';
7093       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7094       else cp2++;
7095     }
7096     else {
7097       if (cp2 != dirend) {
7098         strcpy(rslt,trndev);
7099         cp1 = rslt + trnend;
7100         if (*cp2 != 0) {
7101           *(cp1++) = '.';
7102           cp2++;
7103         }
7104       }
7105       else {
7106         if (decc_disable_posix_root) {
7107           *(cp1++) = ':';
7108           hasdir = 0;
7109         }
7110       }
7111     }
7112     PerlMem_free(trndev);
7113   }
7114   else {
7115     *(cp1++) = '[';
7116     if (*cp2 == '.') {
7117       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7118         cp2 += 2;         /* skip over "./" - it's redundant */
7119         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
7120       }
7121       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7122         *(cp1++) = '-';                                 /* "../" --> "-" */
7123         cp2 += 3;
7124       }
7125       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7126                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7127         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7128         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7129         cp2 += 4;
7130       }
7131       else if ((cp2 != lastdot) || (lastdot < dirend)) {
7132         /* Escape the extra dots in EFS file specifications */
7133         *(cp1++) = '^';
7134       }
7135       if (cp2 > dirend) cp2 = dirend;
7136     }
7137     else *(cp1++) = '.';
7138   }
7139   for (; cp2 < dirend; cp2++) {
7140     if (*cp2 == '/') {
7141       if (*(cp2-1) == '/') continue;
7142       if (*(cp1-1) != '.') *(cp1++) = '.';
7143       infront = 0;
7144     }
7145     else if (!infront && *cp2 == '.') {
7146       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7147       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
7148       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7149         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7150         else if (*(cp1-2) == '[') *(cp1-1) = '-';
7151         else {  /* back up over previous directory name */
7152           cp1--;
7153           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7154           if (*(cp1-1) == '[') {
7155             memcpy(cp1,"000000.",7);
7156             cp1 += 7;
7157           }
7158         }
7159         cp2 += 2;
7160         if (cp2 == dirend) break;
7161       }
7162       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7163                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7164         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7165         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7166         if (!*(cp2+3)) {
7167           *(cp1++) = '.';  /* Simulate trailing '/' */
7168           cp2 += 2;  /* for loop will incr this to == dirend */
7169         }
7170         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
7171       }
7172       else {
7173         if (decc_efs_charset == 0)
7174           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
7175         else {
7176           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
7177           *(cp1++) = '.';
7178         }
7179       }
7180     }
7181     else {
7182       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
7183       if (*cp2 == '.') {
7184         if (decc_efs_charset == 0)
7185           *(cp1++) = '_';
7186         else {
7187           *(cp1++) = '^';
7188           *(cp1++) = '.';
7189         }
7190       }
7191       else                  *(cp1++) =  *cp2;
7192       infront = 1;
7193     }
7194   }
7195   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7196   if (hasdir) *(cp1++) = ']';
7197   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
7198   /* fixme for ODS5 */
7199   no_type_seen = 0;
7200   if (cp2 > lastdot)
7201     no_type_seen = 1;
7202   while (*cp2) {
7203     switch(*cp2) {
7204     case '?':
7205         if (decc_efs_charset == 0)
7206           *(cp1++) = '%';
7207         else
7208           *(cp1++) = '?';
7209         cp2++;
7210     case ' ':
7211         *(cp1)++ = '^';
7212         *(cp1)++ = '_';
7213         cp2++;
7214         break;
7215     case '.':
7216         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7217             decc_readdir_dropdotnotype) {
7218           *(cp1)++ = '^';
7219           *(cp1)++ = '.';
7220           cp2++;
7221
7222           /* trailing dot ==> '^..' on VMS */
7223           if (*cp2 == '\0') {
7224             *(cp1++) = '.';
7225             no_type_seen = 0;
7226           }
7227         }
7228         else {
7229           *(cp1++) = *(cp2++);
7230           no_type_seen = 0;
7231         }
7232         break;
7233     case '$':
7234          /* This could be a macro to be passed through */
7235         *(cp1++) = *(cp2++);
7236         if (*cp2 == '(') {
7237         const char * save_cp2;
7238         char * save_cp1;
7239         int is_macro;
7240
7241             /* paranoid check */
7242             save_cp2 = cp2;
7243             save_cp1 = cp1;
7244             is_macro = 0;
7245
7246             /* Test through */
7247             *(cp1++) = *(cp2++);
7248             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7249                 *(cp1++) = *(cp2++);
7250                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7251                     *(cp1++) = *(cp2++);
7252                 }
7253                 if (*cp2 == ')') {
7254                     *(cp1++) = *(cp2++);
7255                     is_macro = 1;
7256                 }
7257             }
7258             if (is_macro == 0) {
7259                 /* Not really a macro - never mind */
7260                 cp2 = save_cp2;
7261                 cp1 = save_cp1;
7262             }
7263         }
7264         break;
7265     case '\"':
7266     case '~':
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         *(cp1++) = '^';
7289         *(cp1++) = *(cp2++);
7290         break;
7291     case ';':
7292         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7293          * which is wrong.  UNIX notation should be ".dir." unless
7294          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7295          * changing this behavior could break more things at this time.
7296          * efs character set effectively does not allow "." to be a version
7297          * delimiter as a further complication about changing this.
7298          */
7299         if (decc_filename_unix_report != 0) {
7300           *(cp1++) = '^';
7301         }
7302         *(cp1++) = *(cp2++);
7303         break;
7304     default:
7305         *(cp1++) = *(cp2++);
7306     }
7307   }
7308   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7309   char *lcp1;
7310     lcp1 = cp1;
7311     lcp1--;
7312      /* Fix me for "^]", but that requires making sure that you do
7313       * not back up past the start of the filename
7314       */
7315     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7316       *cp1++ = '.';
7317   }
7318   *cp1 = '\0';
7319
7320   if (utf8_flag != NULL)
7321     *utf8_flag = 0;
7322   return rslt;
7323
7324 }  /* end of do_tovmsspec() */
7325 /*}}}*/
7326 /* External entry points */
7327 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7328   { return do_tovmsspec(path,buf,0,NULL); }
7329 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7330   { return do_tovmsspec(path,buf,1,NULL); }
7331 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7332   { return do_tovmsspec(path,buf,0,utf8_fl); }
7333 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7334   { return do_tovmsspec(path,buf,1,utf8_fl); }
7335
7336 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7337 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7338   static char __tovmspath_retbuf[VMS_MAXRSS];
7339   int vmslen;
7340   char *pathified, *vmsified, *cp;
7341
7342   if (path == NULL) return NULL;
7343   pathified = PerlMem_malloc(VMS_MAXRSS);
7344   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7345   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7346     PerlMem_free(pathified);
7347     return NULL;
7348   }
7349
7350   vmsified = NULL;
7351   if (buf == NULL)
7352      Newx(vmsified, VMS_MAXRSS, char);
7353   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7354     PerlMem_free(pathified);
7355     if (vmsified) Safefree(vmsified);
7356     return NULL;
7357   }
7358   PerlMem_free(pathified);
7359   if (buf) {
7360     return buf;
7361   }
7362   else if (ts) {
7363     vmslen = strlen(vmsified);
7364     Newx(cp,vmslen+1,char);
7365     memcpy(cp,vmsified,vmslen);
7366     cp[vmslen] = '\0';
7367     Safefree(vmsified);
7368     return cp;
7369   }
7370   else {
7371     strcpy(__tovmspath_retbuf,vmsified);
7372     Safefree(vmsified);
7373     return __tovmspath_retbuf;
7374   }
7375
7376 }  /* end of do_tovmspath() */
7377 /*}}}*/
7378 /* External entry points */
7379 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7380   { return do_tovmspath(path,buf,0, NULL); }
7381 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7382   { return do_tovmspath(path,buf,1, NULL); }
7383 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7384   { return do_tovmspath(path,buf,0,utf8_fl); }
7385 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7386   { return do_tovmspath(path,buf,1,utf8_fl); }
7387
7388
7389 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7390 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7391   static char __tounixpath_retbuf[VMS_MAXRSS];
7392   int unixlen;
7393   char *pathified, *unixified, *cp;
7394
7395   if (path == NULL) return NULL;
7396   pathified = PerlMem_malloc(VMS_MAXRSS);
7397   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7398   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7399     PerlMem_free(pathified);
7400     return NULL;
7401   }
7402
7403   unixified = NULL;
7404   if (buf == NULL) {
7405       Newx(unixified, VMS_MAXRSS, char);
7406   }
7407   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7408     PerlMem_free(pathified);
7409     if (unixified) Safefree(unixified);
7410     return NULL;
7411   }
7412   PerlMem_free(pathified);
7413   if (buf) {
7414     return buf;
7415   }
7416   else if (ts) {
7417     unixlen = strlen(unixified);
7418     Newx(cp,unixlen+1,char);
7419     memcpy(cp,unixified,unixlen);
7420     cp[unixlen] = '\0';
7421     Safefree(unixified);
7422     return cp;
7423   }
7424   else {
7425     strcpy(__tounixpath_retbuf,unixified);
7426     Safefree(unixified);
7427     return __tounixpath_retbuf;
7428   }
7429
7430 }  /* end of do_tounixpath() */
7431 /*}}}*/
7432 /* External entry points */
7433 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7434   { return do_tounixpath(path,buf,0,NULL); }
7435 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7436   { return do_tounixpath(path,buf,1,NULL); }
7437 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7438   { return do_tounixpath(path,buf,0,utf8_fl); }
7439 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7440   { return do_tounixpath(path,buf,1,utf8_fl); }
7441
7442 /*
7443  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
7444  *
7445  *****************************************************************************
7446  *                                                                           *
7447  *  Copyright (C) 1989-1994 by                                               *
7448  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
7449  *                                                                           *
7450  *  Permission is hereby  granted for the reproduction of this software,     *
7451  *  on condition that this copyright notice is included in the reproduction, *
7452  *  and that such reproduction is not for purposes of profit or material     *
7453  *  gain.                                                                    *
7454  *                                                                           *
7455  *  27-Aug-1994 Modified for inclusion in perl5                              *
7456  *              by Charles Bailey  bailey@newman.upenn.edu                   *
7457  *****************************************************************************
7458  */
7459
7460 /*
7461  * getredirection() is intended to aid in porting C programs
7462  * to VMS (Vax-11 C).  The native VMS environment does not support
7463  * '>' and '<' I/O redirection, or command line wild card expansion,
7464  * or a command line pipe mechanism using the '|' AND background
7465  * command execution '&'.  All of these capabilities are provided to any
7466  * C program which calls this procedure as the first thing in the
7467  * main program.
7468  * The piping mechanism will probably work with almost any 'filter' type
7469  * of program.  With suitable modification, it may useful for other
7470  * portability problems as well.
7471  *
7472  * Author:  Mark Pizzolato      mark@infocomm.com
7473  */
7474 struct list_item
7475     {
7476     struct list_item *next;
7477     char *value;
7478     };
7479
7480 static void add_item(struct list_item **head,
7481                      struct list_item **tail,
7482                      char *value,
7483                      int *count);
7484
7485 static void mp_expand_wild_cards(pTHX_ char *item,
7486                                 struct list_item **head,
7487                                 struct list_item **tail,
7488                                 int *count);
7489
7490 static int background_process(pTHX_ int argc, char **argv);
7491
7492 static void pipe_and_fork(pTHX_ char **cmargv);
7493
7494 /*{{{ void getredirection(int *ac, char ***av)*/
7495 static void
7496 mp_getredirection(pTHX_ int *ac, char ***av)
7497 /*
7498  * Process vms redirection arg's.  Exit if any error is seen.
7499  * If getredirection() processes an argument, it is erased
7500  * from the vector.  getredirection() returns a new argc and argv value.
7501  * In the event that a background command is requested (by a trailing "&"),
7502  * this routine creates a background subprocess, and simply exits the program.
7503  *
7504  * Warning: do not try to simplify the code for vms.  The code
7505  * presupposes that getredirection() is called before any data is
7506  * read from stdin or written to stdout.
7507  *
7508  * Normal usage is as follows:
7509  *
7510  *      main(argc, argv)
7511  *      int             argc;
7512  *      char            *argv[];
7513  *      {
7514  *              getredirection(&argc, &argv);
7515  *      }
7516  */
7517 {
7518     int                 argc = *ac;     /* Argument Count         */
7519     char                **argv = *av;   /* Argument Vector        */
7520     char                *ap;            /* Argument pointer       */
7521     int                 j;              /* argv[] index           */
7522     int                 item_count = 0; /* Count of Items in List */
7523     struct list_item    *list_head = 0; /* First Item in List       */
7524     struct list_item    *list_tail;     /* Last Item in List        */
7525     char                *in = NULL;     /* Input File Name          */
7526     char                *out = NULL;    /* Output File Name         */
7527     char                *outmode = "w"; /* Mode to Open Output File */
7528     char                *err = NULL;    /* Error File Name          */
7529     char                *errmode = "w"; /* Mode to Open Error File  */
7530     int                 cmargc = 0;     /* Piped Command Arg Count  */
7531     char                **cmargv = NULL;/* Piped Command Arg Vector */
7532
7533     /*
7534      * First handle the case where the last thing on the line ends with
7535      * a '&'.  This indicates the desire for the command to be run in a
7536      * subprocess, so we satisfy that desire.
7537      */
7538     ap = argv[argc-1];
7539     if (0 == strcmp("&", ap))
7540        exit(background_process(aTHX_ --argc, argv));
7541     if (*ap && '&' == ap[strlen(ap)-1])
7542         {
7543         ap[strlen(ap)-1] = '\0';
7544        exit(background_process(aTHX_ argc, argv));
7545         }
7546     /*
7547      * Now we handle the general redirection cases that involve '>', '>>',
7548      * '<', and pipes '|'.
7549      */
7550     for (j = 0; j < argc; ++j)
7551         {
7552         if (0 == strcmp("<", argv[j]))
7553             {
7554             if (j+1 >= argc)
7555                 {
7556                 fprintf(stderr,"No input file after < on command line");
7557                 exit(LIB$_WRONUMARG);
7558                 }
7559             in = argv[++j];
7560             continue;
7561             }
7562         if ('<' == *(ap = argv[j]))
7563             {
7564             in = 1 + ap;
7565             continue;
7566             }
7567         if (0 == strcmp(">", ap))
7568             {
7569             if (j+1 >= argc)
7570                 {
7571                 fprintf(stderr,"No output file after > on command line");
7572                 exit(LIB$_WRONUMARG);
7573                 }
7574             out = argv[++j];
7575             continue;
7576             }
7577         if ('>' == *ap)
7578             {
7579             if ('>' == ap[1])
7580                 {
7581                 outmode = "a";
7582                 if ('\0' == ap[2])
7583                     out = argv[++j];
7584                 else
7585                     out = 2 + ap;
7586                 }
7587             else
7588                 out = 1 + ap;
7589             if (j >= argc)
7590                 {
7591                 fprintf(stderr,"No output file after > or >> on command line");
7592                 exit(LIB$_WRONUMARG);
7593                 }
7594             continue;
7595             }
7596         if (('2' == *ap) && ('>' == ap[1]))
7597             {
7598             if ('>' == ap[2])
7599                 {
7600                 errmode = "a";
7601                 if ('\0' == ap[3])
7602                     err = argv[++j];
7603                 else
7604                     err = 3 + ap;
7605                 }
7606             else
7607                 if ('\0' == ap[2])
7608                     err = argv[++j];
7609                 else
7610                     err = 2 + ap;
7611             if (j >= argc)
7612                 {
7613                 fprintf(stderr,"No output file after 2> or 2>> on command line");
7614                 exit(LIB$_WRONUMARG);
7615                 }
7616             continue;
7617             }
7618         if (0 == strcmp("|", argv[j]))
7619             {
7620             if (j+1 >= argc)
7621                 {
7622                 fprintf(stderr,"No command into which to pipe on command line");
7623                 exit(LIB$_WRONUMARG);
7624                 }
7625             cmargc = argc-(j+1);
7626             cmargv = &argv[j+1];
7627             argc = j;
7628             continue;
7629             }
7630         if ('|' == *(ap = argv[j]))
7631             {
7632             ++argv[j];
7633             cmargc = argc-j;
7634             cmargv = &argv[j];
7635             argc = j;
7636             continue;
7637             }
7638         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7639         }
7640     /*
7641      * Allocate and fill in the new argument vector, Some Unix's terminate
7642      * the list with an extra null pointer.
7643      */
7644     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7645     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7646     *av = argv;
7647     for (j = 0; j < item_count; ++j, list_head = list_head->next)
7648         argv[j] = list_head->value;
7649     *ac = item_count;
7650     if (cmargv != NULL)
7651         {
7652         if (out != NULL)
7653             {
7654             fprintf(stderr,"'|' and '>' may not both be specified on command line");
7655             exit(LIB$_INVARGORD);
7656             }
7657         pipe_and_fork(aTHX_ cmargv);
7658         }
7659
7660     /* Check for input from a pipe (mailbox) */
7661
7662     if (in == NULL && 1 == isapipe(0))
7663         {
7664         char mbxname[L_tmpnam];
7665         long int bufsize;
7666         long int dvi_item = DVI$_DEVBUFSIZ;
7667         $DESCRIPTOR(mbxnam, "");
7668         $DESCRIPTOR(mbxdevnam, "");
7669
7670         /* Input from a pipe, reopen it in binary mode to disable       */
7671         /* carriage control processing.                                 */
7672
7673         fgetname(stdin, mbxname);
7674         mbxnam.dsc$a_pointer = mbxname;
7675         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7676         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7677         mbxdevnam.dsc$a_pointer = mbxname;
7678         mbxdevnam.dsc$w_length = sizeof(mbxname);
7679         dvi_item = DVI$_DEVNAM;
7680         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7681         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7682         set_errno(0);
7683         set_vaxc_errno(1);
7684         freopen(mbxname, "rb", stdin);
7685         if (errno != 0)
7686             {
7687             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7688             exit(vaxc$errno);
7689             }
7690         }
7691     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7692         {
7693         fprintf(stderr,"Can't open input file %s as stdin",in);
7694         exit(vaxc$errno);
7695         }
7696     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7697         {
7698         fprintf(stderr,"Can't open output file %s as stdout",out);
7699         exit(vaxc$errno);
7700         }
7701         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7702
7703     if (err != NULL) {
7704         if (strcmp(err,"&1") == 0) {
7705             dup2(fileno(stdout), fileno(stderr));
7706             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7707         } else {
7708         FILE *tmperr;
7709         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7710             {
7711             fprintf(stderr,"Can't open error file %s as stderr",err);
7712             exit(vaxc$errno);
7713             }
7714             fclose(tmperr);
7715            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7716                 {
7717                 exit(vaxc$errno);
7718                 }
7719             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7720         }
7721         }
7722 #ifdef ARGPROC_DEBUG
7723     PerlIO_printf(Perl_debug_log, "Arglist:\n");
7724     for (j = 0; j < *ac;  ++j)
7725         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7726 #endif
7727    /* Clear errors we may have hit expanding wildcards, so they don't
7728       show up in Perl's $! later */
7729    set_errno(0); set_vaxc_errno(1);
7730 }  /* end of getredirection() */
7731 /*}}}*/
7732
7733 static void add_item(struct list_item **head,
7734                      struct list_item **tail,
7735                      char *value,
7736                      int *count)
7737 {
7738     if (*head == 0)
7739         {
7740         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7741         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7742         *tail = *head;
7743         }
7744     else {
7745         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7746         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7747         *tail = (*tail)->next;
7748         }
7749     (*tail)->value = value;
7750     ++(*count);
7751 }
7752
7753 static void mp_expand_wild_cards(pTHX_ char *item,
7754                               struct list_item **head,
7755                               struct list_item **tail,
7756                               int *count)
7757 {
7758 int expcount = 0;
7759 unsigned long int context = 0;
7760 int isunix = 0;
7761 int item_len = 0;
7762 char *had_version;
7763 char *had_device;
7764 int had_directory;
7765 char *devdir,*cp;
7766 char *vmsspec;
7767 $DESCRIPTOR(filespec, "");
7768 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
7769 $DESCRIPTOR(resultspec, "");
7770 unsigned long int lff_flags = 0;
7771 int sts;
7772 int rms_sts;
7773
7774 #ifdef VMS_LONGNAME_SUPPORT
7775     lff_flags = LIB$M_FIL_LONG_NAMES;
7776 #endif
7777
7778     for (cp = item; *cp; cp++) {
7779         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
7780         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
7781     }
7782     if (!*cp || isspace(*cp))
7783         {
7784         add_item(head, tail, item, count);
7785         return;
7786         }
7787     else
7788         {
7789      /* "double quoted" wild card expressions pass as is */
7790      /* From DCL that means using e.g.:                  */
7791      /* perl program """perl.*"""                        */
7792      item_len = strlen(item);
7793      if ( '"' == *item && '"' == item[item_len-1] )
7794        {
7795        item++;
7796        item[item_len-2] = '\0';
7797        add_item(head, tail, item, count);
7798        return;
7799        }
7800      }
7801     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
7802     resultspec.dsc$b_class = DSC$K_CLASS_D;
7803     resultspec.dsc$a_pointer = NULL;
7804     vmsspec = PerlMem_malloc(VMS_MAXRSS);
7805     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7806     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
7807       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
7808     if (!isunix || !filespec.dsc$a_pointer)
7809       filespec.dsc$a_pointer = item;
7810     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
7811     /*
7812      * Only return version specs, if the caller specified a version
7813      */
7814     had_version = strchr(item, ';');
7815     /*
7816      * Only return device and directory specs, if the caller specifed either.
7817      */
7818     had_device = strchr(item, ':');
7819     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
7820
7821     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
7822                                  (&filespec, &resultspec, &context,
7823                                   &defaultspec, 0, &rms_sts, &lff_flags)))
7824         {
7825         char *string;
7826         char *c;
7827
7828         string = PerlMem_malloc(resultspec.dsc$w_length+1);
7829         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7830         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
7831         string[resultspec.dsc$w_length] = '\0';
7832         if (NULL == had_version)
7833             *(strrchr(string, ';')) = '\0';
7834         if ((!had_directory) && (had_device == NULL))
7835             {
7836             if (NULL == (devdir = strrchr(string, ']')))
7837                 devdir = strrchr(string, '>');
7838             strcpy(string, devdir + 1);
7839             }
7840         /*
7841          * Be consistent with what the C RTL has already done to the rest of
7842          * the argv items and lowercase all of these names.
7843          */
7844         if (!decc_efs_case_preserve) {
7845             for (c = string; *c; ++c)
7846             if (isupper(*c))
7847                 *c = tolower(*c);
7848         }
7849         if (isunix) trim_unixpath(string,item,1);
7850         add_item(head, tail, string, count);
7851         ++expcount;
7852     }
7853     PerlMem_free(vmsspec);
7854     if (sts != RMS$_NMF)
7855         {
7856         set_vaxc_errno(sts);
7857         switch (sts)
7858             {
7859             case RMS$_FNF: case RMS$_DNF:
7860                 set_errno(ENOENT); break;
7861             case RMS$_DIR:
7862                 set_errno(ENOTDIR); break;
7863             case RMS$_DEV:
7864                 set_errno(ENODEV); break;
7865             case RMS$_FNM: case RMS$_SYN:
7866                 set_errno(EINVAL); break;
7867             case RMS$_PRV:
7868                 set_errno(EACCES); break;
7869             default:
7870                 _ckvmssts_noperl(sts);
7871             }
7872         }
7873     if (expcount == 0)
7874         add_item(head, tail, item, count);
7875     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
7876     _ckvmssts_noperl(lib$find_file_end(&context));
7877 }
7878
7879 static int child_st[2];/* Event Flag set when child process completes   */
7880
7881 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
7882
7883 static unsigned long int exit_handler(int *status)
7884 {
7885 short iosb[4];
7886
7887     if (0 == child_st[0])
7888         {
7889 #ifdef ARGPROC_DEBUG
7890         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
7891 #endif
7892         fflush(stdout);     /* Have to flush pipe for binary data to    */
7893                             /* terminate properly -- <tp@mccall.com>    */
7894         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
7895         sys$dassgn(child_chan);
7896         fclose(stdout);
7897         sys$synch(0, child_st);
7898         }
7899     return(1);
7900 }
7901
7902 static void sig_child(int chan)
7903 {
7904 #ifdef ARGPROC_DEBUG
7905     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
7906 #endif
7907     if (child_st[0] == 0)
7908         child_st[0] = 1;
7909 }
7910
7911 static struct exit_control_block exit_block =
7912     {
7913     0,
7914     exit_handler,
7915     1,
7916     &exit_block.exit_status,
7917     0
7918     };
7919
7920 static void
7921 pipe_and_fork(pTHX_ char **cmargv)
7922 {
7923     PerlIO *fp;
7924     struct dsc$descriptor_s *vmscmd;
7925     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
7926     int sts, j, l, ismcr, quote, tquote = 0;
7927
7928     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
7929     vms_execfree(vmscmd);
7930
7931     j = l = 0;
7932     p = subcmd;
7933     q = cmargv[0];
7934     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
7935               && toupper(*(q+2)) == 'R' && !*(q+3);
7936
7937     while (q && l < MAX_DCL_LINE_LENGTH) {
7938         if (!*q) {
7939             if (j > 0 && quote) {
7940                 *p++ = '"';
7941                 l++;
7942             }
7943             q = cmargv[++j];
7944             if (q) {
7945                 if (ismcr && j > 1) quote = 1;
7946                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
7947                 *p++ = ' ';
7948                 l++;
7949                 if (quote || tquote) {
7950                     *p++ = '"';
7951                     l++;
7952                 }
7953             }
7954         } else {
7955             if ((quote||tquote) && *q == '"') {
7956                 *p++ = '"';
7957                 l++;
7958             }
7959             *p++ = *q++;
7960             l++;
7961         }
7962     }
7963     *p = '\0';
7964
7965     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7966     if (fp == Nullfp) {
7967         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7968     }
7969 }
7970
7971 static int background_process(pTHX_ int argc, char **argv)
7972 {
7973 char command[MAX_DCL_SYMBOL + 1] = "$";
7974 $DESCRIPTOR(value, "");
7975 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7976 static $DESCRIPTOR(null, "NLA0:");
7977 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7978 char pidstring[80];
7979 $DESCRIPTOR(pidstr, "");
7980 int pid;
7981 unsigned long int flags = 17, one = 1, retsts;
7982 int len;
7983
7984     strcat(command, argv[0]);
7985     len = strlen(command);
7986     while (--argc && (len < MAX_DCL_SYMBOL))
7987         {
7988         strcat(command, " \"");
7989         strcat(command, *(++argv));
7990         strcat(command, "\"");
7991         len = strlen(command);
7992         }
7993     value.dsc$a_pointer = command;
7994     value.dsc$w_length = strlen(value.dsc$a_pointer);
7995     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7996     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7997     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7998         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
7999     }
8000     else {
8001         _ckvmssts_noperl(retsts);
8002     }
8003 #ifdef ARGPROC_DEBUG
8004     PerlIO_printf(Perl_debug_log, "%s\n", command);
8005 #endif
8006     sprintf(pidstring, "%08X", pid);
8007     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8008     pidstr.dsc$a_pointer = pidstring;
8009     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8010     lib$set_symbol(&pidsymbol, &pidstr);
8011     return(SS$_NORMAL);
8012 }
8013 /*}}}*/
8014 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8015
8016
8017 /* OS-specific initialization at image activation (not thread startup) */
8018 /* Older VAXC header files lack these constants */
8019 #ifndef JPI$_RIGHTS_SIZE
8020 #  define JPI$_RIGHTS_SIZE 817
8021 #endif
8022 #ifndef KGB$M_SUBSYSTEM
8023 #  define KGB$M_SUBSYSTEM 0x8
8024 #endif
8025
8026 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8027
8028 /*{{{void vms_image_init(int *, char ***)*/
8029 void
8030 vms_image_init(int *argcp, char ***argvp)
8031 {
8032   char eqv[LNM$C_NAMLENGTH+1] = "";
8033   unsigned int len, tabct = 8, tabidx = 0;
8034   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8035   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8036   unsigned short int dummy, rlen;
8037   struct dsc$descriptor_s **tabvec;
8038 #if defined(PERL_IMPLICIT_CONTEXT)
8039   pTHX = NULL;
8040 #endif
8041   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8042                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8043                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8044                                  {          0,                0,    0,      0} };
8045
8046 #ifdef KILL_BY_SIGPRC
8047     Perl_csighandler_init();
8048 #endif
8049
8050   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8051   _ckvmssts_noperl(iosb[0]);
8052   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8053     if (iprv[i]) {           /* Running image installed with privs? */
8054       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8055       will_taint = TRUE;
8056       break;
8057     }
8058   }
8059   /* Rights identifiers might trigger tainting as well. */
8060   if (!will_taint && (rlen || rsz)) {
8061     while (rlen < rsz) {
8062       /* We didn't get all the identifiers on the first pass.  Allocate a
8063        * buffer much larger than $GETJPI wants (rsz is size in bytes that
8064        * were needed to hold all identifiers at time of last call; we'll
8065        * allocate that many unsigned long ints), and go back and get 'em.
8066        * If it gave us less than it wanted to despite ample buffer space,
8067        * something's broken.  Is your system missing a system identifier?
8068        */
8069       if (rsz <= jpilist[1].buflen) {
8070          /* Perl_croak accvios when used this early in startup. */
8071          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8072                          rsz, (unsigned long) jpilist[1].buflen,
8073                          "Check your rights database for corruption.\n");
8074          exit(SS$_ABORT);
8075       }
8076       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8077       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8078       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8079       jpilist[1].buflen = rsz * sizeof(unsigned long int);
8080       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8081       _ckvmssts_noperl(iosb[0]);
8082     }
8083     mask = jpilist[1].bufadr;
8084     /* Check attribute flags for each identifier (2nd longword); protected
8085      * subsystem identifiers trigger tainting.
8086      */
8087     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8088       if (mask[i] & KGB$M_SUBSYSTEM) {
8089         will_taint = TRUE;
8090         break;
8091       }
8092     }
8093     if (mask != rlst) PerlMem_free(mask);
8094   }
8095
8096   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8097    * logical, some versions of the CRTL will add a phanthom /000000/
8098    * directory.  This needs to be removed.
8099    */
8100   if (decc_filename_unix_report) {
8101   char * zeros;
8102   int ulen;
8103     ulen = strlen(argvp[0][0]);
8104     if (ulen > 7) {
8105       zeros = strstr(argvp[0][0], "/000000/");
8106       if (zeros != NULL) {
8107         int mlen;
8108         mlen = ulen - (zeros - argvp[0][0]) - 7;
8109         memmove(zeros, &zeros[7], mlen);
8110         ulen = ulen - 7;
8111         argvp[0][0][ulen] = '\0';
8112       }
8113     }
8114     /* It also may have a trailing dot that needs to be removed otherwise
8115      * it will be converted to VMS mode incorrectly.
8116      */
8117     ulen--;
8118     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8119       argvp[0][0][ulen] = '\0';
8120   }
8121
8122   /* We need to use this hack to tell Perl it should run with tainting,
8123    * since its tainting flag may be part of the PL_curinterp struct, which
8124    * hasn't been allocated when vms_image_init() is called.
8125    */
8126   if (will_taint) {
8127     char **newargv, **oldargv;
8128     oldargv = *argvp;
8129     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8130     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8131     newargv[0] = oldargv[0];
8132     newargv[1] = PerlMem_malloc(3 * sizeof(char));
8133     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8134     strcpy(newargv[1], "-T");
8135     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8136     (*argcp)++;
8137     newargv[*argcp] = NULL;
8138     /* We orphan the old argv, since we don't know where it's come from,
8139      * so we don't know how to free it.
8140      */
8141     *argvp = newargv;
8142   }
8143   else {  /* Did user explicitly request tainting? */
8144     int i;
8145     char *cp, **av = *argvp;
8146     for (i = 1; i < *argcp; i++) {
8147       if (*av[i] != '-') break;
8148       for (cp = av[i]+1; *cp; cp++) {
8149         if (*cp == 'T') { will_taint = 1; break; }
8150         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8151                   strchr("DFIiMmx",*cp)) break;
8152       }
8153       if (will_taint) break;
8154     }
8155   }
8156
8157   for (tabidx = 0;
8158        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8159        tabidx++) {
8160     if (!tabidx) {
8161       tabvec = (struct dsc$descriptor_s **)
8162             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8163       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8164     }
8165     else if (tabidx >= tabct) {
8166       tabct += 8;
8167       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8168       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8169     }
8170     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8171     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8172     tabvec[tabidx]->dsc$w_length  = 0;
8173     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
8174     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
8175     tabvec[tabidx]->dsc$a_pointer = NULL;
8176     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8177   }
8178   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8179
8180   getredirection(argcp,argvp);
8181 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8182   {
8183 # include <reentrancy.h>
8184   decc$set_reentrancy(C$C_MULTITHREAD);
8185   }
8186 #endif
8187   return;
8188 }
8189 /*}}}*/
8190
8191
8192 /* trim_unixpath()
8193  * Trim Unix-style prefix off filespec, so it looks like what a shell
8194  * glob expansion would return (i.e. from specified prefix on, not
8195  * full path).  Note that returned filespec is Unix-style, regardless
8196  * of whether input filespec was VMS-style or Unix-style.
8197  *
8198  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8199  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
8200  * vector of options; at present, only bit 0 is used, and if set tells
8201  * trim unixpath to try the current default directory as a prefix when
8202  * presented with a possibly ambiguous ... wildcard.
8203  *
8204  * Returns !=0 on success, with trimmed filespec replacing contents of
8205  * fspec, and 0 on failure, with contents of fpsec unchanged.
8206  */
8207 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8208 int
8209 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8210 {
8211   char *unixified, *unixwild,
8212        *template, *base, *end, *cp1, *cp2;
8213   register int tmplen, reslen = 0, dirs = 0;
8214
8215   unixwild = PerlMem_malloc(VMS_MAXRSS);
8216   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8217   if (!wildspec || !fspec) return 0;
8218   template = unixwild;
8219   if (strpbrk(wildspec,"]>:") != NULL) {
8220     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8221         PerlMem_free(unixwild);
8222         return 0;
8223     }
8224   }
8225   else {
8226     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8227     unixwild[VMS_MAXRSS-1] = 0;
8228   }
8229   unixified = PerlMem_malloc(VMS_MAXRSS);
8230   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8231   if (strpbrk(fspec,"]>:") != NULL) {
8232     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8233         PerlMem_free(unixwild);
8234         PerlMem_free(unixified);
8235         return 0;
8236     }
8237     else base = unixified;
8238     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8239      * check to see that final result fits into (isn't longer than) fspec */
8240     reslen = strlen(fspec);
8241   }
8242   else base = fspec;
8243
8244   /* No prefix or absolute path on wildcard, so nothing to remove */
8245   if (!*template || *template == '/') {
8246     PerlMem_free(unixwild);
8247     if (base == fspec) {
8248         PerlMem_free(unixified);
8249         return 1;
8250     }
8251     tmplen = strlen(unixified);
8252     if (tmplen > reslen) {
8253         PerlMem_free(unixified);
8254         return 0;  /* not enough space */
8255     }
8256     /* Copy unixified resultant, including trailing NUL */
8257     memmove(fspec,unixified,tmplen+1);
8258     PerlMem_free(unixified);
8259     return 1;
8260   }
8261
8262   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
8263   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8264     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8265     for (cp1 = end ;cp1 >= base; cp1--)
8266       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8267         { cp1++; break; }
8268     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8269     PerlMem_free(unixified);
8270     PerlMem_free(unixwild);
8271     return 1;
8272   }
8273   else {
8274     char *tpl, *lcres;
8275     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8276     int ells = 1, totells, segdirs, match;
8277     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8278                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8279
8280     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8281     totells = ells;
8282     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8283     tpl = PerlMem_malloc(VMS_MAXRSS);
8284     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8285     if (ellipsis == template && opts & 1) {
8286       /* Template begins with an ellipsis.  Since we can't tell how many
8287        * directory names at the front of the resultant to keep for an
8288        * arbitrary starting point, we arbitrarily choose the current
8289        * default directory as a starting point.  If it's there as a prefix,
8290        * clip it off.  If not, fall through and act as if the leading
8291        * ellipsis weren't there (i.e. return shortest possible path that
8292        * could match template).
8293        */
8294       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8295           PerlMem_free(tpl);
8296           PerlMem_free(unixified);
8297           PerlMem_free(unixwild);
8298           return 0;
8299       }
8300       if (!decc_efs_case_preserve) {
8301         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8302           if (_tolower(*cp1) != _tolower(*cp2)) break;
8303       }
8304       segdirs = dirs - totells;  /* Min # of dirs we must have left */
8305       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8306       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8307         memmove(fspec,cp2+1,end - cp2);
8308         PerlMem_free(tpl);
8309         PerlMem_free(unixified);
8310         PerlMem_free(unixwild);
8311         return 1;
8312       }
8313     }
8314     /* First off, back up over constant elements at end of path */
8315     if (dirs) {
8316       for (front = end ; front >= base; front--)
8317          if (*front == '/' && !dirs--) { front++; break; }
8318     }
8319     lcres = PerlMem_malloc(VMS_MAXRSS);
8320     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8321     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8322          cp1++,cp2++) {
8323             if (!decc_efs_case_preserve) {
8324                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
8325             }
8326             else {
8327                 *cp2 = *cp1;
8328             }
8329     }
8330     if (cp1 != '\0') {
8331         PerlMem_free(tpl);
8332         PerlMem_free(unixified);
8333         PerlMem_free(unixwild);
8334         PerlMem_free(lcres);
8335         return 0;  /* Path too long. */
8336     }
8337     lcend = cp2;
8338     *cp2 = '\0';  /* Pick up with memcpy later */
8339     lcfront = lcres + (front - base);
8340     /* Now skip over each ellipsis and try to match the path in front of it. */
8341     while (ells--) {
8342       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8343         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
8344             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
8345       if (cp1 < template) break; /* template started with an ellipsis */
8346       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8347         ellipsis = cp1; continue;
8348       }
8349       wilddsc.dsc$a_pointer = tpl;
8350       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8351       nextell = cp1;
8352       for (segdirs = 0, cp2 = tpl;
8353            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8354            cp1++, cp2++) {
8355          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8356          else {
8357             if (!decc_efs_case_preserve) {
8358               *cp2 = _tolower(*cp1);  /* else lowercase for match */
8359             }
8360             else {
8361               *cp2 = *cp1;  /* else preserve case for match */
8362             }
8363          }
8364          if (*cp2 == '/') segdirs++;
8365       }
8366       if (cp1 != ellipsis - 1) {
8367           PerlMem_free(tpl);
8368           PerlMem_free(unixified);
8369           PerlMem_free(unixwild);
8370           PerlMem_free(lcres);
8371           return 0; /* Path too long */
8372       }
8373       /* Back up at least as many dirs as in template before matching */
8374       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8375         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8376       for (match = 0; cp1 > lcres;) {
8377         resdsc.dsc$a_pointer = cp1;
8378         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8379           match++;
8380           if (match == 1) lcfront = cp1;
8381         }
8382         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8383       }
8384       if (!match) {
8385         PerlMem_free(tpl);
8386         PerlMem_free(unixified);
8387         PerlMem_free(unixwild);
8388         PerlMem_free(lcres);
8389         return 0;  /* Can't find prefix ??? */
8390       }
8391       if (match > 1 && opts & 1) {
8392         /* This ... wildcard could cover more than one set of dirs (i.e.
8393          * a set of similar dir names is repeated).  If the template
8394          * contains more than 1 ..., upstream elements could resolve the
8395          * ambiguity, but it's not worth a full backtracking setup here.
8396          * As a quick heuristic, clip off the current default directory
8397          * if it's present to find the trimmed spec, else use the
8398          * shortest string that this ... could cover.
8399          */
8400         char def[NAM$C_MAXRSS+1], *st;
8401
8402         if (getcwd(def, sizeof def,0) == NULL) {
8403             Safefree(unixified);
8404             Safefree(unixwild);
8405             Safefree(lcres);
8406             Safefree(tpl);
8407             return 0;
8408         }
8409         if (!decc_efs_case_preserve) {
8410           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8411             if (_tolower(*cp1) != _tolower(*cp2)) break;
8412         }
8413         segdirs = dirs - totells;  /* Min # of dirs we must have left */
8414         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8415         if (*cp1 == '\0' && *cp2 == '/') {
8416           memmove(fspec,cp2+1,end - cp2);
8417           PerlMem_free(tpl);
8418           PerlMem_free(unixified);
8419           PerlMem_free(unixwild);
8420           PerlMem_free(lcres);
8421           return 1;
8422         }
8423         /* Nope -- stick with lcfront from above and keep going. */
8424       }
8425     }
8426     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8427     PerlMem_free(tpl);
8428     PerlMem_free(unixified);
8429     PerlMem_free(unixwild);
8430     PerlMem_free(lcres);
8431     return 1;
8432     ellipsis = nextell;
8433   }
8434
8435 }  /* end of trim_unixpath() */
8436 /*}}}*/
8437
8438
8439 /*
8440  *  VMS readdir() routines.
8441  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8442  *
8443  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
8444  *  Minor modifications to original routines.
8445  */
8446
8447 /* readdir may have been redefined by reentr.h, so make sure we get
8448  * the local version for what we do here.
8449  */
8450 #ifdef readdir
8451 # undef readdir
8452 #endif
8453 #if !defined(PERL_IMPLICIT_CONTEXT)
8454 # define readdir Perl_readdir
8455 #else
8456 # define readdir(a) Perl_readdir(aTHX_ a)
8457 #endif
8458
8459     /* Number of elements in vms_versions array */
8460 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
8461
8462 /*
8463  *  Open a directory, return a handle for later use.
8464  */
8465 /*{{{ DIR *opendir(char*name) */
8466 DIR *
8467 Perl_opendir(pTHX_ const char *name)
8468 {
8469     DIR *dd;
8470     char *dir;
8471     Stat_t sb;
8472     int unix_flag;
8473
8474     unix_flag = 0;
8475     if (decc_efs_charset) {
8476         unix_flag = is_unix_filespec(name);
8477     }
8478
8479     Newx(dir, VMS_MAXRSS, char);
8480     if (do_tovmspath(name,dir,0,NULL) == NULL) {
8481       Safefree(dir);
8482       return NULL;
8483     }
8484     /* Check access before stat; otherwise stat does not
8485      * accurately report whether it's a directory.
8486      */
8487     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8488       /* cando_by_name has already set errno */
8489       Safefree(dir);
8490       return NULL;
8491     }
8492     if (flex_stat(dir,&sb) == -1) return NULL;
8493     if (!S_ISDIR(sb.st_mode)) {
8494       Safefree(dir);
8495       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
8496       return NULL;
8497     }
8498     /* Get memory for the handle, and the pattern. */
8499     Newx(dd,1,DIR);
8500     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8501
8502     /* Fill in the fields; mainly playing with the descriptor. */
8503     sprintf(dd->pattern, "%s*.*",dir);
8504     Safefree(dir);
8505     dd->context = 0;
8506     dd->count = 0;
8507     dd->flags = 0;
8508     if (unix_flag)
8509         dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8510     dd->pat.dsc$a_pointer = dd->pattern;
8511     dd->pat.dsc$w_length = strlen(dd->pattern);
8512     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8513     dd->pat.dsc$b_class = DSC$K_CLASS_S;
8514 #if defined(USE_ITHREADS)
8515     Newx(dd->mutex,1,perl_mutex);
8516     MUTEX_INIT( (perl_mutex *) dd->mutex );
8517 #else
8518     dd->mutex = NULL;
8519 #endif
8520
8521     return dd;
8522 }  /* end of opendir() */
8523 /*}}}*/
8524
8525 /*
8526  *  Set the flag to indicate we want versions or not.
8527  */
8528 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8529 void
8530 vmsreaddirversions(DIR *dd, int flag)
8531 {
8532     if (flag)
8533         dd->flags |= PERL_VMSDIR_M_VERSIONS;
8534     else
8535         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8536 }
8537 /*}}}*/
8538
8539 /*
8540  *  Free up an opened directory.
8541  */
8542 /*{{{ void closedir(DIR *dd)*/
8543 void
8544 Perl_closedir(DIR *dd)
8545 {
8546     int sts;
8547
8548     sts = lib$find_file_end(&dd->context);
8549     Safefree(dd->pattern);
8550 #if defined(USE_ITHREADS)
8551     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8552     Safefree(dd->mutex);
8553 #endif
8554     Safefree(dd);
8555 }
8556 /*}}}*/
8557
8558 /*
8559  *  Collect all the version numbers for the current file.
8560  */
8561 static void
8562 collectversions(pTHX_ DIR *dd)
8563 {
8564     struct dsc$descriptor_s     pat;
8565     struct dsc$descriptor_s     res;
8566     struct dirent *e;
8567     char *p, *text, *buff;
8568     int i;
8569     unsigned long context, tmpsts;
8570
8571     /* Convenient shorthand. */
8572     e = &dd->entry;
8573
8574     /* Add the version wildcard, ignoring the "*.*" put on before */
8575     i = strlen(dd->pattern);
8576     Newx(text,i + e->d_namlen + 3,char);
8577     strcpy(text, dd->pattern);
8578     sprintf(&text[i - 3], "%s;*", e->d_name);
8579
8580     /* Set up the pattern descriptor. */
8581     pat.dsc$a_pointer = text;
8582     pat.dsc$w_length = i + e->d_namlen - 1;
8583     pat.dsc$b_dtype = DSC$K_DTYPE_T;
8584     pat.dsc$b_class = DSC$K_CLASS_S;
8585
8586     /* Set up result descriptor. */
8587     Newx(buff, VMS_MAXRSS, char);
8588     res.dsc$a_pointer = buff;
8589     res.dsc$w_length = VMS_MAXRSS - 1;
8590     res.dsc$b_dtype = DSC$K_DTYPE_T;
8591     res.dsc$b_class = DSC$K_CLASS_S;
8592
8593     /* Read files, collecting versions. */
8594     for (context = 0, e->vms_verscount = 0;
8595          e->vms_verscount < VERSIZE(e);
8596          e->vms_verscount++) {
8597         unsigned long rsts;
8598         unsigned long flags = 0;
8599
8600 #ifdef VMS_LONGNAME_SUPPORT
8601         flags = LIB$M_FIL_LONG_NAMES;
8602 #endif
8603         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8604         if (tmpsts == RMS$_NMF || context == 0) break;
8605         _ckvmssts(tmpsts);
8606         buff[VMS_MAXRSS - 1] = '\0';
8607         if ((p = strchr(buff, ';')))
8608             e->vms_versions[e->vms_verscount] = atoi(p + 1);
8609         else
8610             e->vms_versions[e->vms_verscount] = -1;
8611     }
8612
8613     _ckvmssts(lib$find_file_end(&context));
8614     Safefree(text);
8615     Safefree(buff);
8616
8617 }  /* end of collectversions() */
8618
8619 /*
8620  *  Read the next entry from the directory.
8621  */
8622 /*{{{ struct dirent *readdir(DIR *dd)*/
8623 struct dirent *
8624 Perl_readdir(pTHX_ DIR *dd)
8625 {
8626     struct dsc$descriptor_s     res;
8627     char *p, *buff;
8628     unsigned long int tmpsts;
8629     unsigned long rsts;
8630     unsigned long flags = 0;
8631     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8632     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8633
8634     /* Set up result descriptor, and get next file. */
8635     Newx(buff, VMS_MAXRSS, char);
8636     res.dsc$a_pointer = buff;
8637     res.dsc$w_length = VMS_MAXRSS - 1;
8638     res.dsc$b_dtype = DSC$K_DTYPE_T;
8639     res.dsc$b_class = DSC$K_CLASS_S;
8640
8641 #ifdef VMS_LONGNAME_SUPPORT
8642     flags = LIB$M_FIL_LONG_NAMES;
8643 #endif
8644
8645     tmpsts = lib$find_file
8646         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8647     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
8648     if (!(tmpsts & 1)) {
8649       set_vaxc_errno(tmpsts);
8650       switch (tmpsts) {
8651         case RMS$_PRV:
8652           set_errno(EACCES); break;
8653         case RMS$_DEV:
8654           set_errno(ENODEV); break;
8655         case RMS$_DIR:
8656           set_errno(ENOTDIR); break;
8657         case RMS$_FNF: case RMS$_DNF:
8658           set_errno(ENOENT); break;
8659         default:
8660           set_errno(EVMSERR);
8661       }
8662       Safefree(buff);
8663       return NULL;
8664     }
8665     dd->count++;
8666     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8667     if (!decc_efs_case_preserve) {
8668       buff[VMS_MAXRSS - 1] = '\0';
8669       for (p = buff; *p; p++) *p = _tolower(*p);
8670     }
8671     else {
8672       /* we don't want to force to lowercase, just null terminate */
8673       buff[res.dsc$w_length] = '\0';
8674     }
8675     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
8676     *p = '\0';
8677
8678     /* Skip any directory component and just copy the name. */
8679     sts = vms_split_path
8680        (buff,
8681         &v_spec,
8682         &v_len,
8683         &r_spec,
8684         &r_len,
8685         &d_spec,
8686         &d_len,
8687         &n_spec,
8688         &n_len,
8689         &e_spec,
8690         &e_len,
8691         &vs_spec,
8692         &vs_len);
8693
8694     /* Drop NULL extensions on UNIX file specification */
8695     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8696         (e_len == 1) && decc_readdir_dropdotnotype)) {
8697         e_len = 0;
8698         e_spec[0] = '\0';
8699     }
8700
8701     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8702     dd->entry.d_name[n_len + e_len] = '\0';
8703     dd->entry.d_namlen = strlen(dd->entry.d_name);
8704
8705     /* Convert the filename to UNIX format if needed */
8706     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8707
8708         /* Translate the encoded characters. */
8709         /* Fixme: unicode handling could result in embedded 0 characters */
8710         if (strchr(dd->entry.d_name, '^') != NULL) {
8711             char new_name[256];
8712             char * q;
8713             int cnt;
8714             p = dd->entry.d_name;
8715             q = new_name;
8716             while (*p != 0) {
8717                 int x, y;
8718                 x = copy_expand_vms_filename_escape(q, p, &y);
8719                 p += x;
8720                 q += y;
8721                 /* fix-me */
8722                 /* if y > 1, then this is a wide file specification */
8723                 /* Wide file specifications need to be passed in Perl */
8724                 /* counted strings apparently with a unicode flag */
8725             }
8726             *q = 0;
8727             strcpy(dd->entry.d_name, new_name);
8728         }
8729     }
8730
8731     dd->entry.vms_verscount = 0;
8732     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8733     Safefree(buff);
8734     return &dd->entry;
8735
8736 }  /* end of readdir() */
8737 /*}}}*/
8738
8739 /*
8740  *  Read the next entry from the directory -- thread-safe version.
8741  */
8742 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
8743 int
8744 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
8745 {
8746     int retval;
8747
8748     MUTEX_LOCK( (perl_mutex *) dd->mutex );
8749
8750     entry = readdir(dd);
8751     *result = entry;
8752     retval = ( *result == NULL ? errno : 0 );
8753
8754     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
8755
8756     return retval;
8757
8758 }  /* end of readdir_r() */
8759 /*}}}*/
8760
8761 /*
8762  *  Return something that can be used in a seekdir later.
8763  */
8764 /*{{{ long telldir(DIR *dd)*/
8765 long
8766 Perl_telldir(DIR *dd)
8767 {
8768     return dd->count;
8769 }
8770 /*}}}*/
8771
8772 /*
8773  *  Return to a spot where we used to be.  Brute force.
8774  */
8775 /*{{{ void seekdir(DIR *dd,long count)*/
8776 void
8777 Perl_seekdir(pTHX_ DIR *dd, long count)
8778 {
8779     int old_flags;
8780
8781     /* If we haven't done anything yet... */
8782     if (dd->count == 0)
8783         return;
8784
8785     /* Remember some state, and clear it. */
8786     old_flags = dd->flags;
8787     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8788     _ckvmssts(lib$find_file_end(&dd->context));
8789     dd->context = 0;
8790
8791     /* The increment is in readdir(). */
8792     for (dd->count = 0; dd->count < count; )
8793         readdir(dd);
8794
8795     dd->flags = old_flags;
8796
8797 }  /* end of seekdir() */
8798 /*}}}*/
8799
8800 /* VMS subprocess management
8801  *
8802  * my_vfork() - just a vfork(), after setting a flag to record that
8803  * the current script is trying a Unix-style fork/exec.
8804  *
8805  * vms_do_aexec() and vms_do_exec() are called in response to the
8806  * perl 'exec' function.  If this follows a vfork call, then they
8807  * call out the regular perl routines in doio.c which do an
8808  * execvp (for those who really want to try this under VMS).
8809  * Otherwise, they do exactly what the perl docs say exec should
8810  * do - terminate the current script and invoke a new command
8811  * (See below for notes on command syntax.)
8812  *
8813  * do_aspawn() and do_spawn() implement the VMS side of the perl
8814  * 'system' function.
8815  *
8816  * Note on command arguments to perl 'exec' and 'system': When handled
8817  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
8818  * are concatenated to form a DCL command string.  If the first arg
8819  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
8820  * the command string is handed off to DCL directly.  Otherwise,
8821  * the first token of the command is taken as the filespec of an image
8822  * to run.  The filespec is expanded using a default type of '.EXE' and
8823  * the process defaults for device, directory, etc., and if found, the resultant
8824  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
8825  * the command string as parameters.  This is perhaps a bit complicated,
8826  * but I hope it will form a happy medium between what VMS folks expect
8827  * from lib$spawn and what Unix folks expect from exec.
8828  */
8829
8830 static int vfork_called;
8831
8832 /*{{{int my_vfork()*/
8833 int
8834 my_vfork()
8835 {
8836   vfork_called++;
8837   return vfork();
8838 }
8839 /*}}}*/
8840
8841
8842 static void
8843 vms_execfree(struct dsc$descriptor_s *vmscmd)
8844 {
8845   if (vmscmd) {
8846       if (vmscmd->dsc$a_pointer) {
8847           PerlMem_free(vmscmd->dsc$a_pointer);
8848       }
8849       PerlMem_free(vmscmd);
8850   }
8851 }
8852
8853 static char *
8854 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
8855 {
8856   char *junk, *tmps = Nullch;
8857   register size_t cmdlen = 0;
8858   size_t rlen;
8859   register SV **idx;
8860   STRLEN n_a;
8861
8862   idx = mark;
8863   if (really) {
8864     tmps = SvPV(really,rlen);
8865     if (*tmps) {
8866       cmdlen += rlen + 1;
8867       idx++;
8868     }
8869   }
8870
8871   for (idx++; idx <= sp; idx++) {
8872     if (*idx) {
8873       junk = SvPVx(*idx,rlen);
8874       cmdlen += rlen ? rlen + 1 : 0;
8875     }
8876   }
8877   Newx(PL_Cmd, cmdlen+1, char);
8878
8879   if (tmps && *tmps) {
8880     strcpy(PL_Cmd,tmps);
8881     mark++;
8882   }
8883   else *PL_Cmd = '\0';
8884   while (++mark <= sp) {
8885     if (*mark) {
8886       char *s = SvPVx(*mark,n_a);
8887       if (!*s) continue;
8888       if (*PL_Cmd) strcat(PL_Cmd," ");
8889       strcat(PL_Cmd,s);
8890     }
8891   }
8892   return PL_Cmd;
8893
8894 }  /* end of setup_argstr() */
8895
8896
8897 static unsigned long int
8898 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
8899                    struct dsc$descriptor_s **pvmscmd)
8900 {
8901   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
8902   char image_name[NAM$C_MAXRSS+1];
8903   char image_argv[NAM$C_MAXRSS+1];
8904   $DESCRIPTOR(defdsc,".EXE");
8905   $DESCRIPTOR(defdsc2,".");
8906   $DESCRIPTOR(resdsc,resspec);
8907   struct dsc$descriptor_s *vmscmd;
8908   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8909   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
8910   register char *s, *rest, *cp, *wordbreak;
8911   char * cmd;
8912   int cmdlen;
8913   register int isdcl;
8914
8915   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8916   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
8917
8918   /* Make a copy for modification */
8919   cmdlen = strlen(incmd);
8920   cmd = PerlMem_malloc(cmdlen+1);
8921   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
8922   strncpy(cmd, incmd, cmdlen);
8923   cmd[cmdlen] = 0;
8924   image_name[0] = 0;
8925   image_argv[0] = 0;
8926
8927   vmscmd->dsc$a_pointer = NULL;
8928   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
8929   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
8930   vmscmd->dsc$w_length = 0;
8931   if (pvmscmd) *pvmscmd = vmscmd;
8932
8933   if (suggest_quote) *suggest_quote = 0;
8934
8935   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
8936     PerlMem_free(cmd);
8937     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
8938   }
8939
8940   s = cmd;
8941
8942   while (*s && isspace(*s)) s++;
8943
8944   if (*s == '@' || *s == '$') {
8945     vmsspec[0] = *s;  rest = s + 1;
8946     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
8947   }
8948   else { cp = vmsspec; rest = s; }
8949   if (*rest == '.' || *rest == '/') {
8950     char *cp2;
8951     for (cp2 = resspec;
8952          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
8953          rest++, cp2++) *cp2 = *rest;
8954     *cp2 = '\0';
8955     if (do_tovmsspec(resspec,cp,0,NULL)) {
8956       s = vmsspec;
8957       if (*rest) {
8958         for (cp2 = vmsspec + strlen(vmsspec);
8959              *rest && cp2 - vmsspec < sizeof vmsspec;
8960              rest++, cp2++) *cp2 = *rest;
8961         *cp2 = '\0';
8962       }
8963     }
8964   }
8965   /* Intuit whether verb (first word of cmd) is a DCL command:
8966    *   - if first nonspace char is '@', it's a DCL indirection
8967    * otherwise
8968    *   - if verb contains a filespec separator, it's not a DCL command
8969    *   - if it doesn't, caller tells us whether to default to a DCL
8970    *     command, or to a local image unless told it's DCL (by leading '$')
8971    */
8972   if (*s == '@') {
8973       isdcl = 1;
8974       if (suggest_quote) *suggest_quote = 1;
8975   } else {
8976     register char *filespec = strpbrk(s,":<[.;");
8977     rest = wordbreak = strpbrk(s," \"\t/");
8978     if (!wordbreak) wordbreak = s + strlen(s);
8979     if (*s == '$') check_img = 0;
8980     if (filespec && (filespec < wordbreak)) isdcl = 0;
8981     else isdcl = !check_img;
8982   }
8983
8984   if (!isdcl) {
8985     int rsts;
8986     imgdsc.dsc$a_pointer = s;
8987     imgdsc.dsc$w_length = wordbreak - s;
8988     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8989     if (!(retsts&1)) {
8990         _ckvmssts(lib$find_file_end(&cxt));
8991         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8992       if (!(retsts & 1) && *s == '$') {
8993         _ckvmssts(lib$find_file_end(&cxt));
8994         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
8995         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8996         if (!(retsts&1)) {
8997           _ckvmssts(lib$find_file_end(&cxt));
8998           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8999         }
9000       }
9001     }
9002     _ckvmssts(lib$find_file_end(&cxt));
9003
9004     if (retsts & 1) {
9005       FILE *fp;
9006       s = resspec;
9007       while (*s && !isspace(*s)) s++;
9008       *s = '\0';
9009
9010       /* check that it's really not DCL with no file extension */
9011       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9012       if (fp) {
9013         char b[256] = {0,0,0,0};
9014         read(fileno(fp), b, 256);
9015         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9016         if (isdcl) {
9017           int shebang_len;
9018
9019           /* Check for script */
9020           shebang_len = 0;
9021           if ((b[0] == '#') && (b[1] == '!'))
9022              shebang_len = 2;
9023 #ifdef ALTERNATE_SHEBANG
9024           else {
9025             shebang_len = strlen(ALTERNATE_SHEBANG);
9026             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9027               char * perlstr;
9028                 perlstr = strstr("perl",b);
9029                 if (perlstr == NULL)
9030                   shebang_len = 0;
9031             }
9032             else
9033               shebang_len = 0;
9034           }
9035 #endif
9036
9037           if (shebang_len > 0) {
9038           int i;
9039           int j;
9040           char tmpspec[NAM$C_MAXRSS + 1];
9041
9042             i = shebang_len;
9043              /* Image is following after white space */
9044             /*--------------------------------------*/
9045             while (isprint(b[i]) && isspace(b[i]))
9046                 i++;
9047
9048             j = 0;
9049             while (isprint(b[i]) && !isspace(b[i])) {
9050                 tmpspec[j++] = b[i++];
9051                 if (j >= NAM$C_MAXRSS)
9052                    break;
9053             }
9054             tmpspec[j] = '\0';
9055
9056              /* There may be some default parameters to the image */
9057             /*---------------------------------------------------*/
9058             j = 0;
9059             while (isprint(b[i])) {
9060                 image_argv[j++] = b[i++];
9061                 if (j >= NAM$C_MAXRSS)
9062                    break;
9063             }
9064             while ((j > 0) && !isprint(image_argv[j-1]))
9065                 j--;
9066             image_argv[j] = 0;
9067
9068             /* It will need to be converted to VMS format and validated */
9069             if (tmpspec[0] != '\0') {
9070               char * iname;
9071
9072                /* Try to find the exact program requested to be run */
9073               /*---------------------------------------------------*/
9074               iname = do_rmsexpand
9075                  (tmpspec, image_name, 0, ".exe",
9076                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
9077               if (iname != NULL) {
9078                 if (cando_by_name_int
9079                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9080                   /* MCR prefix needed */
9081                   isdcl = 0;
9082                 }
9083                 else {
9084                    /* Try again with a null type */
9085                   /*----------------------------*/
9086                   iname = do_rmsexpand
9087                     (tmpspec, image_name, 0, ".",
9088                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
9089                   if (iname != NULL) {
9090                     if (cando_by_name_int
9091                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9092                       /* MCR prefix needed */
9093                       isdcl = 0;
9094                     }
9095                   }
9096                 }
9097
9098                  /* Did we find the image to run the script? */
9099                 /*------------------------------------------*/
9100                 if (isdcl) {
9101                   char *tchr;
9102
9103                    /* Assume DCL or foreign command exists */
9104                   /*--------------------------------------*/
9105                   tchr = strrchr(tmpspec, '/');
9106                   if (tchr != NULL) {
9107                     tchr++;
9108                   }
9109                   else {
9110                     tchr = tmpspec;
9111                   }
9112                   strcpy(image_name, tchr);
9113                 }
9114               }
9115             }
9116           }
9117         }
9118         fclose(fp);
9119       }
9120       if (check_img && isdcl) return RMS$_FNF;
9121
9122       if (cando_by_name(S_IXUSR,0,resspec)) {
9123         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9124         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9125         if (!isdcl) {
9126             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9127             if (image_name[0] != 0) {
9128                 strcat(vmscmd->dsc$a_pointer, image_name);
9129                 strcat(vmscmd->dsc$a_pointer, " ");
9130             }
9131         } else if (image_name[0] != 0) {
9132             strcpy(vmscmd->dsc$a_pointer, image_name);
9133             strcat(vmscmd->dsc$a_pointer, " ");
9134         } else {
9135             strcpy(vmscmd->dsc$a_pointer,"@");
9136         }
9137         if (suggest_quote) *suggest_quote = 1;
9138
9139         /* If there is an image name, use original command */
9140         if (image_name[0] == 0)
9141             strcat(vmscmd->dsc$a_pointer,resspec);
9142         else {
9143             rest = cmd;
9144             while (*rest && isspace(*rest)) rest++;
9145         }
9146
9147         if (image_argv[0] != 0) {
9148           strcat(vmscmd->dsc$a_pointer,image_argv);
9149           strcat(vmscmd->dsc$a_pointer, " ");
9150         }
9151         if (rest) {
9152            int rest_len;
9153            int vmscmd_len;
9154
9155            rest_len = strlen(rest);
9156            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9157            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9158               strcat(vmscmd->dsc$a_pointer,rest);
9159            else
9160              retsts = CLI$_BUFOVF;
9161         }
9162         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9163         PerlMem_free(cmd);
9164         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9165       }
9166       else
9167         retsts = RMS$_PRV;
9168     }
9169   }
9170   /* It's either a DCL command or we couldn't find a suitable image */
9171   vmscmd->dsc$w_length = strlen(cmd);
9172
9173   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9174   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9175   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9176
9177   PerlMem_free(cmd);
9178
9179   /* check if it's a symbol (for quoting purposes) */
9180   if (suggest_quote && !*suggest_quote) {
9181     int iss;
9182     char equiv[LNM$C_NAMLENGTH];
9183     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9184     eqvdsc.dsc$a_pointer = equiv;
9185
9186     iss = lib$get_symbol(vmscmd,&eqvdsc);
9187     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9188   }
9189   if (!(retsts & 1)) {
9190     /* just hand off status values likely to be due to user error */
9191     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9192         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9193        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9194     else { _ckvmssts(retsts); }
9195   }
9196
9197   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9198
9199 }  /* end of setup_cmddsc() */
9200
9201
9202 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9203 bool
9204 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9205 {
9206 bool exec_sts;
9207 char * cmd;
9208
9209   if (sp > mark) {
9210     if (vfork_called) {           /* this follows a vfork - act Unixish */
9211       vfork_called--;
9212       if (vfork_called < 0) {
9213         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9214         vfork_called = 0;
9215       }
9216       else return do_aexec(really,mark,sp);
9217     }
9218                                            /* no vfork - act VMSish */
9219     cmd = setup_argstr(aTHX_ really,mark,sp);
9220     exec_sts = vms_do_exec(cmd);
9221     Safefree(cmd);  /* Clean up from setup_argstr() */
9222     return exec_sts;
9223   }
9224
9225   return FALSE;
9226 }  /* end of vms_do_aexec() */
9227 /*}}}*/
9228
9229 /* {{{bool vms_do_exec(char *cmd) */
9230 bool
9231 Perl_vms_do_exec(pTHX_ const char *cmd)
9232 {
9233   struct dsc$descriptor_s *vmscmd;
9234
9235   if (vfork_called) {             /* this follows a vfork - act Unixish */
9236     vfork_called--;
9237     if (vfork_called < 0) {
9238       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9239       vfork_called = 0;
9240     }
9241     else return do_exec(cmd);
9242   }
9243
9244   {                               /* no vfork - act VMSish */
9245     unsigned long int retsts;
9246
9247     TAINT_ENV();
9248     TAINT_PROPER("exec");
9249     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9250       retsts = lib$do_command(vmscmd);
9251
9252     switch (retsts) {
9253       case RMS$_FNF: case RMS$_DNF:
9254         set_errno(ENOENT); break;
9255       case RMS$_DIR:
9256         set_errno(ENOTDIR); break;
9257       case RMS$_DEV:
9258         set_errno(ENODEV); break;
9259       case RMS$_PRV:
9260         set_errno(EACCES); break;
9261       case RMS$_SYN:
9262         set_errno(EINVAL); break;
9263       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9264         set_errno(E2BIG); break;
9265       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9266         _ckvmssts(retsts); /* fall through */
9267       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9268         set_errno(EVMSERR);
9269     }
9270     set_vaxc_errno(retsts);
9271     if (ckWARN(WARN_EXEC)) {
9272       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9273              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9274     }
9275     vms_execfree(vmscmd);
9276   }
9277
9278   return FALSE;
9279
9280 }  /* end of vms_do_exec() */
9281 /*}}}*/
9282
9283 unsigned long int Perl_do_spawn(pTHX_ const char *);
9284
9285 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9286 unsigned long int
9287 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9288 {
9289 unsigned long int sts;
9290 char * cmd;
9291
9292   if (sp > mark) {
9293     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9294     sts = do_spawn(cmd);
9295     /* pp_sys will clean up cmd */
9296     return sts;
9297   }
9298   return SS$_ABORT;
9299 }  /* end of do_aspawn() */
9300 /*}}}*/
9301
9302 /* {{{unsigned long int do_spawn(char *cmd) */
9303 unsigned long int
9304 Perl_do_spawn(pTHX_ const char *cmd)
9305 {
9306   unsigned long int sts, substs;
9307
9308   /* The caller of this routine expects to Safefree(PL_Cmd) */
9309   Newx(PL_Cmd,10,char);
9310
9311   TAINT_ENV();
9312   TAINT_PROPER("spawn");
9313   if (!cmd || !*cmd) {
9314     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9315     if (!(sts & 1)) {
9316       switch (sts) {
9317         case RMS$_FNF:  case RMS$_DNF:
9318           set_errno(ENOENT); break;
9319         case RMS$_DIR:
9320           set_errno(ENOTDIR); break;
9321         case RMS$_DEV:
9322           set_errno(ENODEV); break;
9323         case RMS$_PRV:
9324           set_errno(EACCES); break;
9325         case RMS$_SYN:
9326           set_errno(EINVAL); break;
9327         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9328           set_errno(E2BIG); break;
9329         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9330           _ckvmssts(sts); /* fall through */
9331         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9332           set_errno(EVMSERR);
9333       }
9334       set_vaxc_errno(sts);
9335       if (ckWARN(WARN_EXEC)) {
9336         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9337                     Strerror(errno));
9338       }
9339     }
9340     sts = substs;
9341   }
9342   else {
9343     PerlIO * fp;
9344     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9345     if (fp != NULL)
9346       my_pclose(fp);
9347   }
9348   return sts;
9349 }  /* end of do_spawn() */
9350 /*}}}*/
9351
9352
9353 static unsigned int *sockflags, sockflagsize;
9354
9355 /*
9356  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9357  * routines found in some versions of the CRTL can't deal with sockets.
9358  * We don't shim the other file open routines since a socket isn't
9359  * likely to be opened by a name.
9360  */
9361 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9362 FILE *my_fdopen(int fd, const char *mode)
9363 {
9364   FILE *fp = fdopen(fd, mode);
9365
9366   if (fp) {
9367     unsigned int fdoff = fd / sizeof(unsigned int);
9368     Stat_t sbuf; /* native stat; we don't need flex_stat */
9369     if (!sockflagsize || fdoff > sockflagsize) {
9370       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
9371       else           Newx  (sockflags,fdoff+2,unsigned int);
9372       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9373       sockflagsize = fdoff + 2;
9374     }
9375     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9376       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9377   }
9378   return fp;
9379
9380 }
9381 /*}}}*/
9382
9383
9384 /*
9385  * Clear the corresponding bit when the (possibly) socket stream is closed.
9386  * There still a small hole: we miss an implicit close which might occur
9387  * via freopen().  >> Todo
9388  */
9389 /*{{{ int my_fclose(FILE *fp)*/
9390 int my_fclose(FILE *fp) {
9391   if (fp) {
9392     unsigned int fd = fileno(fp);
9393     unsigned int fdoff = fd / sizeof(unsigned int);
9394
9395     if (sockflagsize && fdoff <= sockflagsize)
9396       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9397   }
9398   return fclose(fp);
9399 }
9400 /*}}}*/
9401
9402
9403 /*
9404  * A simple fwrite replacement which outputs itmsz*nitm chars without
9405  * introducing record boundaries every itmsz chars.
9406  * We are using fputs, which depends on a terminating null.  We may
9407  * well be writing binary data, so we need to accommodate not only
9408  * data with nulls sprinkled in the middle but also data with no null
9409  * byte at the end.
9410  */
9411 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9412 int
9413 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9414 {
9415   register char *cp, *end, *cpd, *data;
9416   register unsigned int fd = fileno(dest);
9417   register unsigned int fdoff = fd / sizeof(unsigned int);
9418   int retval;
9419   int bufsize = itmsz * nitm + 1;
9420
9421   if (fdoff < sockflagsize &&
9422       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9423     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9424     return nitm;
9425   }
9426
9427   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9428   memcpy( data, src, itmsz*nitm );
9429   data[itmsz*nitm] = '\0';
9430
9431   end = data + itmsz * nitm;
9432   retval = (int) nitm; /* on success return # items written */
9433
9434   cpd = data;
9435   while (cpd <= end) {
9436     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9437     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9438     if (cp < end)
9439       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9440     cpd = cp + 1;
9441   }
9442
9443   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9444   return retval;
9445
9446 }  /* end of my_fwrite() */
9447 /*}}}*/
9448
9449 /*{{{ int my_flush(FILE *fp)*/
9450 int
9451 Perl_my_flush(pTHX_ FILE *fp)
9452 {
9453     int res;
9454     if ((res = fflush(fp)) == 0 && fp) {
9455 #ifdef VMS_DO_SOCKETS
9456         Stat_t s;
9457         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9458 #endif
9459             res = fsync(fileno(fp));
9460     }
9461 /*
9462  * If the flush succeeded but set end-of-file, we need to clear
9463  * the error because our caller may check ferror().  BTW, this
9464  * probably means we just flushed an empty file.
9465  */
9466     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9467
9468     return res;
9469 }
9470 /*}}}*/
9471
9472 /*
9473  * Here are replacements for the following Unix routines in the VMS environment:
9474  *      getpwuid    Get information for a particular UIC or UID
9475  *      getpwnam    Get information for a named user
9476  *      getpwent    Get information for each user in the rights database
9477  *      setpwent    Reset search to the start of the rights database
9478  *      endpwent    Finish searching for users in the rights database
9479  *
9480  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9481  * (defined in pwd.h), which contains the following fields:-
9482  *      struct passwd {
9483  *              char        *pw_name;    Username (in lower case)
9484  *              char        *pw_passwd;  Hashed password
9485  *              unsigned int pw_uid;     UIC
9486  *              unsigned int pw_gid;     UIC group  number
9487  *              char        *pw_unixdir; Default device/directory (VMS-style)
9488  *              char        *pw_gecos;   Owner name
9489  *              char        *pw_dir;     Default device/directory (Unix-style)
9490  *              char        *pw_shell;   Default CLI name (eg. DCL)
9491  *      };
9492  * If the specified user does not exist, getpwuid and getpwnam return NULL.
9493  *
9494  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9495  * not the UIC member number (eg. what's returned by getuid()),
9496  * getpwuid() can accept either as input (if uid is specified, the caller's
9497  * UIC group is used), though it won't recognise gid=0.
9498  *
9499  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9500  * information about other users in your group or in other groups, respectively.
9501  * If the required privilege is not available, then these routines fill only
9502  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9503  * string).
9504  *
9505  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9506  */
9507
9508 /* sizes of various UAF record fields */
9509 #define UAI$S_USERNAME 12
9510 #define UAI$S_IDENT    31
9511 #define UAI$S_OWNER    31
9512 #define UAI$S_DEFDEV   31
9513 #define UAI$S_DEFDIR   63
9514 #define UAI$S_DEFCLI   31
9515 #define UAI$S_PWD       8
9516
9517 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
9518                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9519                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
9520
9521 static char __empty[]= "";
9522 static struct passwd __passwd_empty=
9523     {(char *) __empty, (char *) __empty, 0, 0,
9524      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9525 static int contxt= 0;
9526 static struct passwd __pwdcache;
9527 static char __pw_namecache[UAI$S_IDENT+1];
9528
9529 /*
9530  * This routine does most of the work extracting the user information.
9531  */
9532 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9533 {
9534     static struct {
9535         unsigned char length;
9536         char pw_gecos[UAI$S_OWNER+1];
9537     } owner;
9538     static union uicdef uic;
9539     static struct {
9540         unsigned char length;
9541         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9542     } defdev;
9543     static struct {
9544         unsigned char length;
9545         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9546     } defdir;
9547     static struct {
9548         unsigned char length;
9549         char pw_shell[UAI$S_DEFCLI+1];
9550     } defcli;
9551     static char pw_passwd[UAI$S_PWD+1];
9552
9553     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9554     struct dsc$descriptor_s name_desc;
9555     unsigned long int sts;
9556
9557     static struct itmlst_3 itmlst[]= {
9558         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
9559         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
9560         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
9561         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
9562         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
9563         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
9564         {0,                0,           NULL,    NULL}};
9565
9566     name_desc.dsc$w_length=  strlen(name);
9567     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9568     name_desc.dsc$b_class=   DSC$K_CLASS_S;
9569     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9570
9571 /*  Note that sys$getuai returns many fields as counted strings. */
9572     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9573     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9574       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9575     }
9576     else { _ckvmssts(sts); }
9577     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
9578
9579     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
9580     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9581     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9582     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9583     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9584     owner.pw_gecos[lowner]=            '\0';
9585     defdev.pw_dir[ldefdev+ldefdir]= '\0';
9586     defcli.pw_shell[ldefcli]=          '\0';
9587     if (valid_uic(uic)) {
9588         pwd->pw_uid= uic.uic$l_uic;
9589         pwd->pw_gid= uic.uic$v_group;
9590     }
9591     else
9592       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9593     pwd->pw_passwd=  pw_passwd;
9594     pwd->pw_gecos=   owner.pw_gecos;
9595     pwd->pw_dir=     defdev.pw_dir;
9596     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9597     pwd->pw_shell=   defcli.pw_shell;
9598     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9599         int ldir;
9600         ldir= strlen(pwd->pw_unixdir) - 1;
9601         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9602     }
9603     else
9604         strcpy(pwd->pw_unixdir, pwd->pw_dir);
9605     if (!decc_efs_case_preserve)
9606         __mystrtolower(pwd->pw_unixdir);
9607     return 1;
9608 }
9609
9610 /*
9611  * Get information for a named user.
9612 */
9613 /*{{{struct passwd *getpwnam(char *name)*/
9614 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9615 {
9616     struct dsc$descriptor_s name_desc;
9617     union uicdef uic;
9618     unsigned long int status, sts;
9619
9620     __pwdcache = __passwd_empty;
9621     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9622       /* We still may be able to determine pw_uid and pw_gid */
9623       name_desc.dsc$w_length=  strlen(name);
9624       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9625       name_desc.dsc$b_class=   DSC$K_CLASS_S;
9626       name_desc.dsc$a_pointer= (char *) name;
9627       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9628         __pwdcache.pw_uid= uic.uic$l_uic;
9629         __pwdcache.pw_gid= uic.uic$v_group;
9630       }
9631       else {
9632         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9633           set_vaxc_errno(sts);
9634           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9635           return NULL;
9636         }
9637         else { _ckvmssts(sts); }
9638       }
9639     }
9640     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9641     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9642     __pwdcache.pw_name= __pw_namecache;
9643     return &__pwdcache;
9644 }  /* end of my_getpwnam() */
9645 /*}}}*/
9646
9647 /*
9648  * Get information for a particular UIC or UID.
9649  * Called by my_getpwent with uid=-1 to list all users.
9650 */
9651 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9652 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9653 {
9654     const $DESCRIPTOR(name_desc,__pw_namecache);
9655     unsigned short lname;
9656     union uicdef uic;
9657     unsigned long int status;
9658
9659     if (uid == (unsigned int) -1) {
9660       do {
9661         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9662         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9663           set_vaxc_errno(status);
9664           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9665           my_endpwent();
9666           return NULL;
9667         }
9668         else { _ckvmssts(status); }
9669       } while (!valid_uic (uic));
9670     }
9671     else {
9672       uic.uic$l_uic= uid;
9673       if (!uic.uic$v_group)
9674         uic.uic$v_group= PerlProc_getgid();
9675       if (valid_uic(uic))
9676         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9677       else status = SS$_IVIDENT;
9678       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9679           status == RMS$_PRV) {
9680         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9681         return NULL;
9682       }
9683       else { _ckvmssts(status); }
9684     }
9685     __pw_namecache[lname]= '\0';
9686     __mystrtolower(__pw_namecache);
9687
9688     __pwdcache = __passwd_empty;
9689     __pwdcache.pw_name = __pw_namecache;
9690
9691 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9692     The identifier's value is usually the UIC, but it doesn't have to be,
9693     so if we can, we let fillpasswd update this. */
9694     __pwdcache.pw_uid =  uic.uic$l_uic;
9695     __pwdcache.pw_gid =  uic.uic$v_group;
9696
9697     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9698     return &__pwdcache;
9699
9700 }  /* end of my_getpwuid() */
9701 /*}}}*/
9702
9703 /*
9704  * Get information for next user.
9705 */
9706 /*{{{struct passwd *my_getpwent()*/
9707 struct passwd *Perl_my_getpwent(pTHX)
9708 {
9709     return (my_getpwuid((unsigned int) -1));
9710 }
9711 /*}}}*/
9712
9713 /*
9714  * Finish searching rights database for users.
9715 */
9716 /*{{{void my_endpwent()*/
9717 void Perl_my_endpwent(pTHX)
9718 {
9719     if (contxt) {
9720       _ckvmssts(sys$finish_rdb(&contxt));
9721       contxt= 0;
9722     }
9723 }
9724 /*}}}*/
9725
9726 #ifdef HOMEGROWN_POSIX_SIGNALS
9727   /* Signal handling routines, pulled into the core from POSIX.xs.
9728    *
9729    * We need these for threads, so they've been rolled into the core,
9730    * rather than left in POSIX.xs.
9731    *
9732    * (DRS, Oct 23, 1997)
9733    */
9734
9735   /* sigset_t is atomic under VMS, so these routines are easy */
9736 /*{{{int my_sigemptyset(sigset_t *) */
9737 int my_sigemptyset(sigset_t *set) {
9738     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9739     *set = 0; return 0;
9740 }
9741 /*}}}*/
9742
9743
9744 /*{{{int my_sigfillset(sigset_t *)*/
9745 int my_sigfillset(sigset_t *set) {
9746     int i;
9747     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9748     for (i = 0; i < NSIG; i++) *set |= (1 << i);
9749     return 0;
9750 }
9751 /*}}}*/
9752
9753
9754 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
9755 int my_sigaddset(sigset_t *set, int sig) {
9756     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9757     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9758     *set |= (1 << (sig - 1));
9759     return 0;
9760 }
9761 /*}}}*/
9762
9763
9764 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
9765 int my_sigdelset(sigset_t *set, int sig) {
9766     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9767     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9768     *set &= ~(1 << (sig - 1));
9769     return 0;
9770 }
9771 /*}}}*/
9772
9773
9774 /*{{{int my_sigismember(sigset_t *set, int sig)*/
9775 int my_sigismember(sigset_t *set, int sig) {
9776     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9777     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9778     return *set & (1 << (sig - 1));
9779 }
9780 /*}}}*/
9781
9782
9783 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
9784 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
9785     sigset_t tempmask;
9786
9787     /* If set and oset are both null, then things are badly wrong. Bail out. */
9788     if ((oset == NULL) && (set == NULL)) {
9789       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
9790       return -1;
9791     }
9792
9793     /* If set's null, then we're just handling a fetch. */
9794     if (set == NULL) {
9795         tempmask = sigblock(0);
9796     }
9797     else {
9798       switch (how) {
9799       case SIG_SETMASK:
9800         tempmask = sigsetmask(*set);
9801         break;
9802       case SIG_BLOCK:
9803         tempmask = sigblock(*set);
9804         break;
9805       case SIG_UNBLOCK:
9806         tempmask = sigblock(0);
9807         sigsetmask(*oset & ~tempmask);
9808         break;
9809       default:
9810         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9811         return -1;
9812       }
9813     }
9814
9815     /* Did they pass us an oset? If so, stick our holding mask into it */
9816     if (oset)
9817       *oset = tempmask;
9818
9819     return 0;
9820 }
9821 /*}}}*/
9822 #endif  /* HOMEGROWN_POSIX_SIGNALS */
9823
9824
9825 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
9826  * my_utime(), and flex_stat(), all of which operate on UTC unless
9827  * VMSISH_TIMES is true.
9828  */
9829 /* method used to handle UTC conversions:
9830  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
9831  */
9832 static int gmtime_emulation_type;
9833 /* number of secs to add to UTC POSIX-style time to get local time */
9834 static long int utc_offset_secs;
9835
9836 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
9837  * in vmsish.h.  #undef them here so we can call the CRTL routines
9838  * directly.
9839  */
9840 #undef gmtime
9841 #undef localtime
9842 #undef time
9843
9844
9845 /*
9846  * DEC C previous to 6.0 corrupts the behavior of the /prefix
9847  * qualifier with the extern prefix pragma.  This provisional
9848  * hack circumvents this prefix pragma problem in previous
9849  * precompilers.
9850  */
9851 #if defined(__VMS_VER) && __VMS_VER >= 70000000
9852 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
9853 #    pragma __extern_prefix save
9854 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
9855 #    define gmtime decc$__utctz_gmtime
9856 #    define localtime decc$__utctz_localtime
9857 #    define time decc$__utc_time
9858 #    pragma __extern_prefix restore
9859
9860      struct tm *gmtime(), *localtime();
9861
9862 #  endif
9863 #endif
9864
9865
9866 static time_t toutc_dst(time_t loc) {
9867   struct tm *rsltmp;
9868
9869   if ((rsltmp = localtime(&loc)) == NULL) return -1;
9870   loc -= utc_offset_secs;
9871   if (rsltmp->tm_isdst) loc -= 3600;
9872   return loc;
9873 }
9874 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9875        ((gmtime_emulation_type || my_time(NULL)), \
9876        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
9877        ((secs) - utc_offset_secs))))
9878
9879 static time_t toloc_dst(time_t utc) {
9880   struct tm *rsltmp;
9881
9882   utc += utc_offset_secs;
9883   if ((rsltmp = localtime(&utc)) == NULL) return -1;
9884   if (rsltmp->tm_isdst) utc += 3600;
9885   return utc;
9886 }
9887 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
9888        ((gmtime_emulation_type || my_time(NULL)), \
9889        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
9890        ((secs) + utc_offset_secs))))
9891
9892 #ifndef RTL_USES_UTC
9893 /*
9894
9895     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
9896         DST starts on 1st sun of april      at 02:00  std time
9897             ends on last sun of october     at 02:00  dst time
9898     see the UCX management command reference, SET CONFIG TIMEZONE
9899     for formatting info.
9900
9901     No, it's not as general as it should be, but then again, NOTHING
9902     will handle UK times in a sensible way.
9903 */
9904
9905
9906 /*
9907     parse the DST start/end info:
9908     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
9909 */
9910
9911 static char *
9912 tz_parse_startend(char *s, struct tm *w, int *past)
9913 {
9914     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
9915     int ly, dozjd, d, m, n, hour, min, sec, j, k;
9916     time_t g;
9917
9918     if (!s)    return 0;
9919     if (!w) return 0;
9920     if (!past) return 0;
9921
9922     ly = 0;
9923     if (w->tm_year % 4        == 0) ly = 1;
9924     if (w->tm_year % 100      == 0) ly = 0;
9925     if (w->tm_year+1900 % 400 == 0) ly = 1;
9926     if (ly) dinm[1]++;
9927
9928     dozjd = isdigit(*s);
9929     if (*s == 'J' || *s == 'j' || dozjd) {
9930         if (!dozjd && !isdigit(*++s)) return 0;
9931         d = *s++ - '0';
9932         if (isdigit(*s)) {
9933             d = d*10 + *s++ - '0';
9934             if (isdigit(*s)) {
9935                 d = d*10 + *s++ - '0';
9936             }
9937         }
9938         if (d == 0) return 0;
9939         if (d > 366) return 0;
9940         d--;
9941         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
9942         g = d * 86400;
9943         dozjd = 1;
9944     } else if (*s == 'M' || *s == 'm') {
9945         if (!isdigit(*++s)) return 0;
9946         m = *s++ - '0';
9947         if (isdigit(*s)) m = 10*m + *s++ - '0';
9948         if (*s != '.') return 0;
9949         if (!isdigit(*++s)) return 0;
9950         n = *s++ - '0';
9951         if (n < 1 || n > 5) return 0;
9952         if (*s != '.') return 0;
9953         if (!isdigit(*++s)) return 0;
9954         d = *s++ - '0';
9955         if (d > 6) return 0;
9956     }
9957
9958     if (*s == '/') {
9959         if (!isdigit(*++s)) return 0;
9960         hour = *s++ - '0';
9961         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
9962         if (*s == ':') {
9963             if (!isdigit(*++s)) return 0;
9964             min = *s++ - '0';
9965             if (isdigit(*s)) min = 10*min + *s++ - '0';
9966             if (*s == ':') {
9967                 if (!isdigit(*++s)) return 0;
9968                 sec = *s++ - '0';
9969                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
9970             }
9971         }
9972     } else {
9973         hour = 2;
9974         min = 0;
9975         sec = 0;
9976     }
9977
9978     if (dozjd) {
9979         if (w->tm_yday < d) goto before;
9980         if (w->tm_yday > d) goto after;
9981     } else {
9982         if (w->tm_mon+1 < m) goto before;
9983         if (w->tm_mon+1 > m) goto after;
9984
9985         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
9986         k = d - j; /* mday of first d */
9987         if (k <= 0) k += 7;
9988         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
9989         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
9990         if (w->tm_mday < k) goto before;
9991         if (w->tm_mday > k) goto after;
9992     }
9993
9994     if (w->tm_hour < hour) goto before;
9995     if (w->tm_hour > hour) goto after;
9996     if (w->tm_min  < min)  goto before;
9997     if (w->tm_min  > min)  goto after;
9998     if (w->tm_sec  < sec)  goto before;
9999     goto after;
10000
10001 before:
10002     *past = 0;
10003     return s;
10004 after:
10005     *past = 1;
10006     return s;
10007 }
10008
10009
10010
10011
10012 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
10013
10014 static char *
10015 tz_parse_offset(char *s, int *offset)
10016 {
10017     int hour = 0, min = 0, sec = 0;
10018     int neg = 0;
10019     if (!s) return 0;
10020     if (!offset) return 0;
10021
10022     if (*s == '-') {neg++; s++;}
10023     if (*s == '+') s++;
10024     if (!isdigit(*s)) return 0;
10025     hour = *s++ - '0';
10026     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10027     if (hour > 24) return 0;
10028     if (*s == ':') {
10029         if (!isdigit(*++s)) return 0;
10030         min = *s++ - '0';
10031         if (isdigit(*s)) min = min*10 + (*s++ - '0');
10032         if (min > 59) return 0;
10033         if (*s == ':') {
10034             if (!isdigit(*++s)) return 0;
10035             sec = *s++ - '0';
10036             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10037             if (sec > 59) return 0;
10038         }
10039     }
10040
10041     *offset = (hour*60+min)*60 + sec;
10042     if (neg) *offset = -*offset;
10043     return s;
10044 }
10045
10046 /*
10047     input time is w, whatever type of time the CRTL localtime() uses.
10048     sets dst, the zone, and the gmtoff (seconds)
10049
10050     caches the value of TZ and UCX$TZ env variables; note that
10051     my_setenv looks for these and sets a flag if they're changed
10052     for efficiency.
10053
10054     We have to watch out for the "australian" case (dst starts in
10055     october, ends in april)...flagged by "reverse" and checked by
10056     scanning through the months of the previous year.
10057
10058 */
10059
10060 static int
10061 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10062 {
10063     time_t when;
10064     struct tm *w2;
10065     char *s,*s2;
10066     char *dstzone, *tz, *s_start, *s_end;
10067     int std_off, dst_off, isdst;
10068     int y, dststart, dstend;
10069     static char envtz[1025];  /* longer than any logical, symbol, ... */
10070     static char ucxtz[1025];
10071     static char reversed = 0;
10072
10073     if (!w) return 0;
10074
10075     if (tz_updated) {
10076         tz_updated = 0;
10077         reversed = -1;  /* flag need to check  */
10078         envtz[0] = ucxtz[0] = '\0';
10079         tz = my_getenv("TZ",0);
10080         if (tz) strcpy(envtz, tz);
10081         tz = my_getenv("UCX$TZ",0);
10082         if (tz) strcpy(ucxtz, tz);
10083         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
10084     }
10085     tz = envtz;
10086     if (!*tz) tz = ucxtz;
10087
10088     s = tz;
10089     while (isalpha(*s)) s++;
10090     s = tz_parse_offset(s, &std_off);
10091     if (!s) return 0;
10092     if (!*s) {                  /* no DST, hurray we're done! */
10093         isdst = 0;
10094         goto done;
10095     }
10096
10097     dstzone = s;
10098     while (isalpha(*s)) s++;
10099     s2 = tz_parse_offset(s, &dst_off);
10100     if (s2) {
10101         s = s2;
10102     } else {
10103         dst_off = std_off - 3600;
10104     }
10105
10106     if (!*s) {      /* default dst start/end?? */
10107         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
10108             s = strchr(ucxtz,',');
10109         }
10110         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
10111     }
10112     if (*s != ',') return 0;
10113
10114     when = *w;
10115     when = _toutc(when);      /* convert to utc */
10116     when = when - std_off;    /* convert to pseudolocal time*/
10117
10118     w2 = localtime(&when);
10119     y = w2->tm_year;
10120     s_start = s+1;
10121     s = tz_parse_startend(s_start,w2,&dststart);
10122     if (!s) return 0;
10123     if (*s != ',') return 0;
10124
10125     when = *w;
10126     when = _toutc(when);      /* convert to utc */
10127     when = when - dst_off;    /* convert to pseudolocal time*/
10128     w2 = localtime(&when);
10129     if (w2->tm_year != y) {   /* spans a year, just check one time */
10130         when += dst_off - std_off;
10131         w2 = localtime(&when);
10132     }
10133     s_end = s+1;
10134     s = tz_parse_startend(s_end,w2,&dstend);
10135     if (!s) return 0;
10136
10137     if (reversed == -1) {  /* need to check if start later than end */
10138         int j, ds, de;
10139
10140         when = *w;
10141         if (when < 2*365*86400) {
10142             when += 2*365*86400;
10143         } else {
10144             when -= 365*86400;
10145         }
10146         w2 =localtime(&when);
10147         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
10148
10149         for (j = 0; j < 12; j++) {
10150             w2 =localtime(&when);
10151             tz_parse_startend(s_start,w2,&ds);
10152             tz_parse_startend(s_end,w2,&de);
10153             if (ds != de) break;
10154             when += 30*86400;
10155         }
10156         reversed = 0;
10157         if (de && !ds) reversed = 1;
10158     }
10159
10160     isdst = dststart && !dstend;
10161     if (reversed) isdst = dststart  || !dstend;
10162
10163 done:
10164     if (dst)    *dst = isdst;
10165     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10166     if (isdst)  tz = dstzone;
10167     if (zone) {
10168         while(isalpha(*tz))  *zone++ = *tz++;
10169         *zone = '\0';
10170     }
10171     return 1;
10172 }
10173
10174 #endif /* !RTL_USES_UTC */
10175
10176 /* my_time(), my_localtime(), my_gmtime()
10177  * By default traffic in UTC time values, using CRTL gmtime() or
10178  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10179  * Note: We need to use these functions even when the CRTL has working
10180  * UTC support, since they also handle C<use vmsish qw(times);>
10181  *
10182  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
10183  * Modified by Charles Bailey <bailey@newman.upenn.edu>
10184  */
10185
10186 /*{{{time_t my_time(time_t *timep)*/
10187 time_t Perl_my_time(pTHX_ time_t *timep)
10188 {
10189   time_t when;
10190   struct tm *tm_p;
10191
10192   if (gmtime_emulation_type == 0) {
10193     int dstnow;
10194     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
10195                               /* results of calls to gmtime() and localtime() */
10196                               /* for same &base */
10197
10198     gmtime_emulation_type++;
10199     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10200       char off[LNM$C_NAMLENGTH+1];;
10201
10202       gmtime_emulation_type++;
10203       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10204         gmtime_emulation_type++;
10205         utc_offset_secs = 0;
10206         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10207       }
10208       else { utc_offset_secs = atol(off); }
10209     }
10210     else { /* We've got a working gmtime() */
10211       struct tm gmt, local;
10212
10213       gmt = *tm_p;
10214       tm_p = localtime(&base);
10215       local = *tm_p;
10216       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
10217       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10218       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
10219       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
10220     }
10221   }
10222
10223   when = time(NULL);
10224 # ifdef VMSISH_TIME
10225 # ifdef RTL_USES_UTC
10226   if (VMSISH_TIME) when = _toloc(when);
10227 # else
10228   if (!VMSISH_TIME) when = _toutc(when);
10229 # endif
10230 # endif
10231   if (timep != NULL) *timep = when;
10232   return when;
10233
10234 }  /* end of my_time() */
10235 /*}}}*/
10236
10237
10238 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10239 struct tm *
10240 Perl_my_gmtime(pTHX_ const time_t *timep)
10241 {
10242   char *p;
10243   time_t when;
10244   struct tm *rsltmp;
10245
10246   if (timep == NULL) {
10247     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10248     return NULL;
10249   }
10250   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10251
10252   when = *timep;
10253 # ifdef VMSISH_TIME
10254   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10255 #  endif
10256 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
10257   return gmtime(&when);
10258 # else
10259   /* CRTL localtime() wants local time as input, so does no tz correction */
10260   rsltmp = localtime(&when);
10261   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
10262   return rsltmp;
10263 #endif
10264 }  /* end of my_gmtime() */
10265 /*}}}*/
10266
10267
10268 /*{{{struct tm *my_localtime(const time_t *timep)*/
10269 struct tm *
10270 Perl_my_localtime(pTHX_ const time_t *timep)
10271 {
10272   time_t when, whenutc;
10273   struct tm *rsltmp;
10274   int dst, offset;
10275
10276   if (timep == NULL) {
10277     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10278     return NULL;
10279   }
10280   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10281   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10282
10283   when = *timep;
10284 # ifdef RTL_USES_UTC
10285 # ifdef VMSISH_TIME
10286   if (VMSISH_TIME) when = _toutc(when);
10287 # endif
10288   /* CRTL localtime() wants UTC as input, does tz correction itself */
10289   return localtime(&when);
10290
10291 # else /* !RTL_USES_UTC */
10292   whenutc = when;
10293 # ifdef VMSISH_TIME
10294   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
10295   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
10296 # endif
10297   dst = -1;
10298 #ifndef RTL_USES_UTC
10299   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
10300       when = whenutc - offset;                   /* pseudolocal time*/
10301   }
10302 # endif
10303   /* CRTL localtime() wants local time as input, so does no tz correction */
10304   rsltmp = localtime(&when);
10305   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10306   return rsltmp;
10307 # endif
10308
10309 } /*  end of my_localtime() */
10310 /*}}}*/
10311
10312 /* Reset definitions for later calls */
10313 #define gmtime(t)    my_gmtime(t)
10314 #define localtime(t) my_localtime(t)
10315 #define time(t)      my_time(t)
10316
10317
10318 /* my_utime - update modification/access time of a file
10319  *
10320  * VMS 7.3 and later implementation
10321  * Only the UTC translation is home-grown. The rest is handled by the
10322  * CRTL utime(), which will take into account the relevant feature
10323  * logicals and ODS-5 volume characteristics for true access times.
10324  *
10325  * pre VMS 7.3 implementation:
10326  * The calling sequence is identical to POSIX utime(), but under
10327  * VMS with ODS-2, only the modification time is changed; ODS-2 does
10328  * not maintain access times.  Restrictions differ from the POSIX
10329  * definition in that the time can be changed as long as the
10330  * caller has permission to execute the necessary IO$_MODIFY $QIO;
10331  * no separate checks are made to insure that the caller is the
10332  * owner of the file or has special privs enabled.
10333  * Code here is based on Joe Meadows' FILE utility.
10334  *
10335  */
10336
10337 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10338  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
10339  * in 100 ns intervals.
10340  */
10341 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10342
10343 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10344 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10345 {
10346 #if __CRTL_VER >= 70300000
10347   struct utimbuf utc_utimes, *utc_utimesp;
10348
10349   if (utimes != NULL) {
10350     utc_utimes.actime = utimes->actime;
10351     utc_utimes.modtime = utimes->modtime;
10352 # ifdef VMSISH_TIME
10353     /* If input was local; convert to UTC for sys svc */
10354     if (VMSISH_TIME) {
10355       utc_utimes.actime = _toutc(utimes->actime);
10356       utc_utimes.modtime = _toutc(utimes->modtime);
10357     }
10358 # endif
10359     utc_utimesp = &utc_utimes;
10360   }
10361   else {
10362     utc_utimesp = NULL;
10363   }
10364
10365   return utime(file, utc_utimesp);
10366
10367 #else /* __CRTL_VER < 70300000 */
10368
10369   register int i;
10370   int sts;
10371   long int bintime[2], len = 2, lowbit, unixtime,
10372            secscale = 10000000; /* seconds --> 100 ns intervals */
10373   unsigned long int chan, iosb[2], retsts;
10374   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10375   struct FAB myfab = cc$rms_fab;
10376   struct NAM mynam = cc$rms_nam;
10377 #if defined (__DECC) && defined (__VAX)
10378   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10379    * at least through VMS V6.1, which causes a type-conversion warning.
10380    */
10381 #  pragma message save
10382 #  pragma message disable cvtdiftypes
10383 #endif
10384   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10385   struct fibdef myfib;
10386 #if defined (__DECC) && defined (__VAX)
10387   /* This should be right after the declaration of myatr, but due
10388    * to a bug in VAX DEC C, this takes effect a statement early.
10389    */
10390 #  pragma message restore
10391 #endif
10392   /* cast ok for read only parameter */
10393   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10394                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10395                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10396
10397   if (file == NULL || *file == '\0') {
10398     SETERRNO(ENOENT, LIB$_INVARG);
10399     return -1;
10400   }
10401
10402   /* Convert to VMS format ensuring that it will fit in 255 characters */
10403   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10404       SETERRNO(ENOENT, LIB$_INVARG);
10405       return -1;
10406   }
10407   if (utimes != NULL) {
10408     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
10409      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10410      * Since time_t is unsigned long int, and lib$emul takes a signed long int
10411      * as input, we force the sign bit to be clear by shifting unixtime right
10412      * one bit, then multiplying by an extra factor of 2 in lib$emul().
10413      */
10414     lowbit = (utimes->modtime & 1) ? secscale : 0;
10415     unixtime = (long int) utimes->modtime;
10416 #   ifdef VMSISH_TIME
10417     /* If input was UTC; convert to local for sys svc */
10418     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10419 #   endif
10420     unixtime >>= 1;  secscale <<= 1;
10421     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10422     if (!(retsts & 1)) {
10423       SETERRNO(EVMSERR, retsts);
10424       return -1;
10425     }
10426     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10427     if (!(retsts & 1)) {
10428       SETERRNO(EVMSERR, retsts);
10429       return -1;
10430     }
10431   }
10432   else {
10433     /* Just get the current time in VMS format directly */
10434     retsts = sys$gettim(bintime);
10435     if (!(retsts & 1)) {
10436       SETERRNO(EVMSERR, retsts);
10437       return -1;
10438     }
10439   }
10440
10441   myfab.fab$l_fna = vmsspec;
10442   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10443   myfab.fab$l_nam = &mynam;
10444   mynam.nam$l_esa = esa;
10445   mynam.nam$b_ess = (unsigned char) sizeof esa;
10446   mynam.nam$l_rsa = rsa;
10447   mynam.nam$b_rss = (unsigned char) sizeof rsa;
10448   if (decc_efs_case_preserve)
10449       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10450
10451   /* Look for the file to be affected, letting RMS parse the file
10452    * specification for us as well.  I have set errno using only
10453    * values documented in the utime() man page for VMS POSIX.
10454    */
10455   retsts = sys$parse(&myfab,0,0);
10456   if (!(retsts & 1)) {
10457     set_vaxc_errno(retsts);
10458     if      (retsts == RMS$_PRV) set_errno(EACCES);
10459     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10460     else                         set_errno(EVMSERR);
10461     return -1;
10462   }
10463   retsts = sys$search(&myfab,0,0);
10464   if (!(retsts & 1)) {
10465     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10466     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10467     set_vaxc_errno(retsts);
10468     if      (retsts == RMS$_PRV) set_errno(EACCES);
10469     else if (retsts == RMS$_FNF) set_errno(ENOENT);
10470     else                         set_errno(EVMSERR);
10471     return -1;
10472   }
10473
10474   devdsc.dsc$w_length = mynam.nam$b_dev;
10475   /* cast ok for read only parameter */
10476   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10477
10478   retsts = sys$assign(&devdsc,&chan,0,0);
10479   if (!(retsts & 1)) {
10480     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10481     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10482     set_vaxc_errno(retsts);
10483     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
10484     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
10485     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
10486     else                               set_errno(EVMSERR);
10487     return -1;
10488   }
10489
10490   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10491   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10492
10493   memset((void *) &myfib, 0, sizeof myfib);
10494 #if defined(__DECC) || defined(__DECCXX)
10495   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10496   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10497   /* This prevents the revision time of the file being reset to the current
10498    * time as a result of our IO$_MODIFY $QIO. */
10499   myfib.fib$l_acctl = FIB$M_NORECORD;
10500 #else
10501   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10502   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10503   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10504 #endif
10505   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10506   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10507   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10508   _ckvmssts(sys$dassgn(chan));
10509   if (retsts & 1) retsts = iosb[0];
10510   if (!(retsts & 1)) {
10511     set_vaxc_errno(retsts);
10512     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10513     else                      set_errno(EVMSERR);
10514     return -1;
10515   }
10516
10517   return 0;
10518
10519 #endif /* #if __CRTL_VER >= 70300000 */
10520
10521 }  /* end of my_utime() */
10522 /*}}}*/
10523
10524 /*
10525  * flex_stat, flex_lstat, flex_fstat
10526  * basic stat, but gets it right when asked to stat
10527  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10528  */
10529
10530 #ifndef _USE_STD_STAT
10531 /* encode_dev packs a VMS device name string into an integer to allow
10532  * simple comparisons. This can be used, for example, to check whether two
10533  * files are located on the same device, by comparing their encoded device
10534  * names. Even a string comparison would not do, because stat() reuses the
10535  * device name buffer for each call; so without encode_dev, it would be
10536  * necessary to save the buffer and use strcmp (this would mean a number of
10537  * changes to the standard Perl code, to say nothing of what a Perl script
10538  * would have to do.
10539  *
10540  * The device lock id, if it exists, should be unique (unless perhaps compared
10541  * with lock ids transferred from other nodes). We have a lock id if the disk is
10542  * mounted cluster-wide, which is when we tend to get long (host-qualified)
10543  * device names. Thus we use the lock id in preference, and only if that isn't
10544  * available, do we try to pack the device name into an integer (flagged by
10545  * the sign bit (LOCKID_MASK) being set).
10546  *
10547  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10548  * name and its encoded form, but it seems very unlikely that we will find
10549  * two files on different disks that share the same encoded device names,
10550  * and even more remote that they will share the same file id (if the test
10551  * is to check for the same file).
10552  *
10553  * A better method might be to use sys$device_scan on the first call, and to
10554  * search for the device, returning an index into the cached array.
10555  * The number returned would be more intelligible.
10556  * This is probably not worth it, and anyway would take quite a bit longer
10557  * on the first call.
10558  */
10559 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
10560 static mydev_t encode_dev (pTHX_ const char *dev)
10561 {
10562   int i;
10563   unsigned long int f;
10564   mydev_t enc;
10565   char c;
10566   const char *q;
10567
10568   if (!dev || !dev[0]) return 0;
10569
10570 #if LOCKID_MASK
10571   {
10572     struct dsc$descriptor_s dev_desc;
10573     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10574
10575     /* For cluster-mounted disks, the disk lock identifier is unique, so we
10576        can try that first. */
10577     dev_desc.dsc$w_length =  strlen (dev);
10578     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
10579     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
10580     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
10581     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10582     if (!$VMS_STATUS_SUCCESS(status)) {
10583       switch (status) {
10584         case SS$_NOSUCHDEV:
10585           SETERRNO(ENODEV, status);
10586           return 0;
10587         default:
10588           _ckvmssts(status);
10589       }
10590     }
10591     if (lockid) return (lockid & ~LOCKID_MASK);
10592   }
10593 #endif
10594
10595   /* Otherwise we try to encode the device name */
10596   enc = 0;
10597   f = 1;
10598   i = 0;
10599   for (q = dev + strlen(dev); q--; q >= dev) {
10600     if (*q == ':')
10601         break;
10602     if (isdigit (*q))
10603       c= (*q) - '0';
10604     else if (isalpha (toupper (*q)))
10605       c= toupper (*q) - 'A' + (char)10;
10606     else
10607       continue; /* Skip '$'s */
10608     i++;
10609     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
10610     if (i>1) f *= 36;
10611     enc += f * (unsigned long int) c;
10612   }
10613   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
10614
10615 }  /* end of encode_dev() */
10616 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10617         device_no = encode_dev(aTHX_ devname)
10618 #else
10619 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10620         device_no = new_dev_no
10621 #endif
10622
10623 static int
10624 is_null_device(name)
10625     const char *name;
10626 {
10627   if (decc_bug_devnull != 0) {
10628     if (strncmp("/dev/null", name, 9) == 0)
10629       return 1;
10630   }
10631     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10632        The underscore prefix, controller letter, and unit number are
10633        independently optional; for our purposes, the colon punctuation
10634        is not.  The colon can be trailed by optional directory and/or
10635        filename, but two consecutive colons indicates a nodename rather
10636        than a device.  [pr]  */
10637   if (*name == '_') ++name;
10638   if (tolower(*name++) != 'n') return 0;
10639   if (tolower(*name++) != 'l') return 0;
10640   if (tolower(*name) == 'a') ++name;
10641   if (*name == '0') ++name;
10642   return (*name++ == ':') && (*name != ':');
10643 }
10644
10645
10646 static I32
10647 Perl_cando_by_name_int
10648    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10649 {
10650   static char usrname[L_cuserid];
10651   static struct dsc$descriptor_s usrdsc =
10652          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10653   char vmsname[NAM$C_MAXRSS+1];
10654   char *fileified;
10655   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10656   unsigned short int retlen, trnlnm_iter_count;
10657   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10658   union prvdef curprv;
10659   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10660          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10661          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10662   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10663          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10664          {0,0,0,0}};
10665   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10666          {0,0,0,0}};
10667   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10668
10669   if (!fname || !*fname) return FALSE;
10670   /* Make sure we expand logical names, since sys$check_access doesn't */
10671
10672   fileified = NULL;
10673   if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
10674     fileified = PerlMem_malloc(VMS_MAXRSS);
10675     if (!strpbrk(fname,"/]>:")) {
10676       strcpy(fileified,fname);
10677       trnlnm_iter_count = 0;
10678       while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10679         trnlnm_iter_count++;
10680         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10681       }
10682       fname = fileified;
10683     }
10684     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10685       PerlMem_free(fileified);
10686       return FALSE;
10687     }
10688     retlen = namdsc.dsc$w_length = strlen(vmsname);
10689     namdsc.dsc$a_pointer = vmsname;
10690     if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10691       vmsname[retlen-1] == ':') {
10692       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) return FALSE;
10693       namdsc.dsc$w_length = strlen(fileified);
10694       namdsc.dsc$a_pointer = fileified;
10695     }
10696   }
10697   else {
10698     retlen = namdsc.dsc$w_length = strlen(fname);
10699     namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
10700   }
10701
10702   switch (bit) {
10703     case S_IXUSR: case S_IXGRP: case S_IXOTH:
10704       access = ARM$M_EXECUTE;
10705       flags = CHP$M_READ;
10706       break;
10707     case S_IRUSR: case S_IRGRP: case S_IROTH:
10708       access = ARM$M_READ;
10709       flags = CHP$M_READ | CHP$M_USEREADALL;
10710       break;
10711     case S_IWUSR: case S_IWGRP: case S_IWOTH:
10712       access = ARM$M_WRITE;
10713       flags = CHP$M_READ | CHP$M_WRITE;
10714       break;
10715     case S_IDUSR: case S_IDGRP: case S_IDOTH:
10716       access = ARM$M_DELETE;
10717       flags = CHP$M_READ | CHP$M_WRITE;
10718       break;
10719     default:
10720       if (fileified != NULL)
10721         PerlMem_free(fileified);
10722       return FALSE;
10723   }
10724
10725   /* Before we call $check_access, create a user profile with the current
10726    * process privs since otherwise it just uses the default privs from the
10727    * UAF and might give false positives or negatives.  This only works on
10728    * VMS versions v6.0 and later since that's when sys$create_user_profile
10729    * became available.
10730    */
10731
10732   /* get current process privs and username */
10733   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
10734   _ckvmssts(iosb[0]);
10735
10736 #if defined(__VMS_VER) && __VMS_VER >= 60000000
10737
10738   /* find out the space required for the profile */
10739   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
10740                                     &usrprodsc.dsc$w_length,0));
10741
10742   /* allocate space for the profile and get it filled in */
10743   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
10744   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10745   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
10746                                     &usrprodsc.dsc$w_length,0));
10747
10748   /* use the profile to check access to the file; free profile & analyze results */
10749   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
10750   PerlMem_free(usrprodsc.dsc$a_pointer);
10751   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
10752
10753 #else
10754
10755   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
10756
10757 #endif
10758
10759   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
10760       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
10761       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
10762     set_vaxc_errno(retsts);
10763     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10764     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
10765     else set_errno(ENOENT);
10766     if (fileified != NULL)
10767       PerlMem_free(fileified);
10768     return FALSE;
10769   }
10770   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
10771     if (fileified != NULL)
10772       PerlMem_free(fileified);
10773     return TRUE;
10774   }
10775   _ckvmssts(retsts);
10776
10777   if (fileified != NULL)
10778     PerlMem_free(fileified);
10779   return FALSE;  /* Should never get here */
10780
10781 }
10782
10783 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
10784 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
10785  * subset of the applicable information.
10786  */
10787 bool
10788 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
10789 {
10790   return cando_by_name_int
10791         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
10792 }  /* end of cando() */
10793 /*}}}*/
10794
10795
10796 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
10797 I32
10798 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
10799 {
10800    return cando_by_name_int(bit, effective, fname, 0);
10801
10802 }  /* end of cando_by_name() */
10803 /*}}}*/
10804
10805
10806 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
10807 int
10808 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
10809 {
10810   if (!fstat(fd,(stat_t *) statbufp)) {
10811     char *cptr;
10812     char *vms_filename;
10813     vms_filename = PerlMem_malloc(VMS_MAXRSS);
10814     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
10815
10816     /* Save name for cando by name in VMS format */
10817     cptr = getname(fd, vms_filename, 1);
10818
10819     /* This should not happen, but just in case */
10820     if (cptr == NULL) {
10821         statbufp->st_devnam[0] = 0;
10822     }
10823     else {
10824         /* Make sure that the saved name fits in 255 characters */
10825         cptr = do_rmsexpand
10826                        (vms_filename,
10827                         statbufp->st_devnam,
10828                         0,
10829                         NULL,
10830                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
10831                         NULL,
10832                         NULL);
10833         if (cptr == NULL)
10834             statbufp->st_devnam[0] = 0;
10835     }
10836     PerlMem_free(vms_filename);
10837
10838     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10839     VMS_DEVICE_ENCODE
10840         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10841
10842 #   ifdef RTL_USES_UTC
10843 #   ifdef VMSISH_TIME
10844     if (VMSISH_TIME) {
10845       statbufp->st_mtime = _toloc(statbufp->st_mtime);
10846       statbufp->st_atime = _toloc(statbufp->st_atime);
10847       statbufp->st_ctime = _toloc(statbufp->st_ctime);
10848     }
10849 #   endif
10850 #   else
10851 #   ifdef VMSISH_TIME
10852     if (!VMSISH_TIME) { /* Return UTC instead of local time */
10853 #   else
10854     if (1) {
10855 #   endif
10856       statbufp->st_mtime = _toutc(statbufp->st_mtime);
10857       statbufp->st_atime = _toutc(statbufp->st_atime);
10858       statbufp->st_ctime = _toutc(statbufp->st_ctime);
10859     }
10860 #endif
10861     return 0;
10862   }
10863   return -1;
10864
10865 }  /* end of flex_fstat() */
10866 /*}}}*/
10867
10868 #if !defined(__VAX) && __CRTL_VER >= 80200000
10869 #ifdef lstat
10870 #undef lstat
10871 #endif
10872 #else
10873 #ifdef lstat
10874 #undef lstat
10875 #endif
10876 #define lstat(_x, _y) stat(_x, _y)
10877 #endif
10878
10879 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
10880
10881 static int
10882 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
10883 {
10884     char fileified[VMS_MAXRSS];
10885     char temp_fspec[VMS_MAXRSS];
10886     char *save_spec;
10887     int retval = -1;
10888     int saved_errno, saved_vaxc_errno;
10889
10890     if (!fspec) return retval;
10891     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
10892     strcpy(temp_fspec, fspec);
10893
10894     if (decc_bug_devnull != 0) {
10895       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
10896         memset(statbufp,0,sizeof *statbufp);
10897         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
10898         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
10899         statbufp->st_uid = 0x00010001;
10900         statbufp->st_gid = 0x0001;
10901         time((time_t *)&statbufp->st_mtime);
10902         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
10903         return 0;
10904       }
10905     }
10906
10907     /* Try for a directory name first.  If fspec contains a filename without
10908      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
10909      * and sea:[wine.dark]water. exist, we prefer the directory here.
10910      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
10911      * not sea:[wine.dark]., if the latter exists.  If the intended target is
10912      * the file with null type, specify this by calling flex_stat() with
10913      * a '.' at the end of fspec.
10914      *
10915      * If we are in Posix filespec mode, accept the filename as is.
10916      */
10917 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10918   if (decc_posix_compliant_pathnames == 0) {
10919 #endif
10920     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
10921       if (lstat_flag == 0)
10922         retval = stat(fileified,(stat_t *) statbufp);
10923       else
10924         retval = lstat(fileified,(stat_t *) statbufp);
10925       save_spec = fileified;
10926     }
10927     if (retval) {
10928       if (lstat_flag == 0)
10929         retval = stat(temp_fspec,(stat_t *) statbufp);
10930       else
10931         retval = lstat(temp_fspec,(stat_t *) statbufp);
10932       save_spec = temp_fspec;
10933     }
10934 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10935   } else {
10936     if (lstat_flag == 0)
10937       retval = stat(temp_fspec,(stat_t *) statbufp);
10938     else
10939       retval = lstat(temp_fspec,(stat_t *) statbufp);
10940       save_spec = temp_fspec;
10941   }
10942 #endif
10943     if (!retval) {
10944     char * cptr;
10945       cptr = do_rmsexpand
10946        (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
10947       if (cptr == NULL)
10948         statbufp->st_devnam[0] = 0;
10949
10950       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10951       VMS_DEVICE_ENCODE
10952         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10953 #     ifdef RTL_USES_UTC
10954 #     ifdef VMSISH_TIME
10955       if (VMSISH_TIME) {
10956         statbufp->st_mtime = _toloc(statbufp->st_mtime);
10957         statbufp->st_atime = _toloc(statbufp->st_atime);
10958         statbufp->st_ctime = _toloc(statbufp->st_ctime);
10959       }
10960 #     endif
10961 #     else
10962 #     ifdef VMSISH_TIME
10963       if (!VMSISH_TIME) { /* Return UTC instead of local time */
10964 #     else
10965       if (1) {
10966 #     endif
10967         statbufp->st_mtime = _toutc(statbufp->st_mtime);
10968         statbufp->st_atime = _toutc(statbufp->st_atime);
10969         statbufp->st_ctime = _toutc(statbufp->st_ctime);
10970       }
10971 #     endif
10972     }
10973     /* If we were successful, leave errno where we found it */
10974     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
10975     return retval;
10976
10977 }  /* end of flex_stat_int() */
10978
10979
10980 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
10981 int
10982 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
10983 {
10984    return flex_stat_int(fspec, statbufp, 0);
10985 }
10986 /*}}}*/
10987
10988 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
10989 int
10990 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
10991 {
10992    return flex_stat_int(fspec, statbufp, 1);
10993 }
10994 /*}}}*/
10995
10996
10997 /*{{{char *my_getlogin()*/
10998 /* VMS cuserid == Unix getlogin, except calling sequence */
10999 char *
11000 my_getlogin(void)
11001 {
11002     static char user[L_cuserid];
11003     return cuserid(user);
11004 }
11005 /*}}}*/
11006
11007
11008 /*  rmscopy - copy a file using VMS RMS routines
11009  *
11010  *  Copies contents and attributes of spec_in to spec_out, except owner
11011  *  and protection information.  Name and type of spec_in are used as
11012  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
11013  *  should try to propagate timestamps from the input file to the output file.
11014  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
11015  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
11016  *  propagated to the output file at creation iff the output file specification
11017  *  did not contain an explicit name or type, and the revision date is always
11018  *  updated at the end of the copy operation.  If it is greater than 0, then
11019  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11020  *  other than the revision date should be propagated, and bit 1 indicates
11021  *  that the revision date should be propagated.
11022  *
11023  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11024  *
11025  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11026  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
11027  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
11028  * as part of the Perl standard distribution under the terms of the
11029  * GNU General Public License or the Perl Artistic License.  Copies
11030  * of each may be found in the Perl standard distribution.
11031  */ /* FIXME */
11032 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11033 int
11034 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11035 {
11036     char *vmsin, * vmsout, *esa, *esa_out,
11037          *rsa, *ubf;
11038     unsigned long int i, sts, sts2;
11039     int dna_len;
11040     struct FAB fab_in, fab_out;
11041     struct RAB rab_in, rab_out;
11042     rms_setup_nam(nam);
11043     rms_setup_nam(nam_out);
11044     struct XABDAT xabdat;
11045     struct XABFHC xabfhc;
11046     struct XABRDT xabrdt;
11047     struct XABSUM xabsum;
11048
11049     vmsin = PerlMem_malloc(VMS_MAXRSS);
11050     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11051     vmsout = PerlMem_malloc(VMS_MAXRSS);
11052     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11053     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11054         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11055       PerlMem_free(vmsin);
11056       PerlMem_free(vmsout);
11057       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11058       return 0;
11059     }
11060
11061     esa = PerlMem_malloc(VMS_MAXRSS);
11062     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11063     fab_in = cc$rms_fab;
11064     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11065     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11066     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11067     fab_in.fab$l_fop = FAB$M_SQO;
11068     rms_bind_fab_nam(fab_in, nam);
11069     fab_in.fab$l_xab = (void *) &xabdat;
11070
11071     rsa = PerlMem_malloc(VMS_MAXRSS);
11072     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11073     rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11074     rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11075     rms_nam_esl(nam) = 0;
11076     rms_nam_rsl(nam) = 0;
11077     rms_nam_esll(nam) = 0;
11078     rms_nam_rsll(nam) = 0;
11079 #ifdef NAM$M_NO_SHORT_UPCASE
11080     if (decc_efs_case_preserve)
11081         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11082 #endif
11083
11084     xabdat = cc$rms_xabdat;        /* To get creation date */
11085     xabdat.xab$l_nxt = (void *) &xabfhc;
11086
11087     xabfhc = cc$rms_xabfhc;        /* To get record length */
11088     xabfhc.xab$l_nxt = (void *) &xabsum;
11089
11090     xabsum = cc$rms_xabsum;        /* To get key and area information */
11091
11092     if (!((sts = sys$open(&fab_in)) & 1)) {
11093       PerlMem_free(vmsin);
11094       PerlMem_free(vmsout);
11095       PerlMem_free(esa);
11096       PerlMem_free(rsa);
11097       set_vaxc_errno(sts);
11098       switch (sts) {
11099         case RMS$_FNF: case RMS$_DNF:
11100           set_errno(ENOENT); break;
11101         case RMS$_DIR:
11102           set_errno(ENOTDIR); break;
11103         case RMS$_DEV:
11104           set_errno(ENODEV); break;
11105         case RMS$_SYN:
11106           set_errno(EINVAL); break;
11107         case RMS$_PRV:
11108           set_errno(EACCES); break;
11109         default:
11110           set_errno(EVMSERR);
11111       }
11112       return 0;
11113     }
11114
11115     nam_out = nam;
11116     fab_out = fab_in;
11117     fab_out.fab$w_ifi = 0;
11118     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11119     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11120     fab_out.fab$l_fop = FAB$M_SQO;
11121     rms_bind_fab_nam(fab_out, nam_out);
11122     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11123     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11124     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11125     esa_out = PerlMem_malloc(VMS_MAXRSS);
11126     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11127     rms_set_rsa(nam_out, NULL, 0);
11128     rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11129
11130     if (preserve_dates == 0) {  /* Act like DCL COPY */
11131       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11132       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
11133       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11134         PerlMem_free(vmsin);
11135         PerlMem_free(vmsout);
11136         PerlMem_free(esa);
11137         PerlMem_free(rsa);
11138         PerlMem_free(esa_out);
11139         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11140         set_vaxc_errno(sts);
11141         return 0;
11142       }
11143       fab_out.fab$l_xab = (void *) &xabdat;
11144       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11145         preserve_dates = 1;
11146     }
11147     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
11148       preserve_dates =0;      /* bitmask from this point forward   */
11149
11150     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11151     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11152       PerlMem_free(vmsin);
11153       PerlMem_free(vmsout);
11154       PerlMem_free(esa);
11155       PerlMem_free(rsa);
11156       PerlMem_free(esa_out);
11157       set_vaxc_errno(sts);
11158       switch (sts) {
11159         case RMS$_DNF:
11160           set_errno(ENOENT); break;
11161         case RMS$_DIR:
11162           set_errno(ENOTDIR); break;
11163         case RMS$_DEV:
11164           set_errno(ENODEV); break;
11165         case RMS$_SYN:
11166           set_errno(EINVAL); break;
11167         case RMS$_PRV:
11168           set_errno(EACCES); break;
11169         default:
11170           set_errno(EVMSERR);
11171       }
11172       return 0;
11173     }
11174     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
11175     if (preserve_dates & 2) {
11176       /* sys$close() will process xabrdt, not xabdat */
11177       xabrdt = cc$rms_xabrdt;
11178 #ifndef __GNUC__
11179       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11180 #else
11181       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11182        * is unsigned long[2], while DECC & VAXC use a struct */
11183       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11184 #endif
11185       fab_out.fab$l_xab = (void *) &xabrdt;
11186     }
11187
11188     ubf = PerlMem_malloc(32256);
11189     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11190     rab_in = cc$rms_rab;
11191     rab_in.rab$l_fab = &fab_in;
11192     rab_in.rab$l_rop = RAB$M_BIO;
11193     rab_in.rab$l_ubf = ubf;
11194     rab_in.rab$w_usz = 32256;
11195     if (!((sts = sys$connect(&rab_in)) & 1)) {
11196       sys$close(&fab_in); sys$close(&fab_out);
11197       PerlMem_free(vmsin);
11198       PerlMem_free(vmsout);
11199       PerlMem_free(esa);
11200       PerlMem_free(ubf);
11201       PerlMem_free(rsa);
11202       PerlMem_free(esa_out);
11203       set_errno(EVMSERR); set_vaxc_errno(sts);
11204       return 0;
11205     }
11206
11207     rab_out = cc$rms_rab;
11208     rab_out.rab$l_fab = &fab_out;
11209     rab_out.rab$l_rbf = ubf;
11210     if (!((sts = sys$connect(&rab_out)) & 1)) {
11211       sys$close(&fab_in); sys$close(&fab_out);
11212       PerlMem_free(vmsin);
11213       PerlMem_free(vmsout);
11214       PerlMem_free(esa);
11215       PerlMem_free(ubf);
11216       PerlMem_free(rsa);
11217       PerlMem_free(esa_out);
11218       set_errno(EVMSERR); set_vaxc_errno(sts);
11219       return 0;
11220     }
11221
11222     while ((sts = sys$read(&rab_in))) {  /* always true  */
11223       if (sts == RMS$_EOF) break;
11224       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11225       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11226         sys$close(&fab_in); sys$close(&fab_out);
11227         PerlMem_free(vmsin);
11228         PerlMem_free(vmsout);
11229         PerlMem_free(esa);
11230         PerlMem_free(ubf);
11231         PerlMem_free(rsa);
11232         PerlMem_free(esa_out);
11233         set_errno(EVMSERR); set_vaxc_errno(sts);
11234         return 0;
11235       }
11236     }
11237
11238
11239     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
11240     sys$close(&fab_in);  sys$close(&fab_out);
11241     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11242     if (!(sts & 1)) {
11243       PerlMem_free(vmsin);
11244       PerlMem_free(vmsout);
11245       PerlMem_free(esa);
11246       PerlMem_free(ubf);
11247       PerlMem_free(rsa);
11248       PerlMem_free(esa_out);
11249       set_errno(EVMSERR); set_vaxc_errno(sts);
11250       return 0;
11251     }
11252
11253     PerlMem_free(vmsin);
11254     PerlMem_free(vmsout);
11255     PerlMem_free(esa);
11256     PerlMem_free(ubf);
11257     PerlMem_free(rsa);
11258     PerlMem_free(esa_out);
11259     return 1;
11260
11261 }  /* end of rmscopy() */
11262 /*}}}*/
11263
11264
11265 /***  The following glue provides 'hooks' to make some of the routines
11266  * from this file available from Perl.  These routines are sufficiently
11267  * basic, and are required sufficiently early in the build process,
11268  * that's it's nice to have them available to miniperl as well as the
11269  * full Perl, so they're set up here instead of in an extension.  The
11270  * Perl code which handles importation of these names into a given
11271  * package lives in [.VMS]Filespec.pm in @INC.
11272  */
11273
11274 void
11275 rmsexpand_fromperl(pTHX_ CV *cv)
11276 {
11277   dXSARGS;
11278   char *fspec, *defspec = NULL, *rslt;
11279   STRLEN n_a;
11280   int fs_utf8, dfs_utf8;
11281
11282   fs_utf8 = 0;
11283   dfs_utf8 = 0;
11284   if (!items || items > 2)
11285     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11286   fspec = SvPV(ST(0),n_a);
11287   fs_utf8 = SvUTF8(ST(0));
11288   if (!fspec || !*fspec) XSRETURN_UNDEF;
11289   if (items == 2) {
11290     defspec = SvPV(ST(1),n_a);
11291     dfs_utf8 = SvUTF8(ST(1));
11292   }
11293   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11294   ST(0) = sv_newmortal();
11295   if (rslt != NULL) {
11296     sv_usepvn(ST(0),rslt,strlen(rslt));
11297     if (fs_utf8) {
11298         SvUTF8_on(ST(0));
11299     }
11300   }
11301   XSRETURN(1);
11302 }
11303
11304 void
11305 vmsify_fromperl(pTHX_ CV *cv)
11306 {
11307   dXSARGS;
11308   char *vmsified;
11309   STRLEN n_a;
11310   int utf8_fl;
11311
11312   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11313   utf8_fl = SvUTF8(ST(0));
11314   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11315   ST(0) = sv_newmortal();
11316   if (vmsified != NULL) {
11317     sv_usepvn(ST(0),vmsified,strlen(vmsified));
11318     if (utf8_fl) {
11319         SvUTF8_on(ST(0));
11320     }
11321   }
11322   XSRETURN(1);
11323 }
11324
11325 void
11326 unixify_fromperl(pTHX_ CV *cv)
11327 {
11328   dXSARGS;
11329   char *unixified;
11330   STRLEN n_a;
11331   int utf8_fl;
11332
11333   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11334   utf8_fl = SvUTF8(ST(0));
11335   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11336   ST(0) = sv_newmortal();
11337   if (unixified != NULL) {
11338     sv_usepvn(ST(0),unixified,strlen(unixified));
11339     if (utf8_fl) {
11340         SvUTF8_on(ST(0));
11341     }
11342   }
11343   XSRETURN(1);
11344 }
11345
11346 void
11347 fileify_fromperl(pTHX_ CV *cv)
11348 {
11349   dXSARGS;
11350   char *fileified;
11351   STRLEN n_a;
11352   int utf8_fl;
11353
11354   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11355   utf8_fl = SvUTF8(ST(0));
11356   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11357   ST(0) = sv_newmortal();
11358   if (fileified != NULL) {
11359     sv_usepvn(ST(0),fileified,strlen(fileified));
11360     if (utf8_fl) {
11361         SvUTF8_on(ST(0));
11362     }
11363   }
11364   XSRETURN(1);
11365 }
11366
11367 void
11368 pathify_fromperl(pTHX_ CV *cv)
11369 {
11370   dXSARGS;
11371   char *pathified;
11372   STRLEN n_a;
11373   int utf8_fl;
11374
11375   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11376   utf8_fl = SvUTF8(ST(0));
11377   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11378   ST(0) = sv_newmortal();
11379   if (pathified != NULL) {
11380     sv_usepvn(ST(0),pathified,strlen(pathified));
11381     if (utf8_fl) {
11382         SvUTF8_on(ST(0));
11383     }
11384   }
11385   XSRETURN(1);
11386 }
11387
11388 void
11389 vmspath_fromperl(pTHX_ CV *cv)
11390 {
11391   dXSARGS;
11392   char *vmspath;
11393   STRLEN n_a;
11394   int utf8_fl;
11395
11396   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11397   utf8_fl = SvUTF8(ST(0));
11398   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11399   ST(0) = sv_newmortal();
11400   if (vmspath != NULL) {
11401     sv_usepvn(ST(0),vmspath,strlen(vmspath));
11402     if (utf8_fl) {
11403         SvUTF8_on(ST(0));
11404     }
11405   }
11406   XSRETURN(1);
11407 }
11408
11409 void
11410 unixpath_fromperl(pTHX_ CV *cv)
11411 {
11412   dXSARGS;
11413   char *unixpath;
11414   STRLEN n_a;
11415   int utf8_fl;
11416
11417   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11418   utf8_fl = SvUTF8(ST(0));
11419   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11420   ST(0) = sv_newmortal();
11421   if (unixpath != NULL) {
11422     sv_usepvn(ST(0),unixpath,strlen(unixpath));
11423     if (utf8_fl) {
11424         SvUTF8_on(ST(0));
11425     }
11426   }
11427   XSRETURN(1);
11428 }
11429
11430 void
11431 candelete_fromperl(pTHX_ CV *cv)
11432 {
11433   dXSARGS;
11434   char *fspec, *fsp;
11435   SV *mysv;
11436   IO *io;
11437   STRLEN n_a;
11438
11439   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11440
11441   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11442   Newx(fspec, VMS_MAXRSS, char);
11443   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11444   if (SvTYPE(mysv) == SVt_PVGV) {
11445     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11446       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11447       ST(0) = &PL_sv_no;
11448       Safefree(fspec);
11449       XSRETURN(1);
11450     }
11451     fsp = fspec;
11452   }
11453   else {
11454     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11455       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11456       ST(0) = &PL_sv_no;
11457       Safefree(fspec);
11458       XSRETURN(1);
11459     }
11460   }
11461
11462   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11463   Safefree(fspec);
11464   XSRETURN(1);
11465 }
11466
11467 void
11468 rmscopy_fromperl(pTHX_ CV *cv)
11469 {
11470   dXSARGS;
11471   char *inspec, *outspec, *inp, *outp;
11472   int date_flag;
11473   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11474                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11475   unsigned long int sts;
11476   SV *mysv;
11477   IO *io;
11478   STRLEN n_a;
11479
11480   if (items < 2 || items > 3)
11481     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11482
11483   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11484   Newx(inspec, VMS_MAXRSS, char);
11485   if (SvTYPE(mysv) == SVt_PVGV) {
11486     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11487       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11488       ST(0) = &PL_sv_no;
11489       Safefree(inspec);
11490       XSRETURN(1);
11491     }
11492     inp = inspec;
11493   }
11494   else {
11495     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11496       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11497       ST(0) = &PL_sv_no;
11498       Safefree(inspec);
11499       XSRETURN(1);
11500     }
11501   }
11502   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11503   Newx(outspec, VMS_MAXRSS, char);
11504   if (SvTYPE(mysv) == SVt_PVGV) {
11505     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11506       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11507       ST(0) = &PL_sv_no;
11508       Safefree(inspec);
11509       Safefree(outspec);
11510       XSRETURN(1);
11511     }
11512     outp = outspec;
11513   }
11514   else {
11515     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11516       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11517       ST(0) = &PL_sv_no;
11518       Safefree(inspec);
11519       Safefree(outspec);
11520       XSRETURN(1);
11521     }
11522   }
11523   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11524
11525   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11526   Safefree(inspec);
11527   Safefree(outspec);
11528   XSRETURN(1);
11529 }
11530
11531 /* The mod2fname is limited to shorter filenames by design, so it should
11532  * not be modified to support longer EFS pathnames
11533  */
11534 void
11535 mod2fname(pTHX_ CV *cv)
11536 {
11537   dXSARGS;
11538   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11539        workbuff[NAM$C_MAXRSS*1 + 1];
11540   int total_namelen = 3, counter, num_entries;
11541   /* ODS-5 ups this, but we want to be consistent, so... */
11542   int max_name_len = 39;
11543   AV *in_array = (AV *)SvRV(ST(0));
11544
11545   num_entries = av_len(in_array);
11546
11547   /* All the names start with PL_. */
11548   strcpy(ultimate_name, "PL_");
11549
11550   /* Clean up our working buffer */
11551   Zero(work_name, sizeof(work_name), char);
11552
11553   /* Run through the entries and build up a working name */
11554   for(counter = 0; counter <= num_entries; counter++) {
11555     /* If it's not the first name then tack on a __ */
11556     if (counter) {
11557       strcat(work_name, "__");
11558     }
11559     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11560                            PL_na));
11561   }
11562
11563   /* Check to see if we actually have to bother...*/
11564   if (strlen(work_name) + 3 <= max_name_len) {
11565     strcat(ultimate_name, work_name);
11566   } else {
11567     /* It's too darned big, so we need to go strip. We use the same */
11568     /* algorithm as xsubpp does. First, strip out doubled __ */
11569     char *source, *dest, last;
11570     dest = workbuff;
11571     last = 0;
11572     for (source = work_name; *source; source++) {
11573       if (last == *source && last == '_') {
11574         continue;
11575       }
11576       *dest++ = *source;
11577       last = *source;
11578     }
11579     /* Go put it back */
11580     strcpy(work_name, workbuff);
11581     /* Is it still too big? */
11582     if (strlen(work_name) + 3 > max_name_len) {
11583       /* Strip duplicate letters */
11584       last = 0;
11585       dest = workbuff;
11586       for (source = work_name; *source; source++) {
11587         if (last == toupper(*source)) {
11588         continue;
11589         }
11590         *dest++ = *source;
11591         last = toupper(*source);
11592       }
11593       strcpy(work_name, workbuff);
11594     }
11595
11596     /* Is it *still* too big? */
11597     if (strlen(work_name) + 3 > max_name_len) {
11598       /* Too bad, we truncate */
11599       work_name[max_name_len - 2] = 0;
11600     }
11601     strcat(ultimate_name, work_name);
11602   }
11603
11604   /* Okay, return it */
11605   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11606   XSRETURN(1);
11607 }
11608
11609 void
11610 hushexit_fromperl(pTHX_ CV *cv)
11611 {
11612     dXSARGS;
11613
11614     if (items > 0) {
11615         VMSISH_HUSHED = SvTRUE(ST(0));
11616     }
11617     ST(0) = boolSV(VMSISH_HUSHED);
11618     XSRETURN(1);
11619 }
11620
11621
11622 PerlIO *
11623 Perl_vms_start_glob
11624    (pTHX_ SV *tmpglob,
11625     IO *io)
11626 {
11627     PerlIO *fp;
11628     struct vs_str_st *rslt;
11629     char *vmsspec;
11630     char *rstr;
11631     char *begin, *cp;
11632     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11633     PerlIO *tmpfp;
11634     STRLEN i;
11635     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11636     struct dsc$descriptor_vs rsdsc;
11637     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11638     unsigned long hasver = 0, isunix = 0;
11639     unsigned long int lff_flags = 0;
11640     int rms_sts;
11641
11642 #ifdef VMS_LONGNAME_SUPPORT
11643     lff_flags = LIB$M_FIL_LONG_NAMES;
11644 #endif
11645     /* The Newx macro will not allow me to assign a smaller array
11646      * to the rslt pointer, so we will assign it to the begin char pointer
11647      * and then copy the value into the rslt pointer.
11648      */
11649     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11650     rslt = (struct vs_str_st *)begin;
11651     rslt->length = 0;
11652     rstr = &rslt->str[0];
11653     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11654     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11655     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11656     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11657
11658     Newx(vmsspec, VMS_MAXRSS, char);
11659
11660         /* We could find out if there's an explicit dev/dir or version
11661            by peeking into lib$find_file's internal context at
11662            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11663            but that's unsupported, so I don't want to do it now and
11664            have it bite someone in the future. */
11665         /* Fix-me: vms_split_path() is the only way to do this, the
11666            existing method will fail with many legal EFS or UNIX specifications
11667          */
11668
11669     cp = SvPV(tmpglob,i);
11670
11671     for (; i; i--) {
11672         if (cp[i] == ';') hasver = 1;
11673         if (cp[i] == '.') {
11674             if (sts) hasver = 1;
11675             else sts = 1;
11676         }
11677         if (cp[i] == '/') {
11678             hasdir = isunix = 1;
11679             break;
11680         }
11681         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11682             hasdir = 1;
11683             break;
11684         }
11685     }
11686     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11687         Stat_t st;
11688         int stat_sts;
11689         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11690         if (!stat_sts && S_ISDIR(st.st_mode)) {
11691             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
11692             ok = (wilddsc.dsc$a_pointer != NULL);
11693         }
11694         else {
11695             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
11696             ok = (wilddsc.dsc$a_pointer != NULL);
11697         }
11698         if (ok)
11699             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11700
11701         /* If not extended character set, replace ? with % */
11702         /* With extended character set, ? is a wildcard single character */
11703         if (!decc_efs_case_preserve) {
11704             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11705                 if (*cp == '?') *cp = '%';
11706         }
11707         sts = SS$_NORMAL;
11708         while (ok && $VMS_STATUS_SUCCESS(sts)) {
11709          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11710          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11711
11712             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11713                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
11714             if (!$VMS_STATUS_SUCCESS(sts))
11715                 break;
11716
11717             /* with varying string, 1st word of buffer contains result length */
11718             rstr[rslt->length] = '\0';
11719
11720              /* Find where all the components are */
11721              v_sts = vms_split_path
11722                        (rstr,
11723                         &v_spec,
11724                         &v_len,
11725                         &r_spec,
11726                         &r_len,
11727                         &d_spec,
11728                         &d_len,
11729                         &n_spec,
11730                         &n_len,
11731                         &e_spec,
11732                         &e_len,
11733                         &vs_spec,
11734                         &vs_len);
11735
11736             /* If no version on input, truncate the version on output */
11737             if (!hasver && (vs_len > 0)) {
11738                 *vs_spec = '\0';
11739                 vs_len = 0;
11740
11741                 /* No version & a null extension on UNIX handling */
11742                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
11743                     e_len = 0;
11744                     *e_spec = '\0';
11745                 }
11746             }
11747
11748             if (!decc_efs_case_preserve) {
11749                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
11750             }
11751
11752             if (hasdir) {
11753                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
11754                 begin = rstr;
11755             }
11756             else {
11757                 /* Start with the name */
11758                 begin = n_spec;
11759             }
11760             strcat(begin,"\n");
11761             ok = (PerlIO_puts(tmpfp,begin) != EOF);
11762         }
11763         if (cxt) (void)lib$find_file_end(&cxt);
11764         if (ok && sts != RMS$_NMF &&
11765             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
11766         if (!ok) {
11767             if (!(sts & 1)) {
11768                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
11769             }
11770             PerlIO_close(tmpfp);
11771             fp = NULL;
11772         }
11773         else {
11774             PerlIO_rewind(tmpfp);
11775             IoTYPE(io) = IoTYPE_RDONLY;
11776             IoIFP(io) = fp = tmpfp;
11777             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
11778         }
11779     }
11780     Safefree(vmsspec);
11781     Safefree(rslt);
11782     return fp;
11783 }
11784
11785 #ifdef HAS_SYMLINK
11786 static char *
11787 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
11788
11789 void
11790 vms_realpath_fromperl(pTHX_ CV *cv)
11791 {
11792   dXSARGS;
11793   char *fspec, *rslt_spec, *rslt;
11794   STRLEN n_a;
11795
11796   if (!items || items != 1)
11797     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
11798
11799   fspec = SvPV(ST(0),n_a);
11800   if (!fspec || !*fspec) XSRETURN_UNDEF;
11801
11802   Newx(rslt_spec, VMS_MAXRSS + 1, char);
11803   rslt = do_vms_realpath(fspec, rslt_spec, NULL);
11804   ST(0) = sv_newmortal();
11805   if (rslt != NULL)
11806     sv_usepvn(ST(0),rslt,strlen(rslt));
11807   else
11808     Safefree(rslt_spec);
11809   XSRETURN(1);
11810 }
11811 #endif
11812
11813 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11814 int do_vms_case_tolerant(void);
11815
11816 void
11817 vms_case_tolerant_fromperl(pTHX_ CV *cv)
11818 {
11819   dXSARGS;
11820   ST(0) = boolSV(do_vms_case_tolerant());
11821   XSRETURN(1);
11822 }
11823 #endif
11824
11825 void
11826 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
11827                           struct interp_intern *dst)
11828 {
11829     memcpy(dst,src,sizeof(struct interp_intern));
11830 }
11831
11832 void
11833 Perl_sys_intern_clear(pTHX)
11834 {
11835 }
11836
11837 void
11838 Perl_sys_intern_init(pTHX)
11839 {
11840     unsigned int ix = RAND_MAX;
11841     double x;
11842
11843     VMSISH_HUSHED = 0;
11844
11845     /* fix me later to track running under GNV */
11846     /* this allows some limited testing */
11847     MY_POSIX_EXIT = decc_filename_unix_report;
11848
11849     x = (float)ix;
11850     MY_INV_RAND_MAX = 1./x;
11851 }
11852
11853 void
11854 init_os_extras(void)
11855 {
11856   dTHX;
11857   char* file = __FILE__;
11858   if (decc_disable_to_vms_logname_translation) {
11859     no_translate_barewords = TRUE;
11860   } else {
11861     no_translate_barewords = FALSE;
11862   }
11863
11864   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
11865   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
11866   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
11867   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
11868   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
11869   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
11870   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
11871   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
11872   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
11873   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
11874   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
11875 #ifdef HAS_SYMLINK
11876   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
11877 #endif
11878 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11879   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
11880 #endif
11881
11882   store_pipelocs(aTHX);         /* will redo any earlier attempts */
11883
11884   return;
11885 }
11886
11887 #ifdef HAS_SYMLINK
11888
11889 #if __CRTL_VER == 80200000
11890 /* This missed getting in to the DECC SDK for 8.2 */
11891 char *realpath(const char *file_name, char * resolved_name, ...);
11892 #endif
11893
11894 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
11895 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
11896  * The perl fallback routine to provide realpath() is not as efficient
11897  * on OpenVMS.
11898  */
11899 static char *
11900 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11901 {
11902     return realpath(filespec, outbuf);
11903 }
11904
11905 /*}}}*/
11906 /* External entry points */
11907 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11908 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
11909 #else
11910 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11911 { return NULL; }
11912 #endif
11913
11914
11915 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11916 /* case_tolerant */
11917
11918 /*{{{int do_vms_case_tolerant(void)*/
11919 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
11920  * controlled by a process setting.
11921  */
11922 int do_vms_case_tolerant(void)
11923 {
11924     return vms_process_case_tolerant;
11925 }
11926 /*}}}*/
11927 /* External entry points */
11928 int Perl_vms_case_tolerant(void)
11929 { return do_vms_case_tolerant(); }
11930 #else
11931 int Perl_vms_case_tolerant(void)
11932 { return vms_process_case_tolerant; }
11933 #endif
11934
11935
11936  /* Start of DECC RTL Feature handling */
11937
11938 static int sys_trnlnm
11939    (const char * logname,
11940     char * value,
11941     int value_len)
11942 {
11943     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
11944     const unsigned long attr = LNM$M_CASE_BLIND;
11945     struct dsc$descriptor_s name_dsc;
11946     int status;
11947     unsigned short result;
11948     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
11949                                 {0, 0, 0, 0}};
11950
11951     name_dsc.dsc$w_length = strlen(logname);
11952     name_dsc.dsc$a_pointer = (char *)logname;
11953     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11954     name_dsc.dsc$b_class = DSC$K_CLASS_S;
11955
11956     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
11957
11958     if ($VMS_STATUS_SUCCESS(status)) {
11959
11960          /* Null terminate and return the string */
11961         /*--------------------------------------*/
11962         value[result] = 0;
11963     }
11964
11965     return status;
11966 }
11967
11968 static int sys_crelnm
11969    (const char * logname,
11970     const char * value)
11971 {
11972     int ret_val;
11973     const char * proc_table = "LNM$PROCESS_TABLE";
11974     struct dsc$descriptor_s proc_table_dsc;
11975     struct dsc$descriptor_s logname_dsc;
11976     struct itmlst_3 item_list[2];
11977
11978     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
11979     proc_table_dsc.dsc$w_length = strlen(proc_table);
11980     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11981     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
11982
11983     logname_dsc.dsc$a_pointer = (char *) logname;
11984     logname_dsc.dsc$w_length = strlen(logname);
11985     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11986     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
11987
11988     item_list[0].buflen = strlen(value);
11989     item_list[0].itmcode = LNM$_STRING;
11990     item_list[0].bufadr = (char *)value;
11991     item_list[0].retlen = NULL;
11992
11993     item_list[1].buflen = 0;
11994     item_list[1].itmcode = 0;
11995
11996     ret_val = sys$crelnm
11997                        (NULL,
11998                         (const struct dsc$descriptor_s *)&proc_table_dsc,
11999                         (const struct dsc$descriptor_s *)&logname_dsc,
12000                         NULL,
12001                         (const struct item_list_3 *) item_list);
12002
12003     return ret_val;
12004 }
12005
12006 /* C RTL Feature settings */
12007
12008 static int set_features
12009    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
12010     int (* cli_routine)(void),  /* Not documented */
12011     void *image_info)           /* Not documented */
12012 {
12013     int status;
12014     int s;
12015     int dflt;
12016     char* str;
12017     char val_str[10];
12018 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12019     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12020     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12021     unsigned long case_perm;
12022     unsigned long case_image;
12023 #endif
12024
12025     /* Allow an exception to bring Perl into the VMS debugger */
12026     vms_debug_on_exception = 0;
12027     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12028     if ($VMS_STATUS_SUCCESS(status)) {
12029        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12030          vms_debug_on_exception = 1;
12031        else
12032          vms_debug_on_exception = 0;
12033     }
12034
12035     /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
12036     vms_vtf7_filenames = 0;
12037     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12038     if ($VMS_STATUS_SUCCESS(status)) {
12039        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12040          vms_vtf7_filenames = 1;
12041        else
12042          vms_vtf7_filenames = 0;
12043     }
12044
12045     /* Dectect running under GNV Bash or other UNIX like shell */
12046 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12047     gnv_unix_shell = 0;
12048     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12049     if ($VMS_STATUS_SUCCESS(status)) {
12050        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12051          gnv_unix_shell = 1;
12052          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12053          set_feature_default("DECC$EFS_CHARSET", 1);
12054          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12055          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12056          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12057          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12058        }
12059        else
12060          gnv_unix_shell = 0;
12061     }
12062 #endif
12063
12064     /* hacks to see if known bugs are still present for testing */
12065
12066     /* Readdir is returning filenames in VMS syntax always */
12067     decc_bug_readdir_efs1 = 1;
12068     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12069     if ($VMS_STATUS_SUCCESS(status)) {
12070        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12071          decc_bug_readdir_efs1 = 1;
12072        else
12073          decc_bug_readdir_efs1 = 0;
12074     }
12075
12076     /* PCP mode requires creating /dev/null special device file */
12077     decc_bug_devnull = 0;
12078     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12079     if ($VMS_STATUS_SUCCESS(status)) {
12080        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12081           decc_bug_devnull = 1;
12082        else
12083           decc_bug_devnull = 0;
12084     }
12085
12086     /* fgetname returning a VMS name in UNIX mode */
12087     decc_bug_fgetname = 1;
12088     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12089     if ($VMS_STATUS_SUCCESS(status)) {
12090       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12091         decc_bug_fgetname = 1;
12092       else
12093         decc_bug_fgetname = 0;
12094     }
12095
12096     /* UNIX directory names with no paths are broken in a lot of places */
12097     decc_dir_barename = 1;
12098     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12099     if ($VMS_STATUS_SUCCESS(status)) {
12100       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12101         decc_dir_barename = 1;
12102       else
12103         decc_dir_barename = 0;
12104     }
12105
12106 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12107     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12108     if (s >= 0) {
12109         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12110         if (decc_disable_to_vms_logname_translation < 0)
12111             decc_disable_to_vms_logname_translation = 0;
12112     }
12113
12114     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12115     if (s >= 0) {
12116         decc_efs_case_preserve = decc$feature_get_value(s, 1);
12117         if (decc_efs_case_preserve < 0)
12118             decc_efs_case_preserve = 0;
12119     }
12120
12121     s = decc$feature_get_index("DECC$EFS_CHARSET");
12122     if (s >= 0) {
12123         decc_efs_charset = decc$feature_get_value(s, 1);
12124         if (decc_efs_charset < 0)
12125             decc_efs_charset = 0;
12126     }
12127
12128     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12129     if (s >= 0) {
12130         decc_filename_unix_report = decc$feature_get_value(s, 1);
12131         if (decc_filename_unix_report > 0)
12132             decc_filename_unix_report = 1;
12133         else
12134             decc_filename_unix_report = 0;
12135     }
12136
12137     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12138     if (s >= 0) {
12139         decc_filename_unix_only = decc$feature_get_value(s, 1);
12140         if (decc_filename_unix_only > 0) {
12141             decc_filename_unix_only = 1;
12142         }
12143         else {
12144             decc_filename_unix_only = 0;
12145         }
12146     }
12147
12148     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12149     if (s >= 0) {
12150         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12151         if (decc_filename_unix_no_version < 0)
12152             decc_filename_unix_no_version = 0;
12153     }
12154
12155     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12156     if (s >= 0) {
12157         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12158         if (decc_readdir_dropdotnotype < 0)
12159             decc_readdir_dropdotnotype = 0;
12160     }
12161
12162     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12163     if ($VMS_STATUS_SUCCESS(status)) {
12164         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12165         if (s >= 0) {
12166             dflt = decc$feature_get_value(s, 4);
12167             if (dflt > 0) {
12168                 decc_disable_posix_root = decc$feature_get_value(s, 1);
12169                 if (decc_disable_posix_root <= 0) {
12170                     decc$feature_set_value(s, 1, 1);
12171                     decc_disable_posix_root = 1;
12172                 }
12173             }
12174             else {
12175                 /* Traditionally Perl assumes this is off */
12176                 decc_disable_posix_root = 1;
12177                 decc$feature_set_value(s, 1, 1);
12178             }
12179         }
12180     }
12181
12182 #if __CRTL_VER >= 80200000
12183     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12184     if (s >= 0) {
12185         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12186         if (decc_posix_compliant_pathnames < 0)
12187             decc_posix_compliant_pathnames = 0;
12188         if (decc_posix_compliant_pathnames > 4)
12189             decc_posix_compliant_pathnames = 0;
12190     }
12191
12192 #endif
12193 #else
12194     status = sys_trnlnm
12195         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12196     if ($VMS_STATUS_SUCCESS(status)) {
12197         val_str[0] = _toupper(val_str[0]);
12198         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12199            decc_disable_to_vms_logname_translation = 1;
12200         }
12201     }
12202
12203 #ifndef __VAX
12204     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12205     if ($VMS_STATUS_SUCCESS(status)) {
12206         val_str[0] = _toupper(val_str[0]);
12207         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12208            decc_efs_case_preserve = 1;
12209         }
12210     }
12211 #endif
12212
12213     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12214     if ($VMS_STATUS_SUCCESS(status)) {
12215         val_str[0] = _toupper(val_str[0]);
12216         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12217            decc_filename_unix_report = 1;
12218         }
12219     }
12220     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12221     if ($VMS_STATUS_SUCCESS(status)) {
12222         val_str[0] = _toupper(val_str[0]);
12223         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12224            decc_filename_unix_only = 1;
12225            decc_filename_unix_report = 1;
12226         }
12227     }
12228     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12229     if ($VMS_STATUS_SUCCESS(status)) {
12230         val_str[0] = _toupper(val_str[0]);
12231         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12232            decc_filename_unix_no_version = 1;
12233         }
12234     }
12235     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12236     if ($VMS_STATUS_SUCCESS(status)) {
12237         val_str[0] = _toupper(val_str[0]);
12238         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12239            decc_readdir_dropdotnotype = 1;
12240         }
12241     }
12242 #endif
12243
12244 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12245
12246      /* Report true case tolerance */
12247     /*----------------------------*/
12248     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12249     if (!$VMS_STATUS_SUCCESS(status))
12250         case_perm = PPROP$K_CASE_BLIND;
12251     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12252     if (!$VMS_STATUS_SUCCESS(status))
12253         case_image = PPROP$K_CASE_BLIND;
12254     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12255         (case_image == PPROP$K_CASE_SENSITIVE))
12256         vms_process_case_tolerant = 0;
12257
12258 #endif
12259
12260
12261     /* CRTL can be initialized past this point, but not before. */
12262 /*    DECC$CRTL_INIT(); */
12263
12264     return SS$_NORMAL;
12265 }
12266
12267 #ifdef __DECC
12268 /* DECC dependent attributes */
12269 #if __DECC_VER < 60560002
12270 #define relative
12271 #define not_executable
12272 #else
12273 #define relative ,rel
12274 #define not_executable ,noexe
12275 #endif
12276 #pragma nostandard
12277 #pragma extern_model save
12278 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12279 #endif
12280         const __align (LONGWORD) int spare[8] = {0};
12281 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
12282 /*                        NOWRT, LONG */
12283 #ifdef __DECC
12284 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
12285         nowrt,noshr relative not_executable
12286 #endif
12287 const long vms_cc_features = (const long)set_features;
12288
12289 /*
12290 ** Force a reference to LIB$INITIALIZE to ensure it
12291 ** exists in the image.
12292 */
12293 int lib$initialize(void);
12294 #ifdef __DECC
12295 #pragma extern_model strict_refdef
12296 #endif
12297     int lib_init_ref = (int) lib$initialize;
12298
12299 #ifdef __DECC
12300 #pragma extern_model restore
12301 #pragma standard
12302 #endif
12303
12304 /*  End of vms.c */