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 <dcdef.h>
  21 #include <descrip.h>
  22 #include <devdef.h>
  23 #include <dvidef.h>
  24 #include <fibdef.h>
  25 #include <float.h>
  26 #include <fscndef.h>
  27 #include <iodef.h>
  28 #include <jpidef.h>
  29 #include <kgbdef.h>
  30 #include <libclidef.h>
  31 #include <libdef.h>
  32 #include <lib$routines.h>
  33 #include <lnmdef.h>
  34 #include <msgdef.h>
  35 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  36 #include <ppropdef.h>
  37 #endif
  38 #include <prvdef.h>
  39 #include <psldef.h>
  40 #include <rms.h>
  41 #include <shrdef.h>
  42 #include <ssdef.h>
  43 #include <starlet.h>
  44 #include <strdef.h>
  45 #include <str$routines.h>
  46 #include <syidef.h>
  47 #include <uaidef.h>
  48 #include <uicdef.h>
  49 #include <stsdef.h>
  50 #include <rmsdef.h>
  51 #include <smgdef.h>
  52 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
  53 #include <efndef.h>
  54 #define NO_EFN EFN$C_ENF
  55 #else
  56 #define NO_EFN 0;
  57 #endif
  58
  59 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  60 int   decc$feature_get_index(const char *name);
  61 char* decc$feature_get_name(int index);
  62 int   decc$feature_get_value(int index, int mode);
  63 int   decc$feature_set_value(int index, int mode, int value);
  64 #else
  65 #include <unixlib.h>
  66 #endif
  67
  68 #pragma member_alignment save
  69 #pragma nomember_alignment longword
  70 struct item_list_3 {
  71         unsigned short len;
  72         unsigned short code;
  73         void * bufadr;
  74         unsigned short * retadr;
  75 };
  76 #pragma member_alignment restore
  77
  78 /* More specific prototype than in starlet_c.h makes programming errors
  79    more visible.
  80  */
  81 #ifdef sys$getdviw
  82 #undef sys$getdviw
  83 int sys$getdviw
  84        (unsigned long efn,
  85         unsigned short chan,
  86         const struct dsc$descriptor_s * devnam,
  87         const struct item_list_3 * itmlst,
  88         void * iosb,
  89         void * (astadr)(unsigned long),
  90         void * astprm,
  91         void * nullarg);
  92 #endif
  93
  94 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  95
  96 static int set_feature_default(const char *name, int value)
  97 {
  98     int status;
  99     int index;
 100
 101     index = decc$feature_get_index(name);
 102
 103     status = decc$feature_set_value(index, 1, value);
 104     if (index == -1 || (status == -1)) {
 105       return -1;
 106     }
 107
 108     status = decc$feature_get_value(index, 1);
 109     if (status != value) {
 110       return -1;
 111     }
 112
 113 return 0;
 114 }
 115 #endif
 116
 117 /* Older versions of ssdef.h don't have these */
 118 #ifndef SS$_INVFILFOROP
 119 #  define SS$_INVFILFOROP 3930
 120 #endif
 121 #ifndef SS$_NOSUCHOBJECT
 122 #  define SS$_NOSUCHOBJECT 2696
 123 #endif
 124
 125 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 126 #define PERLIO_NOT_STDIO 0
 127
 128 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 129  * code below needs to get to the underlying CRTL routines. */
 130 #define DONT_MASK_RTL_CALLS
 131 #include "EXTERN.h"
 132 #include "perl.h"
 133 #include "XSUB.h"
 134 /* Anticipating future expansion in lexical warnings . . . */
 135 #ifndef WARN_INTERNAL
 136 #  define WARN_INTERNAL WARN_MISC
 137 #endif
 138
 139 #ifdef VMS_LONGNAME_SUPPORT
 140 #include <libfildef.h>
 141 #endif
 142
 143 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 144 #  define RTL_USES_UTC 1
 145 #endif
 146
 147 #ifdef USE_VMS_DECTERM
 148
 149 /* Routine to create a decterm for use with the Perl debugger */
 150 /* No headers, this information was found in the Programming Concepts Manual */
 151
 152 int decw$term_port
 153    (const struct dsc$descriptor_s * display,
 154     const struct dsc$descriptor_s * setup_file,
 155     const struct dsc$descriptor_s * customization,
 156     struct dsc$descriptor_s * result_device_name,
 157     unsigned short * result_device_name_length,
 158     void * controller,
 159     void * char_buffer,
 160     void * char_change_buffer);
 161 #endif
 162
 163 /* gcc's header files don't #define direct access macros
 164  * corresponding to VAXC's variant structs */
 165 #ifdef __GNUC__
 166 #  define uic$v_format uic$r_uic_form.uic$v_format
 167 #  define uic$v_group uic$r_uic_form.uic$v_group
 168 #  define uic$v_member uic$r_uic_form.uic$v_member
 169 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 170 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 171 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 172 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 173 #endif
 174
 175 #if defined(NEED_AN_H_ERRNO)
 176 dEXT int h_errno;
 177 #endif
 178
 179 #ifdef __DECC
 180 #pragma message disable pragma
 181 #pragma member_alignment save
 182 #pragma nomember_alignment longword
 183 #pragma message save
 184 #pragma message disable misalgndmem
 185 #endif
 186 struct itmlst_3 {
 187   unsigned short int buflen;
 188   unsigned short int itmcode;
 189   void *bufadr;
 190   unsigned short int *retlen;
 191 };
 192
 193 struct filescan_itmlst_2 {
 194     unsigned short length;
 195     unsigned short itmcode;
 196     char * component;
 197 };
 198
 199 struct vs_str_st {
 200     unsigned short length;
 201     char str[65536];
 202 };
 203
 204 #ifdef __DECC
 205 #pragma message restore
 206 #pragma member_alignment restore
 207 #endif
 208
 209 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 210 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 211 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 212 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 213 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 214 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 215 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 216 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 217 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 218 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 219 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 220
 221 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 222 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 223 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 224 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 225
 226 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 227 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 228
 229 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 230  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 231  * the Perl facility.
 232  */
 233 #define PERL_LNM_MAX_ITER 10
 234
 235   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 236 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 237 #define MAX_DCL_SYMBOL          (8192)
 238 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 239 #else
 240 #define MAX_DCL_SYMBOL          (1024)
 241 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 242 #endif
 243
 244 static char *__mystrtolower(char *str)
 245 {
 246   if (str) for (; *str; ++str) *str= tolower(*str);
 247   return str;
 248 }
 249
 250 static struct dsc$descriptor_s fildevdsc =
 251   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 252 static struct dsc$descriptor_s crtlenvdsc =
 253   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 254 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 255 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 256 static struct dsc$descriptor_s **env_tables = defenv;
 257 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 258
 259 /* True if we shouldn't treat barewords as logicals during directory */
 260 /* munching */
 261 static int no_translate_barewords;
 262
 263 #ifndef RTL_USES_UTC
 264 static int tz_updated = 1;
 265 #endif
 266
 267 /* DECC Features that may need to affect how Perl interprets
 268  * displays filename information
 269  */
 270 static int decc_disable_to_vms_logname_translation = 1;
 271 static int decc_disable_posix_root = 1;
 272 int decc_efs_case_preserve = 0;
 273 static int decc_efs_charset = 0;
 274 static int decc_filename_unix_no_version = 0;
 275 static int decc_filename_unix_only = 0;
 276 int decc_filename_unix_report = 0;
 277 int decc_posix_compliant_pathnames = 0;
 278 int decc_readdir_dropdotnotype = 0;
 279 static int vms_process_case_tolerant = 1;
 280 int vms_vtf7_filenames = 0;
 281 int gnv_unix_shell = 0;
 282
 283 /* bug workarounds if needed */
 284 int decc_bug_readdir_efs1 = 0;
 285 int decc_bug_devnull = 1;
 286 int decc_bug_fgetname = 0;
 287 int decc_dir_barename = 0;
 288
 289 static int vms_debug_on_exception = 0;
 290
 291 /* Is this a UNIX file specification?
 292  *   No longer a simple check with EFS file specs
 293  *   For now, not a full check, but need to
 294  *   handle POSIX ^UP^ specifications
 295  *   Fixing to handle ^/ cases would require
 296  *   changes to many other conversion routines.
 297  */
 298
 299 static int is_unix_filespec(const char *path)
 300 {
 301 int ret_val;
 302 const char * pch1;
 303
 304     ret_val = 0;
 305     if (strncmp(path,"\"^UP^",5) != 0) {
 306         pch1 = strchr(path, '/');
 307         if (pch1 != NULL)
 308             ret_val = 1;
 309         else {
 310
 311             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 312             if (decc_filename_unix_report || decc_filename_unix_only) {
 313             if (strcmp(path,".") == 0)
 314                 ret_val = 1;
 315             }
 316         }
 317     }
 318     return ret_val;
 319 }
 320
 321 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 322  */
 323
 324 static void ucs2_to_vtf7
 325    (char *outspec,
 326     unsigned long ucs2_char,
 327     int * output_cnt)
 328 {
 329 unsigned char * ucs_ptr;
 330 int hex;
 331
 332     ucs_ptr = (unsigned char *)&ucs2_char;
 333
 334     outspec[0] = '^';
 335     outspec[1] = 'U';
 336     hex = (ucs_ptr[1] >> 4) & 0xf;
 337     if (hex < 0xA)
 338         outspec[2] = hex + '0';
 339     else
 340         outspec[2] = (hex - 9) + 'A';
 341     hex = ucs_ptr[1] & 0xF;
 342     if (hex < 0xA)
 343         outspec[3] = hex + '0';
 344     else {
 345         outspec[3] = (hex - 9) + 'A';
 346     }
 347     hex = (ucs_ptr[0] >> 4) & 0xf;
 348     if (hex < 0xA)
 349         outspec[4] = hex + '0';
 350     else
 351         outspec[4] = (hex - 9) + 'A';
 352     hex = ucs_ptr[1] & 0xF;
 353     if (hex < 0xA)
 354         outspec[5] = hex + '0';
 355     else {
 356         outspec[5] = (hex - 9) + 'A';
 357     }
 358     *output_cnt = 6;
 359 }
 360
 361
 362 /* This handles the conversion of a UNIX extended character set to a ^
 363  * escaped VMS character.
 364  * in a UNIX file specification.
 365  *
 366  * The output count variable contains the number of characters added
 367  * to the output string.
 368  *
 369  * The return value is the number of characters read from the input string
 370  */
 371 static int copy_expand_unix_filename_escape
 372   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 373 {
 374 int count;
 375 int scnt;
 376 int utf8_flag;
 377
 378     utf8_flag = 0;
 379     if (utf8_fl)
 380       utf8_flag = *utf8_fl;
 381
 382     count = 0;
 383     *output_cnt = 0;
 384     if (*inspec >= 0x80) {
 385         if (utf8_fl && vms_vtf7_filenames) {
 386         unsigned long ucs_char;
 387
 388             ucs_char = 0;
 389
 390             if ((*inspec & 0xE0) == 0xC0) {
 391                 /* 2 byte Unicode */
 392                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 393                 if (ucs_char >= 0x80) {
 394                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 395                     return 2;
 396                 }
 397             } else if ((*inspec & 0xF0) == 0xE0) {
 398                 /* 3 byte Unicode */
 399                 ucs_char = ((inspec[0] & 0xF) << 12) +
 400                    ((inspec[1] & 0x3f) << 6) +
 401                    (inspec[2] & 0x3f);
 402                 if (ucs_char >= 0x800) {
 403                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 404                     return 3;
 405                 }
 406
 407 #if 0 /* I do not see longer sequences supported by OpenVMS */
 408       /* Maybe some one can fix this later */
 409             } else if ((*inspec & 0xF8) == 0xF0) {
 410                 /* 4 byte Unicode */
 411                 /* UCS-4 to UCS-2 */
 412             } else if ((*inspec & 0xFC) == 0xF8) {
 413                 /* 5 byte Unicode */
 414                 /* UCS-4 to UCS-2 */
 415             } else if ((*inspec & 0xFE) == 0xFC) {
 416                 /* 6 byte Unicode */
 417                 /* UCS-4 to UCS-2 */
 418 #endif
 419             }
 420         }
 421
 422         /* High bit set, but not a unicode character! */
 423
 424         /* Non printing DECMCS or ISO Latin-1 character? */
 425         if (*inspec <= 0x9F) {
 426         int hex;
 427             outspec[0] = '^';
 428             outspec++;
 429             hex = (*inspec >> 4) & 0xF;
 430             if (hex < 0xA)
 431                 outspec[1] = hex + '0';
 432             else {
 433                 outspec[1] = (hex - 9) + 'A';
 434             }
 435             hex = *inspec & 0xF;
 436             if (hex < 0xA)
 437                 outspec[2] = hex + '0';
 438             else {
 439                 outspec[2] = (hex - 9) + 'A';
 440             }
 441             *output_cnt = 3;
 442             return 1;
 443         } else if (*inspec == 0xA0) {
 444             outspec[0] = '^';
 445             outspec[1] = 'A';
 446             outspec[2] = '0';
 447             *output_cnt = 3;
 448             return 1;
 449         } else if (*inspec == 0xFF) {
 450             outspec[0] = '^';
 451             outspec[1] = 'F';
 452             outspec[2] = 'F';
 453             *output_cnt = 3;
 454             return 1;
 455         }
 456         *outspec = *inspec;
 457         *output_cnt = 1;
 458         return 1;
 459     }
 460
 461     /* Is this a macro that needs to be passed through?
 462      * Macros start with $( and an alpha character, followed
 463      * by a string of alpha numeric characters ending with a )
 464      * If this does not match, then encode it as ODS-5.
 465      */
 466     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 467     int tcnt;
 468
 469         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 470             tcnt = 3;
 471             outspec[0] = inspec[0];
 472             outspec[1] = inspec[1];
 473             outspec[2] = inspec[2];
 474
 475             while(isalnum(inspec[tcnt]) ||
 476                   (inspec[2] == '.') || (inspec[2] == '_')) {
 477                 outspec[tcnt] = inspec[tcnt];
 478                 tcnt++;
 479             }
 480             if (inspec[tcnt] == ')') {
 481                 outspec[tcnt] = inspec[tcnt];
 482                 tcnt++;
 483                 *output_cnt = tcnt;
 484                 return tcnt;
 485             }
 486         }
 487     }
 488
 489     switch (*inspec) {
 490     case 0x7f:
 491         outspec[0] = '^';
 492         outspec[1] = '7';
 493         outspec[2] = 'F';
 494         *output_cnt = 3;
 495         return 1;
 496         break;
 497     case '?':
 498         if (decc_efs_charset == 0)
 499           outspec[0] = '%';
 500         else
 501           outspec[0] = '?';
 502         *output_cnt = 1;
 503         return 1;
 504         break;
 505     case '.':
 506     case '~':
 507     case '!':
 508     case '#':
 509     case '&':
 510     case '\'':
 511     case '`':
 512     case '(':
 513     case ')':
 514     case '+':
 515     case '@':
 516     case '{':
 517     case '}':
 518     case ',':
 519     case ';':
 520     case '[':
 521     case ']':
 522     case '%':
 523     case '^':
 524     case '=':
 525         /* Assume that this is to be escaped */
 526         outspec[0] = '^';
 527         outspec[1] = *inspec;
 528         *output_cnt = 2;
 529         return 1;
 530         break;
 531     case ' ': /* space */
 532         /* Assume that this is to be escaped */
 533         outspec[0] = '^';
 534         outspec[1] = '_';
 535         *output_cnt = 2;
 536         return 1;
 537         break;
 538     default:
 539         *outspec = *inspec;
 540         *output_cnt = 1;
 541         return 1;
 542         break;
 543     }
 544 }
 545
 546
 547 /* This handles the expansion of a '^' prefix to the proper character
 548  * in a UNIX file specification.
 549  *
 550  * The output count variable contains the number of characters added
 551  * to the output string.
 552  *
 553  * The return value is the number of characters read from the input
 554  * string
 555  */
 556 static int copy_expand_vms_filename_escape
 557   (char *outspec, const char *inspec, int *output_cnt)
 558 {
 559 int count;
 560 int scnt;
 561
 562     count = 0;
 563     *output_cnt = 0;
 564     if (*inspec == '^') {
 565         inspec++;
 566         switch (*inspec) {
 567         case '.':
 568             /* Non trailing dots should just be passed through, but eat the escape */
 569             *outspec = *inspec;
 570             count++;
 571             break;
 572         case '_': /* space */
 573             *outspec = ' ';
 574             inspec++;
 575             count++;
 576             (*output_cnt)++;
 577             break;
 578         case 'U': /* Unicode - FIX-ME this is wrong. */
 579             inspec++;
 580             count++;
 581             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 582             if (scnt == 4) {
 583                 unsigned int c1, c2;
 584                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 585                 outspec[0] == c1 & 0xff;
 586                 outspec[1] == c2 & 0xff;
 587                 if (scnt > 1) {
 588                     (*output_cnt) += 2;
 589                     count += 4;
 590                 }
 591             }
 592             else {
 593                 /* Error - do best we can to continue */
 594                 *outspec = 'U';
 595                 outspec++;
 596                 (*output_cnt++);
 597                 *outspec = *inspec;
 598                 count++;
 599                 (*output_cnt++);
 600             }
 601             break;
 602         default:
 603             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 604             if (scnt == 2) {
 605                 /* Hex encoded */
 606                 unsigned int c1;
 607                 scnt = sscanf(inspec, "%2x", &c1);
 608                 outspec[0] = c1 & 0xff;
 609                 if (scnt > 0) {
 610                     (*output_cnt++);
 611                     count += 2;
 612                 }
 613             }
 614             else {
 615                 *outspec = *inspec;
 616                 count++;
 617                 (*output_cnt++);
 618             }
 619         }
 620     }
 621     else {
 622         *outspec = *inspec;
 623         count++;
 624         (*output_cnt)++;
 625     }
 626     return count;
 627 }
 628
 629 #ifdef sys$filescan
 630 #undef sys$filescan
 631 int sys$filescan
 632    (const struct dsc$descriptor_s * srcstr,
 633     struct filescan_itmlst_2 * valuelist,
 634     unsigned long * fldflags,
 635     struct dsc$descriptor_s *auxout,
 636     unsigned short * retlen);
 637 #endif
 638
 639 /* vms_split_path - Verify that the input file specification is a
 640  * VMS format file specification, and provide pointers to the components of
 641  * it.  With EFS format filenames, this is virtually the only way to
 642  * parse a VMS path specification into components.
 643  *
 644  * If the sum of the components do not add up to the length of the
 645  * string, then the passed file specification is probably a UNIX style
 646  * path.
 647  */
 648 static int vms_split_path
 649    (const char * path,
 650     char * * volume,
 651     int * vol_len,
 652     char * * root,
 653     int * root_len,
 654     char * * dir,
 655     int * dir_len,
 656     char * * name,
 657     int * name_len,
 658     char * * ext,
 659     int * ext_len,
 660     char * * version,
 661     int * ver_len)
 662 {
 663 struct dsc$descriptor path_desc;
 664 int status;
 665 unsigned long flags;
 666 int ret_stat;
 667 struct filescan_itmlst_2 item_list[9];
 668 const int filespec = 0;
 669 const int nodespec = 1;
 670 const int devspec = 2;
 671 const int rootspec = 3;
 672 const int dirspec = 4;
 673 const int namespec = 5;
 674 const int typespec = 6;
 675 const int verspec = 7;
 676
 677     /* Assume the worst for an easy exit */
 678     ret_stat = -1;
 679     *volume = NULL;
 680     *vol_len = 0;
 681     *root = NULL;
 682     *root_len = 0;
 683     *dir = NULL;
 684     *dir_len;
 685     *name = NULL;
 686     *name_len = 0;
 687     *ext = NULL;
 688     *ext_len = 0;
 689     *version = NULL;
 690     *ver_len = 0;
 691
 692     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 693     path_desc.dsc$w_length = strlen(path);
 694     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 695     path_desc.dsc$b_class = DSC$K_CLASS_S;
 696
 697     /* Get the total length, if it is shorter than the string passed
 698      * then this was probably not a VMS formatted file specification
 699      */
 700     item_list[filespec].itmcode = FSCN$_FILESPEC;
 701     item_list[filespec].length = 0;
 702     item_list[filespec].component = NULL;
 703
 704     /* If the node is present, then it gets considered as part of the
 705      * volume name to hopefully make things simple.
 706      */
 707     item_list[nodespec].itmcode = FSCN$_NODE;
 708     item_list[nodespec].length = 0;
 709     item_list[nodespec].component = NULL;
 710
 711     item_list[devspec].itmcode = FSCN$_DEVICE;
 712     item_list[devspec].length = 0;
 713     item_list[devspec].component = NULL;
 714
 715     /* root is a special case,  adding it to either the directory or
 716      * the device components will probalby complicate things for the
 717      * callers of this routine, so leave it separate.
 718      */
 719     item_list[rootspec].itmcode = FSCN$_ROOT;
 720     item_list[rootspec].length = 0;
 721     item_list[rootspec].component = NULL;
 722
 723     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 724     item_list[dirspec].length = 0;
 725     item_list[dirspec].component = NULL;
 726
 727     item_list[namespec].itmcode = FSCN$_NAME;
 728     item_list[namespec].length = 0;
 729     item_list[namespec].component = NULL;
 730
 731     item_list[typespec].itmcode = FSCN$_TYPE;
 732     item_list[typespec].length = 0;
 733     item_list[typespec].component = NULL;
 734
 735     item_list[verspec].itmcode = FSCN$_VERSION;
 736     item_list[verspec].length = 0;
 737     item_list[verspec].component = NULL;
 738
 739     item_list[8].itmcode = 0;
 740     item_list[8].length = 0;
 741     item_list[8].component = NULL;
 742
 743     status = sys$filescan
 744        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 745         &flags, NULL, NULL);
 746     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 747
 748     /* If we parsed it successfully these two lengths should be the same */
 749     if (path_desc.dsc$w_length != item_list[filespec].length)
 750         return ret_stat;
 751
 752     /* If we got here, then it is a VMS file specification */
 753     ret_stat = 0;
 754
 755     /* set the volume name */
 756     if (item_list[nodespec].length > 0) {
 757         *volume = item_list[nodespec].component;
 758         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 759     }
 760     else {
 761         *volume = item_list[devspec].component;
 762         *vol_len = item_list[devspec].length;
 763     }
 764
 765     *root = item_list[rootspec].component;
 766     *root_len = item_list[rootspec].length;
 767
 768     *dir = item_list[dirspec].component;
 769     *dir_len = item_list[dirspec].length;
 770
 771     /* Now fun with versions and EFS file specifications
 772      * The parser can not tell the difference when a "." is a version
 773      * delimiter or a part of the file specification.
 774      */
 775     if ((decc_efs_charset) &&
 776         (item_list[verspec].length > 0) &&
 777         (item_list[verspec].component[0] == '.')) {
 778         *name = item_list[namespec].component;
 779         *name_len = item_list[namespec].length + item_list[typespec].length;
 780         *ext = item_list[verspec].component;
 781         *ext_len = item_list[verspec].length;
 782         *version = NULL;
 783         *ver_len = 0;
 784     }
 785     else {
 786         *name = item_list[namespec].component;
 787         *name_len = item_list[namespec].length;
 788         *ext = item_list[typespec].component;
 789         *ext_len = item_list[typespec].length;
 790         *version = item_list[verspec].component;
 791         *ver_len = item_list[verspec].length;
 792     }
 793     return ret_stat;
 794 }
 795
 796
 797 /* my_maxidx
 798  * Routine to retrieve the maximum equivalence index for an input
 799  * logical name.  Some calls to this routine have no knowledge if
 800  * the variable is a logical or not.  So on error we return a max
 801  * index of zero.
 802  */
 803 /*{{{int my_maxidx(const char *lnm) */
 804 static int
 805 my_maxidx(const char *lnm)
 806 {
 807     int status;
 808     int midx;
 809     int attr = LNM$M_CASE_BLIND;
 810     struct dsc$descriptor lnmdsc;
 811     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 812                                 {0, 0, 0, 0}};
 813
 814     lnmdsc.dsc$w_length = strlen(lnm);
 815     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 816     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 817     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 818
 819     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 820     if ((status & 1) == 0)
 821        midx = 0;
 822
 823     return (midx);
 824 }
 825 /*}}}*/
 826
 827 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 828 int
 829 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 830   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 831 {
 832     const char *cp1;
 833     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 834     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 835     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 836     int midx;
 837     unsigned char acmode;
 838     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 839                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 840     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 841                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 842                                  {0, 0, 0, 0}};
 843     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 844 #if defined(PERL_IMPLICIT_CONTEXT)
 845     pTHX = NULL;
 846     if (PL_curinterp) {
 847       aTHX = PERL_GET_INTERP;
 848     } else {
 849       aTHX = NULL;
 850     }
 851 #endif
 852
 853     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 854       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 855     }
 856     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 857       *cp2 = _toupper(*cp1);
 858       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 859         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 860         return 0;
 861       }
 862     }
 863     lnmdsc.dsc$w_length = cp1 - lnm;
 864     lnmdsc.dsc$a_pointer = uplnm;
 865     uplnm[lnmdsc.dsc$w_length] = '\0';
 866     secure = flags & PERL__TRNENV_SECURE;
 867     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 868     if (!tabvec || !*tabvec) tabvec = env_tables;
 869
 870     for (curtab = 0; tabvec[curtab]; curtab++) {
 871       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 872         if (!ivenv && !secure) {
 873           char *eq, *end;
 874           int i;
 875           if (!environ) {
 876             ivenv = 1;
 877             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 878             continue;
 879           }
 880           retsts = SS$_NOLOGNAM;
 881           for (i = 0; environ[i]; i++) {
 882             if ((eq = strchr(environ[i],'=')) &&
 883                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 884                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 885               eq++;
 886               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 887               if (!eqvlen) continue;
 888               retsts = SS$_NORMAL;
 889               break;
 890             }
 891           }
 892           if (retsts != SS$_NOLOGNAM) break;
 893         }
 894       }
 895       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 896                !str$case_blind_compare(&tmpdsc,&clisym)) {
 897         if (!ivsym && !secure) {
 898           unsigned short int deflen = LNM$C_NAMLENGTH;
 899           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 900           /* dynamic dsc to accomodate possible long value */
 901           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 902           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 903           if (retsts & 1) {
 904             if (eqvlen > MAX_DCL_SYMBOL) {
 905               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 906               eqvlen = MAX_DCL_SYMBOL;
 907               /* Special hack--we might be called before the interpreter's */
 908               /* fully initialized, in which case either thr or PL_curcop */
 909               /* might be bogus. We have to check, since ckWARN needs them */
 910               /* both to be valid if running threaded */
 911                 if (ckWARN(WARN_MISC)) {
 912                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 913                 }
 914             }
 915             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 916           }
 917           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 918           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 919           if (retsts == LIB$_NOSUCHSYM) continue;
 920           break;
 921         }
 922       }
 923       else if (!ivlnm) {
 924         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 925           midx = my_maxidx(lnm);
 926           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 927             lnmlst[1].bufadr = cp2;
 928             eqvlen = 0;
 929             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 930             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 931             if (retsts == SS$_NOLOGNAM) break;
 932             /* PPFs have a prefix */
 933             if (
 934 #if INTSIZE == 4
 935                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 936 #endif
 937                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 938                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 939                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 940                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 941                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 942               memmove(eqv,eqv+4,eqvlen-4);
 943               eqvlen -= 4;
 944             }
 945             cp2 += eqvlen;
 946             *cp2 = '\0';
 947           }
 948           if ((retsts == SS$_IVLOGNAM) ||
 949               (retsts == SS$_NOLOGNAM)) { continue; }
 950         }
 951         else {
 952           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 953           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 954           if (retsts == SS$_NOLOGNAM) continue;
 955           eqv[eqvlen] = '\0';
 956         }
 957         eqvlen = strlen(eqv);
 958         break;
 959       }
 960     }
 961     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 962     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 963              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 964              retsts == SS$_NOLOGNAM) {
 965       set_errno(EINVAL);  set_vaxc_errno(retsts);
 966     }
 967     else _ckvmssts(retsts);
 968     return 0;
 969 }  /* end of vmstrnenv */
 970 /*}}}*/
 971
 972 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 973 /* Define as a function so we can access statics. */
 974 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 975 {
 976   return vmstrnenv(lnm,eqv,idx,fildev,
 977 #ifdef SECURE_INTERNAL_GETENV
 978                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 979 #else
 980                    0
 981 #endif
 982                                                                               );
 983 }
 984 /*}}}*/
 985
 986 /* my_getenv
 987  * Note: Uses Perl temp to store result so char * can be returned to
 988  * caller; this pointer will be invalidated at next Perl statement
 989  * transition.
 990  * We define this as a function rather than a macro in terms of my_getenv_len()
 991  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 992  * allocate SVs).
 993  */
 994 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 995 char *
 996 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 997 {
 998     const char *cp1;
 999     static char *__my_getenv_eqv = NULL;
1000     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1001     unsigned long int idx = 0;
1002     int trnsuccess, success, secure, saverr, savvmserr;
1003     int midx, flags;
1004     SV *tmpsv;
1005
1006     midx = my_maxidx(lnm) + 1;
1007
1008     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1009       /* Set up a temporary buffer for the return value; Perl will
1010        * clean it up at the next statement transition */
1011       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1012       if (!tmpsv) return NULL;
1013       eqv = SvPVX(tmpsv);
1014     }
1015     else {
1016       /* Assume no interpreter ==> single thread */
1017       if (__my_getenv_eqv != NULL) {
1018         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1019       }
1020       else {
1021         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1022       }
1023       eqv = __my_getenv_eqv;
1024     }
1025
1026     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1027     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1028       int len;
1029       getcwd(eqv,LNM$C_NAMLENGTH);
1030
1031       len = strlen(eqv);
1032
1033       /* Get rid of "000000/ in rooted filespecs */
1034       if (len > 7) {
1035         char * zeros;
1036         zeros = strstr(eqv, "/000000/");
1037         if (zeros != NULL) {
1038           int mlen;
1039           mlen = len - (zeros - eqv) - 7;
1040           memmove(zeros, &zeros[7], mlen);
1041           len = len - 7;
1042           eqv[len] = '\0';
1043         }
1044       }
1045       return eqv;
1046     }
1047     else {
1048       /* Impose security constraints only if tainting */
1049       if (sys) {
1050         /* Impose security constraints only if tainting */
1051         secure = PL_curinterp ? PL_tainting : will_taint;
1052         saverr = errno;  savvmserr = vaxc$errno;
1053       }
1054       else {
1055         secure = 0;
1056       }
1057
1058       flags =
1059 #ifdef SECURE_INTERNAL_GETENV
1060               secure ? PERL__TRNENV_SECURE : 0
1061 #else
1062               0
1063 #endif
1064       ;
1065
1066       /* For the getenv interface we combine all the equivalence names
1067        * of a search list logical into one value to acquire a maximum
1068        * value length of 255*128 (assuming %ENV is using logicals).
1069        */
1070       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1071
1072       /* If the name contains a semicolon-delimited index, parse it
1073        * off and make sure we only retrieve the equivalence name for
1074        * that index.  */
1075       if ((cp2 = strchr(lnm,';')) != NULL) {
1076         strcpy(uplnm,lnm);
1077         uplnm[cp2-lnm] = '\0';
1078         idx = strtoul(cp2+1,NULL,0);
1079         lnm = uplnm;
1080         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1081       }
1082
1083       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1084
1085       /* Discard NOLOGNAM on internal calls since we're often looking
1086        * for an optional name, and this "error" often shows up as the
1087        * (bogus) exit status for a die() call later on.  */
1088       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1089       return success ? eqv : Nullch;
1090     }
1091
1092 }  /* end of my_getenv() */
1093 /*}}}*/
1094
1095
1096 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1097 char *
1098 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1099 {
1100     const char *cp1;
1101     char *buf, *cp2;
1102     unsigned long idx = 0;
1103     int midx, flags;
1104     static char *__my_getenv_len_eqv = NULL;
1105     int secure, saverr, savvmserr;
1106     SV *tmpsv;
1107
1108     midx = my_maxidx(lnm) + 1;
1109
1110     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1111       /* Set up a temporary buffer for the return value; Perl will
1112        * clean it up at the next statement transition */
1113       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1114       if (!tmpsv) return NULL;
1115       buf = SvPVX(tmpsv);
1116     }
1117     else {
1118       /* Assume no interpreter ==> single thread */
1119       if (__my_getenv_len_eqv != NULL) {
1120         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1121       }
1122       else {
1123         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1124       }
1125       buf = __my_getenv_len_eqv;
1126     }
1127
1128     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1129     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1130     char * zeros;
1131
1132       getcwd(buf,LNM$C_NAMLENGTH);
1133       *len = strlen(buf);
1134
1135       /* Get rid of "000000/ in rooted filespecs */
1136       if (*len > 7) {
1137       zeros = strstr(buf, "/000000/");
1138       if (zeros != NULL) {
1139         int mlen;
1140         mlen = *len - (zeros - buf) - 7;
1141         memmove(zeros, &zeros[7], mlen);
1142         *len = *len - 7;
1143         buf[*len] = '\0';
1144         }
1145       }
1146       return buf;
1147     }
1148     else {
1149       if (sys) {
1150         /* Impose security constraints only if tainting */
1151         secure = PL_curinterp ? PL_tainting : will_taint;
1152         saverr = errno;  savvmserr = vaxc$errno;
1153       }
1154       else {
1155         secure = 0;
1156       }
1157
1158       flags =
1159 #ifdef SECURE_INTERNAL_GETENV
1160               secure ? PERL__TRNENV_SECURE : 0
1161 #else
1162               0
1163 #endif
1164       ;
1165
1166       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1167
1168       if ((cp2 = strchr(lnm,';')) != NULL) {
1169         strcpy(buf,lnm);
1170         buf[cp2-lnm] = '\0';
1171         idx = strtoul(cp2+1,NULL,0);
1172         lnm = buf;
1173         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1174       }
1175
1176       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1177
1178       /* Get rid of "000000/ in rooted filespecs */
1179       if (*len > 7) {
1180       char * zeros;
1181         zeros = strstr(buf, "/000000/");
1182         if (zeros != NULL) {
1183           int mlen;
1184           mlen = *len - (zeros - buf) - 7;
1185           memmove(zeros, &zeros[7], mlen);
1186           *len = *len - 7;
1187           buf[*len] = '\0';
1188         }
1189       }
1190
1191       /* Discard NOLOGNAM on internal calls since we're often looking
1192        * for an optional name, and this "error" often shows up as the
1193        * (bogus) exit status for a die() call later on.  */
1194       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1195       return *len ? buf : Nullch;
1196     }
1197
1198 }  /* end of my_getenv_len() */
1199 /*}}}*/
1200
1201 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1202
1203 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1204
1205 /*{{{ void prime_env_iter() */
1206 void
1207 prime_env_iter(void)
1208 /* Fill the %ENV associative array with all logical names we can
1209  * find, in preparation for iterating over it.
1210  */
1211 {
1212   static int primed = 0;
1213   HV *seenhv = NULL, *envhv;
1214   SV *sv = NULL;
1215   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1216   unsigned short int chan;
1217 #ifndef CLI$M_TRUSTED
1218 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1219 #endif
1220   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1221   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1222   long int i;
1223   bool have_sym = FALSE, have_lnm = FALSE;
1224   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1225   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1226   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1227   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1228   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1229 #if defined(PERL_IMPLICIT_CONTEXT)
1230   pTHX;
1231 #endif
1232 #if defined(USE_ITHREADS)
1233   static perl_mutex primenv_mutex;
1234   MUTEX_INIT(&primenv_mutex);
1235 #endif
1236
1237 #if defined(PERL_IMPLICIT_CONTEXT)
1238     /* We jump through these hoops because we can be called at */
1239     /* platform-specific initialization time, which is before anything is */
1240     /* set up--we can't even do a plain dTHX since that relies on the */
1241     /* interpreter structure to be initialized */
1242     if (PL_curinterp) {
1243       aTHX = PERL_GET_INTERP;
1244     } else {
1245       aTHX = NULL;
1246     }
1247 #endif
1248
1249   if (primed || !PL_envgv) return;
1250   MUTEX_LOCK(&primenv_mutex);
1251   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1252   envhv = GvHVn(PL_envgv);
1253   /* Perform a dummy fetch as an lval to insure that the hash table is
1254    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1255   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1256
1257   for (i = 0; env_tables[i]; i++) {
1258      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1259          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1260      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1261   }
1262   if (have_sym || have_lnm) {
1263     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1264     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1265     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1266     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1267   }
1268
1269   for (i--; i >= 0; i--) {
1270     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1271       char *start;
1272       int j;
1273       for (j = 0; environ[j]; j++) {
1274         if (!(start = strchr(environ[j],'='))) {
1275           if (ckWARN(WARN_INTERNAL))
1276             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1277         }
1278         else {
1279           start++;
1280           sv = newSVpv(start,0);
1281           SvTAINTED_on(sv);
1282           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1283         }
1284       }
1285       continue;
1286     }
1287     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1288              !str$case_blind_compare(&tmpdsc,&clisym)) {
1289       strcpy(cmd,"Show Symbol/Global *");
1290       cmddsc.dsc$w_length = 20;
1291       if (env_tables[i]->dsc$w_length == 12 &&
1292           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1293           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1294       flags = defflags | CLI$M_NOLOGNAM;
1295     }
1296     else {
1297       strcpy(cmd,"Show Logical *");
1298       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1299         strcat(cmd," /Table=");
1300         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1301         cmddsc.dsc$w_length = strlen(cmd);
1302       }
1303       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1304       flags = defflags | CLI$M_NOCLISYM;
1305     }
1306
1307     /* Create a new subprocess to execute each command, to exclude the
1308      * remote possibility that someone could subvert a mbx or file used
1309      * to write multiple commands to a single subprocess.
1310      */
1311     do {
1312       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1313                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1314       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1315       defflags &= ~CLI$M_TRUSTED;
1316     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1317     _ckvmssts(retsts);
1318     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1319     if (seenhv) SvREFCNT_dec(seenhv);
1320     seenhv = newHV();
1321     while (1) {
1322       char *cp1, *cp2, *key;
1323       unsigned long int sts, iosb[2], retlen, keylen;
1324       register U32 hash;
1325
1326       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1327       if (sts & 1) sts = iosb[0] & 0xffff;
1328       if (sts == SS$_ENDOFFILE) {
1329         int wakect = 0;
1330         while (substs == 0) { sys$hiber(); wakect++;}
1331         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1332         _ckvmssts(substs);
1333         break;
1334       }
1335       _ckvmssts(sts);
1336       retlen = iosb[0] >> 16;
1337       if (!retlen) continue;  /* blank line */
1338       buf[retlen] = '\0';
1339       if (iosb[1] != subpid) {
1340         if (iosb[1]) {
1341           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1342         }
1343         continue;
1344       }
1345       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1346         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1347
1348       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1349       if (*cp1 == '(' || /* Logical name table name */
1350           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1351       if (*cp1 == '"') cp1++;
1352       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1353       key = cp1;  keylen = cp2 - cp1;
1354       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1355       while (*cp2 && *cp2 != '=') cp2++;
1356       while (*cp2 && *cp2 == '=') cp2++;
1357       while (*cp2 && *cp2 == ' ') cp2++;
1358       if (*cp2 == '"') {  /* String translation; may embed "" */
1359         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1360         cp2++;  cp1--; /* Skip "" surrounding translation */
1361       }
1362       else {  /* Numeric translation */
1363         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1364         cp1--;  /* stop on last non-space char */
1365       }
1366       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1367         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1368         continue;
1369       }
1370       PERL_HASH(hash,key,keylen);
1371
1372       if (cp1 == cp2 && *cp2 == '.') {
1373         /* A single dot usually means an unprintable character, such as a null
1374          * to indicate a zero-length value.  Get the actual value to make sure.
1375          */
1376         char lnm[LNM$C_NAMLENGTH+1];
1377         char eqv[MAX_DCL_SYMBOL+1];
1378         int trnlen;
1379         strncpy(lnm, key, keylen);
1380         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1381         sv = newSVpvn(eqv, strlen(eqv));
1382       }
1383       else {
1384         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1385       }
1386
1387       SvTAINTED_on(sv);
1388       hv_store(envhv,key,keylen,sv,hash);
1389       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1390     }
1391     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1392       /* get the PPFs for this process, not the subprocess */
1393       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1394       char eqv[LNM$C_NAMLENGTH+1];
1395       int trnlen, i;
1396       for (i = 0; ppfs[i]; i++) {
1397         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1398         sv = newSVpv(eqv,trnlen);
1399         SvTAINTED_on(sv);
1400         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1401       }
1402     }
1403   }
1404   primed = 1;
1405   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1406   if (buf) Safefree(buf);
1407   if (seenhv) SvREFCNT_dec(seenhv);
1408   MUTEX_UNLOCK(&primenv_mutex);
1409   return;
1410
1411 }  /* end of prime_env_iter */
1412 /*}}}*/
1413
1414
1415 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1416 /* Define or delete an element in the same "environment" as
1417  * vmstrnenv().  If an element is to be deleted, it's removed from
1418  * the first place it's found.  If it's to be set, it's set in the
1419  * place designated by the first element of the table vector.
1420  * Like setenv() returns 0 for success, non-zero on error.
1421  */
1422 int
1423 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1424 {
1425     const char *cp1;
1426     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1427     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1428     int nseg = 0, j;
1429     unsigned long int retsts, usermode = PSL$C_USER;
1430     struct itmlst_3 *ile, *ilist;
1431     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1432                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1433                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1434     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1435     $DESCRIPTOR(local,"_LOCAL");
1436
1437     if (!lnm) {
1438         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1439         return SS$_IVLOGNAM;
1440     }
1441
1442     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1443       *cp2 = _toupper(*cp1);
1444       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1445         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1446         return SS$_IVLOGNAM;
1447       }
1448     }
1449     lnmdsc.dsc$w_length = cp1 - lnm;
1450     if (!tabvec || !*tabvec) tabvec = env_tables;
1451
1452     if (!eqv) {  /* we're deleting n element */
1453       for (curtab = 0; tabvec[curtab]; curtab++) {
1454         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1455         int i;
1456           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1457             if ((cp1 = strchr(environ[i],'=')) &&
1458                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1459                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1460 #ifdef HAS_SETENV
1461               return setenv(lnm,"",1) ? vaxc$errno : 0;
1462             }
1463           }
1464           ivenv = 1; retsts = SS$_NOLOGNAM;
1465 #else
1466               if (ckWARN(WARN_INTERNAL))
1467                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1468               ivenv = 1; retsts = SS$_NOSUCHPGM;
1469               break;
1470             }
1471           }
1472 #endif
1473         }
1474         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1475                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1476           unsigned int symtype;
1477           if (tabvec[curtab]->dsc$w_length == 12 &&
1478               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1479               !str$case_blind_compare(&tmpdsc,&local))
1480             symtype = LIB$K_CLI_LOCAL_SYM;
1481           else symtype = LIB$K_CLI_GLOBAL_SYM;
1482           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1483           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1484           if (retsts == LIB$_NOSUCHSYM) continue;
1485           break;
1486         }
1487         else if (!ivlnm) {
1488           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1489           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1490           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1491           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1492           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1493         }
1494       }
1495     }
1496     else {  /* we're defining a value */
1497       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1498 #ifdef HAS_SETENV
1499         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1500 #else
1501         if (ckWARN(WARN_INTERNAL))
1502           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1503         retsts = SS$_NOSUCHPGM;
1504 #endif
1505       }
1506       else {
1507         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1508         eqvdsc.dsc$w_length  = strlen(eqv);
1509         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1510             !str$case_blind_compare(&tmpdsc,&clisym)) {
1511           unsigned int symtype;
1512           if (tabvec[0]->dsc$w_length == 12 &&
1513               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1514                !str$case_blind_compare(&tmpdsc,&local))
1515             symtype = LIB$K_CLI_LOCAL_SYM;
1516           else symtype = LIB$K_CLI_GLOBAL_SYM;
1517           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1518         }
1519         else {
1520           if (!*eqv) eqvdsc.dsc$w_length = 1;
1521           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1522
1523             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1524             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1525               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1526                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1527               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1528               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1529             }
1530
1531             Newx(ilist,nseg+1,struct itmlst_3);
1532             ile = ilist;
1533             if (!ile) {
1534               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1535               return SS$_INSFMEM;
1536             }
1537             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1538
1539             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1540               ile->itmcode = LNM$_STRING;
1541               ile->bufadr = c;
1542               if ((j+1) == nseg) {
1543                 ile->buflen = strlen(c);
1544                 /* in case we are truncating one that's too long */
1545                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1546               }
1547               else {
1548                 ile->buflen = LNM$C_NAMLENGTH;
1549               }
1550             }
1551
1552             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1553             Safefree (ilist);
1554           }
1555           else {
1556             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1557           }
1558         }
1559       }
1560     }
1561     if (!(retsts & 1)) {
1562       switch (retsts) {
1563         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1564         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1565           set_errno(EVMSERR); break;
1566         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1567         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1568           set_errno(EINVAL); break;
1569         case SS$_NOPRIV:
1570           set_errno(EACCES); break;
1571         default:
1572           _ckvmssts(retsts);
1573           set_errno(EVMSERR);
1574        }
1575        set_vaxc_errno(retsts);
1576        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1577     }
1578     else {
1579       /* We reset error values on success because Perl does an hv_fetch()
1580        * before each hv_store(), and if the thing we're setting didn't
1581        * previously exist, we've got a leftover error message.  (Of course,
1582        * this fails in the face of
1583        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1584        * in that the error reported in $! isn't spurious,
1585        * but it's right more often than not.)
1586        */
1587       set_errno(0); set_vaxc_errno(retsts);
1588       return 0;
1589     }
1590
1591 }  /* end of vmssetenv() */
1592 /*}}}*/
1593
1594 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1595 /* This has to be a function since there's a prototype for it in proto.h */
1596 void
1597 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1598 {
1599     if (lnm && *lnm) {
1600       int len = strlen(lnm);
1601       if  (len == 7) {
1602         char uplnm[8];
1603         int i;
1604         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1605         if (!strcmp(uplnm,"DEFAULT")) {
1606           if (eqv && *eqv) my_chdir(eqv);
1607           return;
1608         }
1609     }
1610 #ifndef RTL_USES_UTC
1611     if (len == 6 || len == 2) {
1612       char uplnm[7];
1613       int i;
1614       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1615       uplnm[len] = '\0';
1616       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1617       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1618     }
1619 #endif
1620   }
1621   (void) vmssetenv(lnm,eqv,NULL);
1622 }
1623 /*}}}*/
1624
1625 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1626 /*  vmssetuserlnm
1627  *  sets a user-mode logical in the process logical name table
1628  *  used for redirection of sys$error
1629  */
1630 void
1631 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1632 {
1633     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1634     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1635     unsigned long int iss, attr = LNM$M_CONFINE;
1636     unsigned char acmode = PSL$C_USER;
1637     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1638                                  {0, 0, 0, 0}};
1639     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1640     d_name.dsc$w_length = strlen(name);
1641
1642     lnmlst[0].buflen = strlen(eqv);
1643     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1644
1645     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1646     if (!(iss&1)) lib$signal(iss);
1647 }
1648 /*}}}*/
1649
1650
1651 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1652 /* my_crypt - VMS password hashing
1653  * my_crypt() provides an interface compatible with the Unix crypt()
1654  * C library function, and uses sys$hash_password() to perform VMS
1655  * password hashing.  The quadword hashed password value is returned
1656  * as a NUL-terminated 8 character string.  my_crypt() does not change
1657  * the case of its string arguments; in order to match the behavior
1658  * of LOGINOUT et al., alphabetic characters in both arguments must
1659  *  be upcased by the caller.
1660  *
1661  * - fix me to call ACM services when available
1662  */
1663 char *
1664 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1665 {
1666 #   ifndef UAI$C_PREFERRED_ALGORITHM
1667 #     define UAI$C_PREFERRED_ALGORITHM 127
1668 #   endif
1669     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1670     unsigned short int salt = 0;
1671     unsigned long int sts;
1672     struct const_dsc {
1673         unsigned short int dsc$w_length;
1674         unsigned char      dsc$b_type;
1675         unsigned char      dsc$b_class;
1676         const char *       dsc$a_pointer;
1677     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1678        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1679     struct itmlst_3 uailst[3] = {
1680         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1681         { sizeof salt, UAI$_SALT,    &salt, 0},
1682         { 0,           0,            NULL,  NULL}};
1683     static char hash[9];
1684
1685     usrdsc.dsc$w_length = strlen(usrname);
1686     usrdsc.dsc$a_pointer = usrname;
1687     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1688       switch (sts) {
1689         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1690           set_errno(EACCES);
1691           break;
1692         case RMS$_RNF:
1693           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1694           break;
1695         default:
1696           set_errno(EVMSERR);
1697       }
1698       set_vaxc_errno(sts);
1699       if (sts != RMS$_RNF) return NULL;
1700     }
1701
1702     txtdsc.dsc$w_length = strlen(textpasswd);
1703     txtdsc.dsc$a_pointer = textpasswd;
1704     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1705       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1706     }
1707
1708     return (char *) hash;
1709
1710 }  /* end of my_crypt() */
1711 /*}}}*/
1712
1713
1714 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1715 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1716 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1717
1718 /* fixup barenames that are directories for internal use.
1719  * There have been problems with the consistent handling of UNIX
1720  * style directory names when routines are presented with a name that
1721  * has no directory delimitors at all.  So this routine will eventually
1722  * fix the issue.
1723  */
1724 static char * fixup_bare_dirnames(const char * name)
1725 {
1726   if (decc_disable_to_vms_logname_translation) {
1727 /* fix me */
1728   }
1729   return NULL;
1730 }
1731
1732 /* mp_do_kill_file
1733  * A little hack to get around a bug in some implemenation of remove()
1734  * that do not know how to delete a directory
1735  *
1736  * Delete any file to which user has control access, regardless of whether
1737  * delete access is explicitly allowed.
1738  * Limitations: User must have write access to parent directory.
1739  *              Does not block signals or ASTs; if interrupted in midstream
1740  *              may leave file with an altered ACL.
1741  * HANDLE WITH CARE!
1742  */
1743 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1744 static int
1745 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1746 {
1747     char *vmsname, *rspec;
1748     char *remove_name;
1749     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1750     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1751     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1752     struct myacedef {
1753       unsigned char myace$b_length;
1754       unsigned char myace$b_type;
1755       unsigned short int myace$w_flags;
1756       unsigned long int myace$l_access;
1757       unsigned long int myace$l_ident;
1758     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1759                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1760       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1761      struct itmlst_3
1762        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1763                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1764        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1765        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1766        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1767        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1768
1769     /* Expand the input spec using RMS, since the CRTL remove() and
1770      * system services won't do this by themselves, so we may miss
1771      * a file "hiding" behind a logical name or search list. */
1772     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1773     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1774
1775     if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1776       PerlMem_free(vmsname);
1777       return -1;
1778     }
1779
1780     if (decc_posix_compliant_pathnames) {
1781       /* In POSIX mode, we prefer to remove the UNIX name */
1782       rspec = vmsname;
1783       remove_name = (char *)name;
1784     }
1785     else {
1786       rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1787       if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1788       if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1789         PerlMem_free(rspec);
1790         PerlMem_free(vmsname);
1791         return -1;
1792       }
1793       PerlMem_free(vmsname);
1794       remove_name = rspec;
1795     }
1796
1797 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1798     if (dirflag != 0) {
1799         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1800           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1801           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1802
1803           do_pathify_dirspec(name, remove_name, 0, NULL);
1804           if (!rmdir(remove_name)) {
1805
1806             PerlMem_free(remove_name);
1807             PerlMem_free(rspec);
1808             return 0;   /* Can we just get rid of it? */
1809           }
1810         }
1811         else {
1812           if (!rmdir(remove_name)) {
1813             PerlMem_free(rspec);
1814             return 0;   /* Can we just get rid of it? */
1815           }
1816         }
1817     }
1818     else
1819 #endif
1820       if (!remove(remove_name)) {
1821         PerlMem_free(rspec);
1822         return 0;   /* Can we just get rid of it? */
1823       }
1824
1825     /* If not, can changing protections help? */
1826     if (vaxc$errno != RMS$_PRV) {
1827       PerlMem_free(rspec);
1828       return -1;
1829     }
1830
1831     /* No, so we get our own UIC to use as a rights identifier,
1832      * and the insert an ACE at the head of the ACL which allows us
1833      * to delete the file.
1834      */
1835     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1836     fildsc.dsc$w_length = strlen(rspec);
1837     fildsc.dsc$a_pointer = rspec;
1838     cxt = 0;
1839     newace.myace$l_ident = oldace.myace$l_ident;
1840     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1841       switch (aclsts) {
1842         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1843           set_errno(ENOENT); break;
1844         case RMS$_DIR:
1845           set_errno(ENOTDIR); break;
1846         case RMS$_DEV:
1847           set_errno(ENODEV); break;
1848         case RMS$_SYN: case SS$_INVFILFOROP:
1849           set_errno(EINVAL); break;
1850         case RMS$_PRV:
1851           set_errno(EACCES); break;
1852         default:
1853           _ckvmssts(aclsts);
1854       }
1855       set_vaxc_errno(aclsts);
1856       PerlMem_free(rspec);
1857       return -1;
1858     }
1859     /* Grab any existing ACEs with this identifier in case we fail */
1860     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1861     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1862                     || fndsts == SS$_NOMOREACE ) {
1863       /* Add the new ACE . . . */
1864       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1865         goto yourroom;
1866
1867 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1868       if (dirflag != 0)
1869         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1870           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1871           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1872
1873           do_pathify_dirspec(name, remove_name, 0, NULL);
1874           rmsts = rmdir(remove_name);
1875           PerlMem_free(remove_name);
1876         }
1877         else {
1878         rmsts = rmdir(remove_name);
1879         }
1880       else
1881 #endif
1882         rmsts = remove(remove_name);
1883       if (rmsts) {
1884         /* We blew it - dir with files in it, no write priv for
1885          * parent directory, etc.  Put things back the way they were. */
1886         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1887           goto yourroom;
1888         if (fndsts & 1) {
1889           addlst[0].bufadr = &oldace;
1890           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1891             goto yourroom;
1892         }
1893       }
1894     }
1895
1896     yourroom:
1897     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1898     /* We just deleted it, so of course it's not there.  Some versions of
1899      * VMS seem to return success on the unlock operation anyhow (after all
1900      * the unlock is successful), but others don't.
1901      */
1902     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1903     if (aclsts & 1) aclsts = fndsts;
1904     if (!(aclsts & 1)) {
1905       set_errno(EVMSERR);
1906       set_vaxc_errno(aclsts);
1907       PerlMem_free(rspec);
1908       return -1;
1909     }
1910
1911     PerlMem_free(rspec);
1912     return rmsts;
1913
1914 }  /* end of kill_file() */
1915 /*}}}*/
1916
1917
1918 /*{{{int do_rmdir(char *name)*/
1919 int
1920 Perl_do_rmdir(pTHX_ const char *name)
1921 {
1922     char dirfile[NAM$C_MAXRSS+1];
1923     int retval;
1924     Stat_t st;
1925
1926     if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1927     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1928     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1929     return retval;
1930
1931 }  /* end of do_rmdir */
1932 /*}}}*/
1933
1934 /* kill_file
1935  * Delete any file to which user has control access, regardless of whether
1936  * delete access is explicitly allowed.
1937  * Limitations: User must have write access to parent directory.
1938  *              Does not block signals or ASTs; if interrupted in midstream
1939  *              may leave file with an altered ACL.
1940  * HANDLE WITH CARE!
1941  */
1942 /*{{{int kill_file(char *name)*/
1943 int
1944 Perl_kill_file(pTHX_ const char *name)
1945 {
1946     char rspec[NAM$C_MAXRSS+1];
1947     char *tspec;
1948     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1949     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1950     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1951     struct myacedef {
1952       unsigned char myace$b_length;
1953       unsigned char myace$b_type;
1954       unsigned short int myace$w_flags;
1955       unsigned long int myace$l_access;
1956       unsigned long int myace$l_ident;
1957     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1958                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1959       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1960      struct itmlst_3
1961        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1962                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1963        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1964        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1965        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1966        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1967
1968     /* Expand the input spec using RMS, since the CRTL remove() and
1969      * system services won't do this by themselves, so we may miss
1970      * a file "hiding" behind a logical name or search list. */
1971     tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1972     if (tspec == NULL) return -1;
1973     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1974     /* If not, can changing protections help? */
1975     if (vaxc$errno != RMS$_PRV) return -1;
1976
1977     /* No, so we get our own UIC to use as a rights identifier,
1978      * and the insert an ACE at the head of the ACL which allows us
1979      * to delete the file.
1980      */
1981     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1982     fildsc.dsc$w_length = strlen(rspec);
1983     fildsc.dsc$a_pointer = rspec;
1984     cxt = 0;
1985     newace.myace$l_ident = oldace.myace$l_ident;
1986     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1987       switch (aclsts) {
1988         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1989           set_errno(ENOENT); break;
1990         case RMS$_DIR:
1991           set_errno(ENOTDIR); break;
1992         case RMS$_DEV:
1993           set_errno(ENODEV); break;
1994         case RMS$_SYN: case SS$_INVFILFOROP:
1995           set_errno(EINVAL); break;
1996         case RMS$_PRV:
1997           set_errno(EACCES); break;
1998         default:
1999           _ckvmssts(aclsts);
2000       }
2001       set_vaxc_errno(aclsts);
2002       return -1;
2003     }
2004     /* Grab any existing ACEs with this identifier in case we fail */
2005     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2006     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2007                     || fndsts == SS$_NOMOREACE ) {
2008       /* Add the new ACE . . . */
2009       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2010         goto yourroom;
2011       if ((rmsts = remove(name))) {
2012         /* We blew it - dir with files in it, no write priv for
2013          * parent directory, etc.  Put things back the way they were. */
2014         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2015           goto yourroom;
2016         if (fndsts & 1) {
2017           addlst[0].bufadr = &oldace;
2018           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2019             goto yourroom;
2020         }
2021       }
2022     }
2023
2024     yourroom:
2025     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2026     /* We just deleted it, so of course it's not there.  Some versions of
2027      * VMS seem to return success on the unlock operation anyhow (after all
2028      * the unlock is successful), but others don't.
2029      */
2030     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2031     if (aclsts & 1) aclsts = fndsts;
2032     if (!(aclsts & 1)) {
2033       set_errno(EVMSERR);
2034       set_vaxc_errno(aclsts);
2035       return -1;
2036     }
2037
2038     return rmsts;
2039
2040 }  /* end of kill_file() */
2041 /*}}}*/
2042
2043
2044 /*{{{int my_mkdir(char *,Mode_t)*/
2045 int
2046 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2047 {
2048   STRLEN dirlen = strlen(dir);
2049
2050   /* zero length string sometimes gives ACCVIO */
2051   if (dirlen == 0) return -1;
2052
2053   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2054    * null file name/type.  However, it's commonplace under Unix,
2055    * so we'll allow it for a gain in portability.
2056    */
2057   if (dir[dirlen-1] == '/') {
2058     char *newdir = savepvn(dir,dirlen-1);
2059     int ret = mkdir(newdir,mode);
2060     Safefree(newdir);
2061     return ret;
2062   }
2063   else return mkdir(dir,mode);
2064 }  /* end of my_mkdir */
2065 /*}}}*/
2066
2067 /*{{{int my_chdir(char *)*/
2068 int
2069 Perl_my_chdir(pTHX_ const char *dir)
2070 {
2071   STRLEN dirlen = strlen(dir);
2072
2073   /* zero length string sometimes gives ACCVIO */
2074   if (dirlen == 0) return -1;
2075   const char *dir1;
2076
2077   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2078    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2079    * so that existing scripts do not need to be changed.
2080    */
2081   dir1 = dir;
2082   while ((dirlen > 0) && (*dir1 == ' ')) {
2083     dir1++;
2084     dirlen--;
2085   }
2086
2087   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2088    * that implies
2089    * null file name/type.  However, it's commonplace under Unix,
2090    * so we'll allow it for a gain in portability.
2091    *
2092    * - Preview- '/' will be valid soon on VMS
2093    */
2094   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2095     char *newdir = savepvn(dir1,dirlen-1);
2096     int ret = chdir(newdir);
2097     Safefree(newdir);
2098     return ret;
2099   }
2100   else return chdir(dir1);
2101 }  /* end of my_chdir */
2102 /*}}}*/
2103
2104
2105 /*{{{FILE *my_tmpfile()*/
2106 FILE *
2107 my_tmpfile(void)
2108 {
2109   FILE *fp;
2110   char *cp;
2111
2112   if ((fp = tmpfile())) return fp;
2113
2114   cp = PerlMem_malloc(L_tmpnam+24);
2115   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2116
2117   if (decc_filename_unix_only == 0)
2118     strcpy(cp,"Sys$Scratch:");
2119   else
2120     strcpy(cp,"/tmp/");
2121   tmpnam(cp+strlen(cp));
2122   strcat(cp,".Perltmp");
2123   fp = fopen(cp,"w+","fop=dlt");
2124   PerlMem_free(cp);
2125   return fp;
2126 }
2127 /*}}}*/
2128
2129
2130 #ifndef HOMEGROWN_POSIX_SIGNALS
2131 /*
2132  * The C RTL's sigaction fails to check for invalid signal numbers so we
2133  * help it out a bit.  The docs are correct, but the actual routine doesn't
2134  * do what the docs say it will.
2135  */
2136 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2137 int
2138 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2139                    struct sigaction* oact)
2140 {
2141   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2142         SETERRNO(EINVAL, SS$_INVARG);
2143         return -1;
2144   }
2145   return sigaction(sig, act, oact);
2146 }
2147 /*}}}*/
2148 #endif
2149
2150 #ifdef KILL_BY_SIGPRC
2151 #include <errnodef.h>
2152
2153 /* We implement our own kill() using the undocumented system service
2154    sys$sigprc for one of two reasons:
2155
2156    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2157    target process to do a sys$exit, which usually can't be handled
2158    gracefully...certainly not by Perl and the %SIG{} mechanism.
2159
2160    2.) If the kill() in the CRTL can't be called from a signal
2161    handler without disappearing into the ether, i.e., the signal
2162    it purportedly sends is never trapped. Still true as of VMS 7.3.
2163
2164    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2165    in the target process rather than calling sys$exit.
2166
2167    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2168    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2169    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2170    with condition codes C$_SIG0+nsig*8, catching the exception on the
2171    target process and resignaling with appropriate arguments.
2172
2173    But we don't have that VMS 7.0+ exception handler, so if you
2174    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2175
2176    Also note that SIGTERM is listed in the docs as being "unimplemented",
2177    yet always seems to be signaled with a VMS condition code of 4 (and
2178    correctly handled for that code).  So we hardwire it in.
2179
2180    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2181    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2182    than signalling with an unrecognized (and unhandled by CRTL) code.
2183 */
2184
2185 #define _MY_SIG_MAX 28
2186
2187 static unsigned int
2188 Perl_sig_to_vmscondition_int(int sig)
2189 {
2190     static unsigned int sig_code[_MY_SIG_MAX+1] =
2191     {
2192         0,                  /*  0 ZERO     */
2193         SS$_HANGUP,         /*  1 SIGHUP   */
2194         SS$_CONTROLC,       /*  2 SIGINT   */
2195         SS$_CONTROLY,       /*  3 SIGQUIT  */
2196         SS$_RADRMOD,        /*  4 SIGILL   */
2197         SS$_BREAK,          /*  5 SIGTRAP  */
2198         SS$_OPCCUS,         /*  6 SIGABRT  */
2199         SS$_COMPAT,         /*  7 SIGEMT   */
2200 #ifdef __VAX
2201         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2202 #else
2203         SS$_HPARITH,        /*  8 SIGFPE AXP */
2204 #endif
2205         SS$_ABORT,          /*  9 SIGKILL  */
2206         SS$_ACCVIO,         /* 10 SIGBUS   */
2207         SS$_ACCVIO,         /* 11 SIGSEGV  */
2208         SS$_BADPARAM,       /* 12 SIGSYS   */
2209         SS$_NOMBX,          /* 13 SIGPIPE  */
2210         SS$_ASTFLT,         /* 14 SIGALRM  */
2211         4,                  /* 15 SIGTERM  */
2212         0,                  /* 16 SIGUSR1  */
2213         0,                  /* 17 SIGUSR2  */
2214         0,                  /* 18 */
2215         0,                  /* 19 */
2216         0,                  /* 20 SIGCHLD  */
2217         0,                  /* 21 SIGCONT  */
2218         0,                  /* 22 SIGSTOP  */
2219         0,                  /* 23 SIGTSTP  */
2220         0,                  /* 24 SIGTTIN  */
2221         0,                  /* 25 SIGTTOU  */
2222         0,                  /* 26 */
2223         0,                  /* 27 */
2224         0                   /* 28 SIGWINCH  */
2225     };
2226
2227 #if __VMS_VER >= 60200000
2228     static int initted = 0;
2229     if (!initted) {
2230         initted = 1;
2231         sig_code[16] = C$_SIGUSR1;
2232         sig_code[17] = C$_SIGUSR2;
2233 #if __CRTL_VER >= 70000000
2234         sig_code[20] = C$_SIGCHLD;
2235 #endif
2236 #if __CRTL_VER >= 70300000
2237         sig_code[28] = C$_SIGWINCH;
2238 #endif
2239     }
2240 #endif
2241
2242     if (sig < _SIG_MIN) return 0;
2243     if (sig > _MY_SIG_MAX) return 0;
2244     return sig_code[sig];
2245 }
2246
2247 unsigned int
2248 Perl_sig_to_vmscondition(int sig)
2249 {
2250 #ifdef SS$_DEBUG
2251     if (vms_debug_on_exception != 0)
2252         lib$signal(SS$_DEBUG);
2253 #endif
2254     return Perl_sig_to_vmscondition_int(sig);
2255 }
2256
2257
2258 int
2259 Perl_my_kill(int pid, int sig)
2260 {
2261     dTHX;
2262     int iss;
2263     unsigned int code;
2264     int sys$sigprc(unsigned int *pidadr,
2265                      struct dsc$descriptor_s *prcname,
2266                      unsigned int code);
2267
2268      /* sig 0 means validate the PID */
2269     /*------------------------------*/
2270     if (sig == 0) {
2271         const unsigned long int jpicode = JPI$_PID;
2272         pid_t ret_pid;
2273         int status;
2274         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2275         if ($VMS_STATUS_SUCCESS(status))
2276            return 0;
2277         switch (status) {
2278         case SS$_NOSUCHNODE:
2279         case SS$_UNREACHABLE:
2280         case SS$_NONEXPR:
2281            errno = ESRCH;
2282            break;
2283         case SS$_NOPRIV:
2284            errno = EPERM;
2285            break;
2286         default:
2287            errno = EVMSERR;
2288         }
2289         vaxc$errno=status;
2290         return -1;
2291     }
2292
2293     code = Perl_sig_to_vmscondition_int(sig);
2294
2295     if (!code) {
2296         SETERRNO(EINVAL, SS$_BADPARAM);
2297         return -1;
2298     }
2299
2300     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2301      * signals are to be sent to multiple processes.
2302      *  pid = 0 - all processes in group except ones that the system exempts
2303      *  pid = -1 - all processes except ones that the system exempts
2304      *  pid = -n - all processes in group (abs(n)) except ...
2305      * For now, just report as not supported.
2306      */
2307
2308     if (pid <= 0) {
2309         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2310         return -1;
2311     }
2312
2313     iss = sys$sigprc((unsigned int *)&pid,0,code);
2314     if (iss&1) return 0;
2315
2316     switch (iss) {
2317       case SS$_NOPRIV:
2318         set_errno(EPERM);  break;
2319       case SS$_NONEXPR:
2320       case SS$_NOSUCHNODE:
2321       case SS$_UNREACHABLE:
2322         set_errno(ESRCH);  break;
2323       case SS$_INSFMEM:
2324         set_errno(ENOMEM); break;
2325       default:
2326         _ckvmssts(iss);
2327         set_errno(EVMSERR);
2328     }
2329     set_vaxc_errno(iss);
2330
2331     return -1;
2332 }
2333 #endif
2334
2335 /* Routine to convert a VMS status code to a UNIX status code.
2336 ** More tricky than it appears because of conflicting conventions with
2337 ** existing code.
2338 **
2339 ** VMS status codes are a bit mask, with the least significant bit set for
2340 ** success.
2341 **
2342 ** Special UNIX status of EVMSERR indicates that no translation is currently
2343 ** available, and programs should check the VMS status code.
2344 **
2345 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2346 ** decoding.
2347 */
2348
2349 #ifndef C_FACILITY_NO
2350 #define C_FACILITY_NO 0x350000
2351 #endif
2352 #ifndef DCL_IVVERB
2353 #define DCL_IVVERB 0x38090
2354 #endif
2355
2356 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2357 {
2358 int facility;
2359 int fac_sp;
2360 int msg_no;
2361 int msg_status;
2362 int unix_status;
2363
2364   /* Assume the best or the worst */
2365   if (vms_status & STS$M_SUCCESS)
2366     unix_status = 0;
2367   else
2368     unix_status = EVMSERR;
2369
2370   msg_status = vms_status & ~STS$M_CONTROL;
2371
2372   facility = vms_status & STS$M_FAC_NO;
2373   fac_sp = vms_status & STS$M_FAC_SP;
2374   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2375
2376   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2377     switch(msg_no) {
2378     case SS$_NORMAL:
2379         unix_status = 0;
2380         break;
2381     case SS$_ACCVIO:
2382         unix_status = EFAULT;
2383         break;
2384     case SS$_DEVOFFLINE:
2385         unix_status = EBUSY;
2386         break;
2387     case SS$_CLEARED:
2388         unix_status = ENOTCONN;
2389         break;
2390     case SS$_IVCHAN:
2391     case SS$_IVLOGNAM:
2392     case SS$_BADPARAM:
2393     case SS$_IVLOGTAB:
2394     case SS$_NOLOGNAM:
2395     case SS$_NOLOGTAB:
2396     case SS$_INVFILFOROP:
2397     case SS$_INVARG:
2398     case SS$_NOSUCHID:
2399     case SS$_IVIDENT:
2400         unix_status = EINVAL;
2401         break;
2402     case SS$_UNSUPPORTED:
2403         unix_status = ENOTSUP;
2404         break;
2405     case SS$_FILACCERR:
2406     case SS$_NOGRPPRV:
2407     case SS$_NOSYSPRV:
2408         unix_status = EACCES;
2409         break;
2410     case SS$_DEVICEFULL:
2411         unix_status = ENOSPC;
2412         break;
2413     case SS$_NOSUCHDEV:
2414         unix_status = ENODEV;
2415         break;
2416     case SS$_NOSUCHFILE:
2417     case SS$_NOSUCHOBJECT:
2418         unix_status = ENOENT;
2419         break;
2420     case SS$_ABORT:                                 /* Fatal case */
2421     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2422     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2423         unix_status = EINTR;
2424         break;
2425     case SS$_BUFFEROVF:
2426         unix_status = E2BIG;
2427         break;
2428     case SS$_INSFMEM:
2429         unix_status = ENOMEM;
2430         break;
2431     case SS$_NOPRIV:
2432         unix_status = EPERM;
2433         break;
2434     case SS$_NOSUCHNODE:
2435     case SS$_UNREACHABLE:
2436         unix_status = ESRCH;
2437         break;
2438     case SS$_NONEXPR:
2439         unix_status = ECHILD;
2440         break;
2441     default:
2442         if ((facility == 0) && (msg_no < 8)) {
2443           /* These are not real VMS status codes so assume that they are
2444           ** already UNIX status codes
2445           */
2446           unix_status = msg_no;
2447           break;
2448         }
2449     }
2450   }
2451   else {
2452     /* Translate a POSIX exit code to a UNIX exit code */
2453     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2454         unix_status = (msg_no & 0x07F8) >> 3;
2455     }
2456     else {
2457
2458          /* Documented traditional behavior for handling VMS child exits */
2459         /*--------------------------------------------------------------*/
2460         if (child_flag != 0) {
2461
2462              /* Success / Informational return 0 */
2463             /*----------------------------------*/
2464             if (msg_no & STS$K_SUCCESS)
2465                 return 0;
2466
2467              /* Warning returns 1 */
2468             /*-------------------*/
2469             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2470                 return 1;
2471
2472              /* Everything else pass through the severity bits */
2473             /*------------------------------------------------*/
2474             return (msg_no & STS$M_SEVERITY);
2475         }
2476
2477          /* Normal VMS status to ERRNO mapping attempt */
2478         /*--------------------------------------------*/
2479         switch(msg_status) {
2480         /* case RMS$_EOF: */ /* End of File */
2481         case RMS$_FNF:  /* File Not Found */
2482         case RMS$_DNF:  /* Dir Not Found */
2483                 unix_status = ENOENT;
2484                 break;
2485         case RMS$_RNF:  /* Record Not Found */
2486                 unix_status = ESRCH;
2487                 break;
2488         case RMS$_DIR:
2489                 unix_status = ENOTDIR;
2490                 break;
2491         case RMS$_DEV:
2492                 unix_status = ENODEV;
2493                 break;
2494         case RMS$_IFI:
2495         case RMS$_FAC:
2496         case RMS$_ISI:
2497                 unix_status = EBADF;
2498                 break;
2499         case RMS$_FEX:
2500                 unix_status = EEXIST;
2501                 break;
2502         case RMS$_SYN:
2503         case RMS$_FNM:
2504         case LIB$_INVSTRDES:
2505         case LIB$_INVARG:
2506         case LIB$_NOSUCHSYM:
2507         case LIB$_INVSYMNAM:
2508         case DCL_IVVERB:
2509                 unix_status = EINVAL;
2510                 break;
2511         case CLI$_BUFOVF:
2512         case RMS$_RTB:
2513         case CLI$_TKNOVF:
2514         case CLI$_RSLOVF:
2515                 unix_status = E2BIG;
2516                 break;
2517         case RMS$_PRV:  /* No privilege */
2518         case RMS$_ACC:  /* ACP file access failed */
2519         case RMS$_WLK:  /* Device write locked */
2520                 unix_status = EACCES;
2521                 break;
2522         /* case RMS$_NMF: */  /* No more files */
2523         }
2524     }
2525   }
2526
2527   return unix_status;
2528 }
2529
2530 /* Try to guess at what VMS error status should go with a UNIX errno
2531  * value.  This is hard to do as there could be many possible VMS
2532  * error statuses that caused the errno value to be set.
2533  */
2534
2535 int Perl_unix_status_to_vms(int unix_status)
2536 {
2537 int test_unix_status;
2538
2539      /* Trivial cases first */
2540     /*---------------------*/
2541     if (unix_status == EVMSERR)
2542         return vaxc$errno;
2543
2544      /* Is vaxc$errno sane? */
2545     /*---------------------*/
2546     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2547     if (test_unix_status == unix_status)
2548         return vaxc$errno;
2549
2550      /* If way out of range, must be VMS code already */
2551     /*-----------------------------------------------*/
2552     if (unix_status > EVMSERR)
2553         return unix_status;
2554
2555      /* If out of range, punt */
2556     /*-----------------------*/
2557     if (unix_status > __ERRNO_MAX)
2558         return SS$_ABORT;
2559
2560
2561      /* Ok, now we have to do it the hard way. */
2562     /*----------------------------------------*/
2563     switch(unix_status) {
2564     case 0:     return SS$_NORMAL;
2565     case EPERM: return SS$_NOPRIV;
2566     case ENOENT: return SS$_NOSUCHOBJECT;
2567     case ESRCH: return SS$_UNREACHABLE;
2568     case EINTR: return SS$_ABORT;
2569     /* case EIO: */
2570     /* case ENXIO:  */
2571     case E2BIG: return SS$_BUFFEROVF;
2572     /* case ENOEXEC */
2573     case EBADF: return RMS$_IFI;
2574     case ECHILD: return SS$_NONEXPR;
2575     /* case EAGAIN */
2576     case ENOMEM: return SS$_INSFMEM;
2577     case EACCES: return SS$_FILACCERR;
2578     case EFAULT: return SS$_ACCVIO;
2579     /* case ENOTBLK */
2580     case EBUSY: return SS$_DEVOFFLINE;
2581     case EEXIST: return RMS$_FEX;
2582     /* case EXDEV */
2583     case ENODEV: return SS$_NOSUCHDEV;
2584     case ENOTDIR: return RMS$_DIR;
2585     /* case EISDIR */
2586     case EINVAL: return SS$_INVARG;
2587     /* case ENFILE */
2588     /* case EMFILE */
2589     /* case ENOTTY */
2590     /* case ETXTBSY */
2591     /* case EFBIG */
2592     case ENOSPC: return SS$_DEVICEFULL;
2593     case ESPIPE: return LIB$_INVARG;
2594     /* case EROFS: */
2595     /* case EMLINK: */
2596     /* case EPIPE: */
2597     /* case EDOM */
2598     case ERANGE: return LIB$_INVARG;
2599     /* case EWOULDBLOCK */
2600     /* case EINPROGRESS */
2601     /* case EALREADY */
2602     /* case ENOTSOCK */
2603     /* case EDESTADDRREQ */
2604     /* case EMSGSIZE */
2605     /* case EPROTOTYPE */
2606     /* case ENOPROTOOPT */
2607     /* case EPROTONOSUPPORT */
2608     /* case ESOCKTNOSUPPORT */
2609     /* case EOPNOTSUPP */
2610     /* case EPFNOSUPPORT */
2611     /* case EAFNOSUPPORT */
2612     /* case EADDRINUSE */
2613     /* case EADDRNOTAVAIL */
2614     /* case ENETDOWN */
2615     /* case ENETUNREACH */
2616     /* case ENETRESET */
2617     /* case ECONNABORTED */
2618     /* case ECONNRESET */
2619     /* case ENOBUFS */
2620     /* case EISCONN */
2621     case ENOTCONN: return SS$_CLEARED;
2622     /* case ESHUTDOWN */
2623     /* case ETOOMANYREFS */
2624     /* case ETIMEDOUT */
2625     /* case ECONNREFUSED */
2626     /* case ELOOP */
2627     /* case ENAMETOOLONG */
2628     /* case EHOSTDOWN */
2629     /* case EHOSTUNREACH */
2630     /* case ENOTEMPTY */
2631     /* case EPROCLIM */
2632     /* case EUSERS  */
2633     /* case EDQUOT  */
2634     /* case ENOMSG  */
2635     /* case EIDRM */
2636     /* case EALIGN */
2637     /* case ESTALE */
2638     /* case EREMOTE */
2639     /* case ENOLCK */
2640     /* case ENOSYS */
2641     /* case EFTYPE */
2642     /* case ECANCELED */
2643     /* case EFAIL */
2644     /* case EINPROG */
2645     case ENOTSUP:
2646         return SS$_UNSUPPORTED;
2647     /* case EDEADLK */
2648     /* case ENWAIT */
2649     /* case EILSEQ */
2650     /* case EBADCAT */
2651     /* case EBADMSG */
2652     /* case EABANDONED */
2653     default:
2654         return SS$_ABORT; /* punt */
2655     }
2656
2657   return SS$_ABORT; /* Should not get here */
2658 }
2659
2660
2661 /* default piping mailbox size */
2662 #define PERL_BUFSIZ        512
2663
2664
2665 static void
2666 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2667 {
2668   unsigned long int mbxbufsiz;
2669   static unsigned long int syssize = 0;
2670   unsigned long int dviitm = DVI$_DEVNAM;
2671   char csize[LNM$C_NAMLENGTH+1];
2672   int sts;
2673
2674   if (!syssize) {
2675     unsigned long syiitm = SYI$_MAXBUF;
2676     /*
2677      * Get the SYSGEN parameter MAXBUF
2678      *
2679      * If the logical 'PERL_MBX_SIZE' is defined
2680      * use the value of the logical instead of PERL_BUFSIZ, but
2681      * keep the size between 128 and MAXBUF.
2682      *
2683      */
2684     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2685   }
2686
2687   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2688       mbxbufsiz = atoi(csize);
2689   } else {
2690       mbxbufsiz = PERL_BUFSIZ;
2691   }
2692   if (mbxbufsiz < 128) mbxbufsiz = 128;
2693   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2694
2695   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2696
2697   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2698   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2699
2700 }  /* end of create_mbx() */
2701
2702
2703 /*{{{  my_popen and my_pclose*/
2704
2705 typedef struct _iosb           IOSB;
2706 typedef struct _iosb*         pIOSB;
2707 typedef struct _pipe           Pipe;
2708 typedef struct _pipe*         pPipe;
2709 typedef struct pipe_details    Info;
2710 typedef struct pipe_details*  pInfo;
2711 typedef struct _srqp            RQE;
2712 typedef struct _srqp*          pRQE;
2713 typedef struct _tochildbuf      CBuf;
2714 typedef struct _tochildbuf*    pCBuf;
2715
2716 struct _iosb {
2717     unsigned short status;
2718     unsigned short count;
2719     unsigned long  dvispec;
2720 };
2721
2722 #pragma member_alignment save
2723 #pragma nomember_alignment quadword
2724 struct _srqp {          /* VMS self-relative queue entry */
2725     unsigned long qptr[2];
2726 };
2727 #pragma member_alignment restore
2728 static RQE  RQE_ZERO = {0,0};
2729
2730 struct _tochildbuf {
2731     RQE             q;
2732     int             eof;
2733     unsigned short  size;
2734     char            *buf;
2735 };
2736
2737 struct _pipe {
2738     RQE            free;
2739     RQE            wait;
2740     int            fd_out;
2741     unsigned short chan_in;
2742     unsigned short chan_out;
2743     char          *buf;
2744     unsigned int   bufsize;
2745     IOSB           iosb;
2746     IOSB           iosb2;
2747     int           *pipe_done;
2748     int            retry;
2749     int            type;
2750     int            shut_on_empty;
2751     int            need_wake;
2752     pPipe         *home;
2753     pInfo          info;
2754     pCBuf          curr;
2755     pCBuf          curr2;
2756 #if defined(PERL_IMPLICIT_CONTEXT)
2757     void            *thx;           /* Either a thread or an interpreter */
2758                                     /* pointer, depending on how we're built */
2759 #endif
2760 };
2761
2762
2763 struct pipe_details
2764 {
2765     pInfo           next;
2766     PerlIO *fp;  /* file pointer to pipe mailbox */
2767     int useFILE; /* using stdio, not perlio */
2768     int pid;   /* PID of subprocess */
2769     int mode;  /* == 'r' if pipe open for reading */
2770     int done;  /* subprocess has completed */
2771     int waiting; /* waiting for completion/closure */
2772     int             closing;        /* my_pclose is closing this pipe */
2773     unsigned long   completion;     /* termination status of subprocess */
2774     pPipe           in;             /* pipe in to sub */
2775     pPipe           out;            /* pipe out of sub */
2776     pPipe           err;            /* pipe of sub's sys$error */
2777     int             in_done;        /* true when in pipe finished */
2778     int             out_done;
2779     int             err_done;
2780     unsigned short  xchan;          /* channel to debug xterm */
2781     unsigned short  xchan_valid;    /* channel is assigned */
2782 };
2783
2784 struct exit_control_block
2785 {
2786     struct exit_control_block *flink;
2787     unsigned long int   (*exit_routine)();
2788     unsigned long int arg_count;
2789     unsigned long int *status_address;
2790     unsigned long int exit_status;
2791 };
2792
2793 typedef struct _closed_pipes    Xpipe;
2794 typedef struct _closed_pipes*  pXpipe;
2795
2796 struct _closed_pipes {
2797     int             pid;            /* PID of subprocess */
2798     unsigned long   completion;     /* termination status of subprocess */
2799 };
2800 #define NKEEPCLOSED 50
2801 static Xpipe closed_list[NKEEPCLOSED];
2802 static int   closed_index = 0;
2803 static int   closed_num = 0;
2804
2805 #define RETRY_DELAY     "0 ::0.20"
2806 #define MAX_RETRY              50
2807
2808 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2809 static unsigned long mypid;
2810 static unsigned long delaytime[2];
2811
2812 static pInfo open_pipes = NULL;
2813 static $DESCRIPTOR(nl_desc, "NL:");
2814
2815 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2816
2817
2818
2819 static unsigned long int
2820 pipe_exit_routine(pTHX)
2821 {
2822     pInfo info;
2823     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2824     int sts, did_stuff, need_eof, j;
2825
2826    /*
2827     * Flush any pending i/o, but since we are in process run-down, be
2828     * careful about referencing PerlIO structures that may already have
2829     * been deallocated.  We may not even have an interpreter anymore.
2830     */
2831     info = open_pipes;
2832     while (info) {
2833         if (info->fp) {
2834            if (!info->useFILE
2835 #if defined(USE_ITHREADS)
2836              && my_perl
2837 #endif
2838              && PL_perlio_fd_refcnt)
2839                PerlIO_flush(info->fp);
2840            else
2841                fflush((FILE *)info->fp);
2842         }
2843         info = info->next;
2844     }
2845
2846     /*
2847      next we try sending an EOF...ignore if doesn't work, make sure we
2848      don't hang
2849     */
2850     did_stuff = 0;
2851     info = open_pipes;
2852
2853     while (info) {
2854       int need_eof;
2855       _ckvmssts_noperl(sys$setast(0));
2856       if (info->in && !info->in->shut_on_empty) {
2857         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2858                           0, 0, 0, 0, 0, 0));
2859         info->waiting = 1;
2860         did_stuff = 1;
2861       }
2862       _ckvmssts_noperl(sys$setast(1));
2863       info = info->next;
2864     }
2865
2866     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2867
2868     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2869         int nwait = 0;
2870
2871         info = open_pipes;
2872         while (info) {
2873           _ckvmssts_noperl(sys$setast(0));
2874           if (info->waiting && info->done)
2875                 info->waiting = 0;
2876           nwait += info->waiting;
2877           _ckvmssts_noperl(sys$setast(1));
2878           info = info->next;
2879         }
2880         if (!nwait) break;
2881         sleep(1);
2882     }
2883
2884     did_stuff = 0;
2885     info = open_pipes;
2886     while (info) {
2887       _ckvmssts_noperl(sys$setast(0));
2888       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2889         sts = sys$forcex(&info->pid,0,&abort);
2890         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2891         did_stuff = 1;
2892       }
2893       _ckvmssts_noperl(sys$setast(1));
2894       info = info->next;
2895     }
2896
2897     /* again, wait for effect */
2898
2899     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2900         int nwait = 0;
2901
2902         info = open_pipes;
2903         while (info) {
2904           _ckvmssts_noperl(sys$setast(0));
2905           if (info->waiting && info->done)
2906                 info->waiting = 0;
2907           nwait += info->waiting;
2908           _ckvmssts_noperl(sys$setast(1));
2909           info = info->next;
2910         }
2911         if (!nwait) break;
2912         sleep(1);
2913     }
2914
2915     info = open_pipes;
2916     while (info) {
2917       _ckvmssts_noperl(sys$setast(0));
2918       if (!info->done) {  /* We tried to be nice . . . */
2919         sts = sys$delprc(&info->pid,0);
2920         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2921         info->done = 1;  /* sys$delprc is as done as we're going to get. */
2922       }
2923       _ckvmssts_noperl(sys$setast(1));
2924       info = info->next;
2925     }
2926
2927     while(open_pipes) {
2928       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2929       else if (!(sts & 1)) retsts = sts;
2930     }
2931     return retsts;
2932 }
2933
2934 static struct exit_control_block pipe_exitblock =
2935        {(struct exit_control_block *) 0,
2936         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2937
2938 static void pipe_mbxtofd_ast(pPipe p);
2939 static void pipe_tochild1_ast(pPipe p);
2940 static void pipe_tochild2_ast(pPipe p);
2941
2942 static void
2943 popen_completion_ast(pInfo info)
2944 {
2945   pInfo i = open_pipes;
2946   int iss;
2947   int sts;
2948   pXpipe x;
2949
2950   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2951   closed_list[closed_index].pid = info->pid;
2952   closed_list[closed_index].completion = info->completion;
2953   closed_index++;
2954   if (closed_index == NKEEPCLOSED)
2955     closed_index = 0;
2956   closed_num++;
2957
2958   while (i) {
2959     if (i == info) break;
2960     i = i->next;
2961   }
2962   if (!i) return;       /* unlinked, probably freed too */
2963
2964   info->done = TRUE;
2965
2966 /*
2967     Writing to subprocess ...
2968             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2969
2970             chan_out may be waiting for "done" flag, or hung waiting
2971             for i/o completion to child...cancel the i/o.  This will
2972             put it into "snarf mode" (done but no EOF yet) that discards
2973             input.
2974
2975     Output from subprocess (stdout, stderr) needs to be flushed and
2976     shut down.   We try sending an EOF, but if the mbx is full the pipe
2977     routine should still catch the "shut_on_empty" flag, telling it to
2978     use immediate-style reads so that "mbx empty" -> EOF.
2979
2980
2981 */
2982   if (info->in && !info->in_done) {               /* only for mode=w */
2983         if (info->in->shut_on_empty && info->in->need_wake) {
2984             info->in->need_wake = FALSE;
2985             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2986         } else {
2987             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2988         }
2989   }
2990
2991   if (info->out && !info->out_done) {             /* were we also piping output? */
2992       info->out->shut_on_empty = TRUE;
2993       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2994       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2995       _ckvmssts_noperl(iss);
2996   }
2997
2998   if (info->err && !info->err_done) {        /* we were piping stderr */
2999         info->err->shut_on_empty = TRUE;
3000         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3001         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3002         _ckvmssts_noperl(iss);
3003   }
3004   _ckvmssts_noperl(sys$setef(pipe_ef));
3005
3006 }
3007
3008 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3009 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3010
3011 /*
3012     we actually differ from vmstrnenv since we use this to
3013     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3014     are pointing to the same thing
3015 */
3016
3017 static unsigned short
3018 popen_translate(pTHX_ char *logical, char *result)
3019 {
3020     int iss;
3021     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3022     $DESCRIPTOR(d_log,"");
3023     struct _il3 {
3024         unsigned short length;
3025         unsigned short code;
3026         char *         buffer_addr;
3027         unsigned short *retlenaddr;
3028     } itmlst[2];
3029     unsigned short l, ifi;
3030
3031     d_log.dsc$a_pointer = logical;
3032     d_log.dsc$w_length  = strlen(logical);
3033
3034     itmlst[0].code = LNM$_STRING;
3035     itmlst[0].length = 255;
3036     itmlst[0].buffer_addr = result;
3037     itmlst[0].retlenaddr = &l;
3038
3039     itmlst[1].code = 0;
3040     itmlst[1].length = 0;
3041     itmlst[1].buffer_addr = 0;
3042     itmlst[1].retlenaddr = 0;
3043
3044     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3045     if (iss == SS$_NOLOGNAM) {
3046         iss = SS$_NORMAL;
3047         l = 0;
3048     }
3049     if (!(iss&1)) lib$signal(iss);
3050     result[l] = '\0';
3051 /*
3052     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3053     strip it off and return the ifi, if any
3054 */
3055     ifi  = 0;
3056     if (result[0] == 0x1b && result[1] == 0x00) {
3057         memmove(&ifi,result+2,2);
3058         strcpy(result,result+4);
3059     }
3060     return ifi;     /* this is the RMS internal file id */
3061 }
3062
3063 static void pipe_infromchild_ast(pPipe p);
3064
3065 /*
3066     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3067     inside an AST routine without worrying about reentrancy and which Perl
3068     memory allocator is being used.
3069
3070     We read data and queue up the buffers, then spit them out one at a
3071     time to the output mailbox when the output mailbox is ready for one.
3072
3073 */
3074 #define INITIAL_TOCHILDQUEUE  2
3075
3076 static pPipe
3077 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3078 {
3079     pPipe p;
3080     pCBuf b;
3081     char mbx1[64], mbx2[64];
3082     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3083                                       DSC$K_CLASS_S, mbx1},
3084                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3085                                       DSC$K_CLASS_S, mbx2};
3086     unsigned int dviitm = DVI$_DEVBUFSIZ;
3087     int j, n;
3088
3089     n = sizeof(Pipe);
3090     _ckvmssts(lib$get_vm(&n, &p));
3091
3092     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3093     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3094     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3095
3096     p->buf           = 0;
3097     p->shut_on_empty = FALSE;
3098     p->need_wake     = FALSE;
3099     p->type          = 0;
3100     p->retry         = 0;
3101     p->iosb.status   = SS$_NORMAL;
3102     p->iosb2.status  = SS$_NORMAL;
3103     p->free          = RQE_ZERO;
3104     p->wait          = RQE_ZERO;
3105     p->curr          = 0;
3106     p->curr2         = 0;
3107     p->info          = 0;
3108 #ifdef PERL_IMPLICIT_CONTEXT
3109     p->thx           = aTHX;
3110 #endif
3111
3112     n = sizeof(CBuf) + p->bufsize;
3113
3114     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3115         _ckvmssts(lib$get_vm(&n, &b));
3116         b->buf = (char *) b + sizeof(CBuf);
3117         _ckvmssts(lib$insqhi(b, &p->free));
3118     }
3119
3120     pipe_tochild2_ast(p);
3121     pipe_tochild1_ast(p);
3122     strcpy(wmbx, mbx1);
3123     strcpy(rmbx, mbx2);
3124     return p;
3125 }
3126
3127 /*  reads the MBX Perl is writing, and queues */
3128
3129 static void
3130 pipe_tochild1_ast(pPipe p)
3131 {
3132     pCBuf b = p->curr;
3133     int iss = p->iosb.status;
3134     int eof = (iss == SS$_ENDOFFILE);
3135     int sts;
3136 #ifdef PERL_IMPLICIT_CONTEXT
3137     pTHX = p->thx;
3138 #endif
3139
3140     if (p->retry) {
3141         if (eof) {
3142             p->shut_on_empty = TRUE;
3143             b->eof     = TRUE;
3144             _ckvmssts(sys$dassgn(p->chan_in));
3145         } else  {
3146             _ckvmssts(iss);
3147         }
3148
3149         b->eof  = eof;
3150         b->size = p->iosb.count;
3151         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3152         if (p->need_wake) {
3153             p->need_wake = FALSE;
3154             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3155         }
3156     } else {
3157         p->retry = 1;   /* initial call */
3158     }
3159
3160     if (eof) {                  /* flush the free queue, return when done */
3161         int n = sizeof(CBuf) + p->bufsize;
3162         while (1) {
3163             iss = lib$remqti(&p->free, &b);
3164             if (iss == LIB$_QUEWASEMP) return;
3165             _ckvmssts(iss);
3166             _ckvmssts(lib$free_vm(&n, &b));
3167         }
3168     }
3169
3170     iss = lib$remqti(&p->free, &b);
3171     if (iss == LIB$_QUEWASEMP) {
3172         int n = sizeof(CBuf) + p->bufsize;
3173         _ckvmssts(lib$get_vm(&n, &b));
3174         b->buf = (char *) b + sizeof(CBuf);
3175     } else {
3176        _ckvmssts(iss);
3177     }
3178
3179     p->curr = b;
3180     iss = sys$qio(0,p->chan_in,
3181              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3182              &p->iosb,
3183              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3184     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3185     _ckvmssts(iss);
3186 }
3187
3188
3189 /* writes queued buffers to output, waits for each to complete before
3190    doing the next */
3191
3192 static void
3193 pipe_tochild2_ast(pPipe p)
3194 {
3195     pCBuf b = p->curr2;
3196     int iss = p->iosb2.status;
3197     int n = sizeof(CBuf) + p->bufsize;
3198     int done = (p->info && p->info->done) ||
3199               iss == SS$_CANCEL || iss == SS$_ABORT;
3200 #if defined(PERL_IMPLICIT_CONTEXT)
3201     pTHX = p->thx;
3202 #endif
3203
3204     do {
3205         if (p->type) {         /* type=1 has old buffer, dispose */
3206             if (p->shut_on_empty) {
3207                 _ckvmssts(lib$free_vm(&n, &b));
3208             } else {
3209                 _ckvmssts(lib$insqhi(b, &p->free));
3210             }
3211             p->type = 0;
3212         }
3213
3214         iss = lib$remqti(&p->wait, &b);
3215         if (iss == LIB$_QUEWASEMP) {
3216             if (p->shut_on_empty) {
3217                 if (done) {
3218                     _ckvmssts(sys$dassgn(p->chan_out));
3219                     *p->pipe_done = TRUE;
3220                     _ckvmssts(sys$setef(pipe_ef));
3221                 } else {
3222                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3223                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3224                 }
3225                 return;
3226             }
3227             p->need_wake = TRUE;
3228             return;
3229         }
3230         _ckvmssts(iss);
3231         p->type = 1;
3232     } while (done);
3233
3234
3235     p->curr2 = b;
3236     if (b->eof) {
3237         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3238             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3239     } else {
3240         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3241             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3242     }
3243
3244     return;
3245
3246 }
3247
3248
3249 static pPipe
3250 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3251 {
3252     pPipe p;
3253     char mbx1[64], mbx2[64];
3254     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3255                                       DSC$K_CLASS_S, mbx1},
3256                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3257                                       DSC$K_CLASS_S, mbx2};
3258     unsigned int dviitm = DVI$_DEVBUFSIZ;
3259
3260     int n = sizeof(Pipe);
3261     _ckvmssts(lib$get_vm(&n, &p));
3262     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3263     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3264
3265     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3266     n = p->bufsize * sizeof(char);
3267     _ckvmssts(lib$get_vm(&n, &p->buf));
3268     p->shut_on_empty = FALSE;
3269     p->info   = 0;
3270     p->type   = 0;
3271     p->iosb.status = SS$_NORMAL;
3272 #if defined(PERL_IMPLICIT_CONTEXT)
3273     p->thx = aTHX;
3274 #endif
3275     pipe_infromchild_ast(p);
3276
3277     strcpy(wmbx, mbx1);
3278     strcpy(rmbx, mbx2);
3279     return p;
3280 }
3281
3282 static void
3283 pipe_infromchild_ast(pPipe p)
3284 {
3285     int iss = p->iosb.status;
3286     int eof = (iss == SS$_ENDOFFILE);
3287     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3288     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3289 #if defined(PERL_IMPLICIT_CONTEXT)
3290     pTHX = p->thx;
3291 #endif
3292
3293     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3294         _ckvmssts(sys$dassgn(p->chan_out));
3295         p->chan_out = 0;
3296     }
3297
3298     /* read completed:
3299             input shutdown if EOF from self (done or shut_on_empty)
3300             output shutdown if closing flag set (my_pclose)
3301             send data/eof from child or eof from self
3302             otherwise, re-read (snarf of data from child)
3303     */
3304
3305     if (p->type == 1) {
3306         p->type = 0;
3307         if (myeof && p->chan_in) {                  /* input shutdown */
3308             _ckvmssts(sys$dassgn(p->chan_in));
3309             p->chan_in = 0;
3310         }
3311
3312         if (p->chan_out) {
3313             if (myeof || kideof) {      /* pass EOF to parent */
3314                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3315                               pipe_infromchild_ast, p,
3316                               0, 0, 0, 0, 0, 0));
3317                 return;
3318             } else if (eof) {       /* eat EOF --- fall through to read*/
3319
3320             } else {                /* transmit data */
3321                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3322                               pipe_infromchild_ast,p,
3323                               p->buf, p->iosb.count, 0, 0, 0, 0));
3324                 return;
3325             }
3326         }
3327     }
3328
3329     /*  everything shut? flag as done */
3330
3331     if (!p->chan_in && !p->chan_out) {
3332         *p->pipe_done = TRUE;
3333         _ckvmssts(sys$setef(pipe_ef));
3334         return;
3335     }
3336
3337     /* write completed (or read, if snarfing from child)
3338             if still have input active,
3339                queue read...immediate mode if shut_on_empty so we get EOF if empty
3340             otherwise,
3341                check if Perl reading, generate EOFs as needed
3342     */
3343
3344     if (p->type == 0) {
3345         p->type = 1;
3346         if (p->chan_in) {
3347             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3348                           pipe_infromchild_ast,p,
3349                           p->buf, p->bufsize, 0, 0, 0, 0);
3350             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3351             _ckvmssts(iss);
3352         } else {           /* send EOFs for extra reads */
3353             p->iosb.status = SS$_ENDOFFILE;
3354             p->iosb.dvispec = 0;
3355             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3356                       0, 0, 0,
3357                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3358         }
3359     }
3360 }
3361
3362 static pPipe
3363 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3364 {
3365     pPipe p;
3366     char mbx[64];
3367     unsigned long dviitm = DVI$_DEVBUFSIZ;
3368     struct stat s;
3369     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3370                                       DSC$K_CLASS_S, mbx};
3371     int n = sizeof(Pipe);
3372
3373     /* things like terminals and mbx's don't need this filter */
3374     if (fd && fstat(fd,&s) == 0) {
3375         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3376         char device[65];
3377         unsigned short dev_len;
3378         struct dsc$descriptor_s d_dev;
3379         char * cptr;
3380         struct item_list_3 items[3];
3381         int status;
3382         unsigned short dvi_iosb[4];
3383
3384         cptr = getname(fd, out, 1);
3385         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3386         d_dev.dsc$a_pointer = out;
3387         d_dev.dsc$w_length = strlen(out);
3388         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3389         d_dev.dsc$b_class = DSC$K_CLASS_S;
3390
3391         items[0].len = 4;
3392         items[0].code = DVI$_DEVCHAR;
3393         items[0].bufadr = &devchar;
3394         items[0].retadr = NULL;
3395         items[1].len = 64;
3396         items[1].code = DVI$_FULLDEVNAM;
3397         items[1].bufadr = device;
3398         items[1].retadr = &dev_len;
3399         items[2].len = 0;
3400         items[2].code = 0;
3401
3402         status = sys$getdviw
3403                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3404         _ckvmssts(status);
3405         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3406             device[dev_len] = 0;
3407
3408             if (!(devchar & DEV$M_DIR)) {
3409                 strcpy(out, device);
3410                 return 0;
3411             }
3412         }
3413     }
3414
3415     _ckvmssts(lib$get_vm(&n, &p));
3416     p->fd_out = dup(fd);
3417     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3418     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3419     n = (p->bufsize+1) * sizeof(char);
3420     _ckvmssts(lib$get_vm(&n, &p->buf));
3421     p->shut_on_empty = FALSE;
3422     p->retry = 0;
3423     p->info  = 0;
3424     strcpy(out, mbx);
3425
3426     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3427                   pipe_mbxtofd_ast, p,
3428                   p->buf, p->bufsize, 0, 0, 0, 0));
3429
3430     return p;
3431 }
3432
3433 static void
3434 pipe_mbxtofd_ast(pPipe p)
3435 {
3436     int iss = p->iosb.status;
3437     int done = p->info->done;
3438     int iss2;
3439     int eof = (iss == SS$_ENDOFFILE);
3440     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3441     int err = !(iss&1) && !eof;
3442 #if defined(PERL_IMPLICIT_CONTEXT)
3443     pTHX = p->thx;
3444 #endif
3445
3446     if (done && myeof) {               /* end piping */
3447         close(p->fd_out);
3448         sys$dassgn(p->chan_in);
3449         *p->pipe_done = TRUE;
3450         _ckvmssts(sys$setef(pipe_ef));
3451         return;
3452     }
3453
3454     if (!err && !eof) {             /* good data to send to file */
3455         p->buf[p->iosb.count] = '\n';
3456         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3457         if (iss2 < 0) {
3458             p->retry++;
3459             if (p->retry < MAX_RETRY) {
3460                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3461                 return;
3462             }
3463         }
3464         p->retry = 0;
3465     } else if (err) {
3466         _ckvmssts(iss);
3467     }
3468
3469
3470     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3471           pipe_mbxtofd_ast, p,
3472           p->buf, p->bufsize, 0, 0, 0, 0);
3473     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3474     _ckvmssts(iss);
3475 }
3476
3477
3478 typedef struct _pipeloc     PLOC;
3479 typedef struct _pipeloc*   pPLOC;
3480
3481 struct _pipeloc {
3482     pPLOC   next;
3483     char    dir[NAM$C_MAXRSS+1];
3484 };
3485 static pPLOC  head_PLOC = 0;
3486
3487 void
3488 free_pipelocs(pTHX_ void *head)
3489 {
3490     pPLOC p, pnext;
3491     pPLOC *pHead = (pPLOC *)head;
3492
3493     p = *pHead;
3494     while (p) {
3495         pnext = p->next;
3496         PerlMem_free(p);
3497         p = pnext;
3498     }
3499     *pHead = 0;
3500 }
3501
3502 static void
3503 store_pipelocs(pTHX)
3504 {
3505     int    i;
3506     pPLOC  p;
3507     AV    *av = 0;
3508     SV    *dirsv;
3509     GV    *gv;
3510     char  *dir, *x;
3511     char  *unixdir;
3512     char  temp[NAM$C_MAXRSS+1];
3513     STRLEN n_a;
3514
3515     if (head_PLOC)
3516         free_pipelocs(aTHX_ &head_PLOC);
3517
3518 /*  the . directory from @INC comes last */
3519
3520     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3521     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3522     p->next = head_PLOC;
3523     head_PLOC = p;
3524     strcpy(p->dir,"./");
3525
3526 /*  get the directory from $^X */
3527
3528     unixdir = PerlMem_malloc(VMS_MAXRSS);
3529     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3530
3531 #ifdef PERL_IMPLICIT_CONTEXT
3532     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3533 #else
3534     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3535 #endif
3536         strcpy(temp, PL_origargv[0]);
3537         x = strrchr(temp,']');
3538         if (x == NULL) {
3539         x = strrchr(temp,'>');
3540           if (x == NULL) {
3541             /* It could be a UNIX path */
3542             x = strrchr(temp,'/');
3543           }
3544         }
3545         if (x)
3546           x[1] = '\0';
3547         else {
3548           /* Got a bare name, so use default directory */
3549           temp[0] = '.';
3550           temp[1] = '\0';
3551         }
3552
3553         if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3554             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3555             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3556             p->next = head_PLOC;
3557             head_PLOC = p;
3558             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3559             p->dir[NAM$C_MAXRSS] = '\0';
3560         }
3561     }
3562
3563 /*  reverse order of @INC entries, skip "." since entered above */
3564
3565 #ifdef PERL_IMPLICIT_CONTEXT
3566     if (aTHX)
3567 #endif
3568     if (PL_incgv) av = GvAVn(PL_incgv);
3569
3570     for (i = 0; av && i <= AvFILL(av); i++) {
3571         dirsv = *av_fetch(av,i,TRUE);
3572
3573         if (SvROK(dirsv)) continue;
3574         dir = SvPVx(dirsv,n_a);
3575         if (strcmp(dir,".") == 0) continue;
3576         if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3577             continue;
3578
3579         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3580         p->next = head_PLOC;
3581         head_PLOC = p;
3582         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3583         p->dir[NAM$C_MAXRSS] = '\0';
3584     }
3585
3586 /* most likely spot (ARCHLIB) put first in the list */
3587
3588 #ifdef ARCHLIB_EXP
3589     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3590         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3591         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3592         p->next = head_PLOC;
3593         head_PLOC = p;
3594         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3595         p->dir[NAM$C_MAXRSS] = '\0';
3596     }
3597 #endif
3598     PerlMem_free(unixdir);
3599 }
3600
3601 static I32
3602 Perl_cando_by_name_int
3603    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3604 #if !defined(PERL_IMPLICIT_CONTEXT)
3605 #define cando_by_name_int               Perl_cando_by_name_int
3606 #else
3607 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3608 #endif
3609
3610 static char *
3611 find_vmspipe(pTHX)
3612 {
3613     static int   vmspipe_file_status = 0;
3614     static char  vmspipe_file[NAM$C_MAXRSS+1];
3615
3616     /* already found? Check and use ... need read+execute permission */
3617
3618     if (vmspipe_file_status == 1) {
3619         if (cando_by_name_int(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             return vmspipe_file;
3623         }
3624         vmspipe_file_status = 0;
3625     }
3626
3627     /* scan through stored @INC, $^X */
3628
3629     if (vmspipe_file_status == 0) {
3630         char file[NAM$C_MAXRSS+1];
3631         pPLOC  p = head_PLOC;
3632
3633         while (p) {
3634             char * exp_res;
3635             int dirlen;
3636             strcpy(file, p->dir);
3637             dirlen = strlen(file);
3638             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3639             file[NAM$C_MAXRSS] = '\0';
3640             p = p->next;
3641
3642             exp_res = do_rmsexpand
3643                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3644             if (!exp_res) continue;
3645
3646             if (cando_by_name_int
3647                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3648              && cando_by_name_int
3649                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3650                 vmspipe_file_status = 1;
3651                 return vmspipe_file;
3652             }
3653         }
3654         vmspipe_file_status = -1;   /* failed, use tempfiles */
3655     }
3656
3657     return 0;
3658 }
3659
3660 static FILE *
3661 vmspipe_tempfile(pTHX)
3662 {
3663     char file[NAM$C_MAXRSS+1];
3664     FILE *fp;
3665     static int index = 0;
3666     Stat_t s0, s1;
3667     int cmp_result;
3668
3669     /* create a tempfile */
3670
3671     /* we can't go from   W, shr=get to  R, shr=get without
3672        an intermediate vulnerable state, so don't bother trying...
3673
3674        and lib$spawn doesn't shr=put, so have to close the write
3675
3676        So... match up the creation date/time and the FID to
3677        make sure we're dealing with the same file
3678
3679     */
3680
3681     index++;
3682     if (!decc_filename_unix_only) {
3683       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3684       fp = fopen(file,"w");
3685       if (!fp) {
3686         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3687         fp = fopen(file,"w");
3688         if (!fp) {
3689             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3690             fp = fopen(file,"w");
3691         }
3692       }
3693      }
3694      else {
3695       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3696       fp = fopen(file,"w");
3697       if (!fp) {
3698         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3699         fp = fopen(file,"w");
3700         if (!fp) {
3701           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3702           fp = fopen(file,"w");
3703         }
3704       }
3705     }
3706     if (!fp) return 0;  /* we're hosed */
3707
3708     fprintf(fp,"$! 'f$verify(0)'\n");
3709     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3710     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3711     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3712     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3713     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3714     fprintf(fp,"$ perl_del    = \"delete\"\n");
3715     fprintf(fp,"$ pif         = \"if\"\n");
3716     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3717     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3718     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3719     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3720     fprintf(fp,"$!  --- build command line to get max possible length\n");
3721     fprintf(fp,"$c=perl_popen_cmd0\n");
3722     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3723     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3724     fprintf(fp,"$x=perl_popen_cmd3\n");
3725     fprintf(fp,"$c=c+x\n");
3726     fprintf(fp,"$ perl_on\n");
3727     fprintf(fp,"$ 'c'\n");
3728     fprintf(fp,"$ perl_status = $STATUS\n");
3729     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3730     fprintf(fp,"$ perl_exit 'perl_status'\n");
3731     fsync(fileno(fp));
3732
3733     fgetname(fp, file, 1);
3734     fstat(fileno(fp), (struct stat *)&s0);
3735     fclose(fp);
3736
3737     if (decc_filename_unix_only)
3738         do_tounixspec(file, file, 0, NULL);
3739     fp = fopen(file,"r","shr=get");
3740     if (!fp) return 0;
3741     fstat(fileno(fp), (struct stat *)&s1);
3742
3743     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3744     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3745         fclose(fp);
3746         return 0;
3747     }
3748
3749     return fp;
3750 }
3751
3752
3753 #ifdef USE_VMS_DECTERM
3754
3755 static int vms_is_syscommand_xterm(void)
3756 {
3757     const static struct dsc$descriptor_s syscommand_dsc =
3758       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3759
3760     const static struct dsc$descriptor_s decwdisplay_dsc =
3761       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3762
3763     struct item_list_3 items[2];
3764     unsigned short dvi_iosb[4];
3765     unsigned long devchar;
3766     unsigned long devclass;
3767     int status;
3768
3769     /* Very simple check to guess if sys$command is a decterm? */
3770     /* First see if the DECW$DISPLAY: device exists */
3771     items[0].len = 4;
3772     items[0].code = DVI$_DEVCHAR;
3773     items[0].bufadr = &devchar;
3774     items[0].retadr = NULL;
3775     items[1].len = 0;
3776     items[1].code = 0;
3777
3778     status = sys$getdviw
3779         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3780
3781     if ($VMS_STATUS_SUCCESS(status)) {
3782         status = dvi_iosb[0];
3783     }
3784
3785     if (!$VMS_STATUS_SUCCESS(status)) {
3786         SETERRNO(EVMSERR, status);
3787         return -1;
3788     }
3789
3790     /* If it does, then for now assume that we are on a workstation */
3791     /* Now verify that SYS$COMMAND is a terminal */
3792     /* for creating the debugger DECTerm */
3793
3794     items[0].len = 4;
3795     items[0].code = DVI$_DEVCLASS;
3796     items[0].bufadr = &devclass;
3797     items[0].retadr = NULL;
3798     items[1].len = 0;
3799     items[1].code = 0;
3800
3801     status = sys$getdviw
3802         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3803
3804     if ($VMS_STATUS_SUCCESS(status)) {
3805         status = dvi_iosb[0];
3806     }
3807
3808     if (!$VMS_STATUS_SUCCESS(status)) {
3809         SETERRNO(EVMSERR, status);
3810         return -1;
3811     }
3812     else {
3813         if (devclass == DC$_TERM) {
3814             return 0;
3815         }
3816     }
3817     return -1;
3818 }
3819
3820 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3821 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3822 {
3823     int status;
3824     int ret_stat;
3825     char * ret_char;
3826     char device_name[65];
3827     unsigned short device_name_len;
3828     struct dsc$descriptor_s customization_dsc;
3829     struct dsc$descriptor_s device_name_dsc;
3830     const char * cptr;
3831     char * tptr;
3832     char customization[200];
3833     char title[40];
3834     pInfo info = NULL;
3835     char mbx1[64];
3836     unsigned short p_chan;
3837     int n;
3838     unsigned short iosb[4];
3839     struct item_list_3 items[2];
3840     const char * cust_str =
3841         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3842     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3843                                           DSC$K_CLASS_S, mbx1};
3844
3845     ret_char = strstr(cmd," xterm ");
3846     if (ret_char == NULL)
3847         return NULL;
3848     cptr = ret_char + 7;
3849     ret_char = strstr(cmd,"tty");
3850     if (ret_char == NULL)
3851         return NULL;
3852     ret_char = strstr(cmd,"sleep");
3853     if (ret_char == NULL)
3854         return NULL;
3855
3856     /* Are we on a workstation? */
3857     /* to do: capture the rows / columns and pass their properties */
3858     ret_stat = vms_is_syscommand_xterm();
3859     if (ret_stat < 0)
3860         return NULL;
3861
3862     /* Make the title: */
3863     ret_char = strstr(cptr,"-title");
3864     if (ret_char != NULL) {
3865         while ((*cptr != 0) && (*cptr != '\"')) {
3866             cptr++;
3867         }
3868         if (*cptr == '\"')
3869             cptr++;
3870         n = 0;
3871         while ((*cptr != 0) && (*cptr != '\"')) {
3872             title[n] = *cptr;
3873             n++;
3874             if (n == 39) {
3875                 title[39] == 0;
3876                 break;
3877             }
3878             cptr++;
3879         }
3880         title[n] = 0;
3881     }
3882     else {
3883             /* Default title */
3884             strcpy(title,"Perl Debug DECTerm");
3885     }
3886     sprintf(customization, cust_str, title);
3887
3888     customization_dsc.dsc$a_pointer = customization;
3889     customization_dsc.dsc$w_length = strlen(customization);
3890     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3891     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3892
3893     device_name_dsc.dsc$a_pointer = device_name;
3894     device_name_dsc.dsc$w_length = sizeof device_name -1;
3895     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3896     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3897
3898     device_name_len = 0;
3899
3900     /* Try to create the window */
3901      status = decw$term_port
3902        (NULL,
3903         NULL,
3904         &customization_dsc,
3905         &device_name_dsc,
3906         &device_name_len,
3907         NULL,
3908         NULL,
3909         NULL);
3910     if (!$VMS_STATUS_SUCCESS(status)) {
3911         SETERRNO(EVMSERR, status);
3912         return NULL;
3913     }
3914
3915     device_name[device_name_len] = '\0';
3916
3917     /* Need to set this up to look like a pipe for cleanup */
3918     n = sizeof(Info);
3919     status = lib$get_vm(&n, &info);
3920     if (!$VMS_STATUS_SUCCESS(status)) {
3921         SETERRNO(ENOMEM, status);
3922         return NULL;
3923     }
3924
3925     info->mode = *mode;
3926     info->done = FALSE;
3927     info->completion = 0;
3928     info->closing    = FALSE;
3929     info->in         = 0;
3930     info->out        = 0;
3931     info->err        = 0;
3932     info->fp         = Nullfp;
3933     info->useFILE    = 0;
3934     info->waiting    = 0;
3935     info->in_done    = TRUE;
3936     info->out_done   = TRUE;
3937     info->err_done   = TRUE;
3938
3939     /* Assign a channel on this so that it will persist, and not login */
3940     /* We stash this channel in the info structure for reference. */
3941     /* The created xterm self destructs when the last channel is removed */
3942     /* and it appears that perl5db.pl (perl debugger) does this routinely */
3943     /* So leave this assigned. */
3944     device_name_dsc.dsc$w_length = device_name_len;
3945     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
3946     if (!$VMS_STATUS_SUCCESS(status)) {
3947         SETERRNO(EVMSERR, status);
3948         return NULL;
3949     }
3950     info->xchan_valid = 1;
3951
3952     /* Now create a mailbox to be read by the application */
3953
3954     create_mbx(aTHX_ &p_chan, &d_mbx1);
3955
3956     /* write the name of the created terminal to the mailbox */
3957     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
3958             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
3959
3960     if (!$VMS_STATUS_SUCCESS(status)) {
3961         SETERRNO(EVMSERR, status);
3962         return NULL;
3963     }
3964
3965     info->fp  = PerlIO_open(mbx1, mode);
3966
3967     /* Done with this channel */
3968     sys$dassgn(p_chan);
3969
3970     /* If any errors, then clean up */
3971     if (!info->fp) {
3972         n = sizeof(Info);
3973         _ckvmssts(lib$free_vm(&n, &info));
3974         return NULL;
3975         }
3976
3977     /* All done */
3978     return info->fp;
3979 }
3980 #endif
3981
3982 static PerlIO *
3983 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3984 {
3985     static int handler_set_up = FALSE;
3986     unsigned long int sts, flags = CLI$M_NOWAIT;
3987     /* The use of a GLOBAL table (as was done previously) rendered
3988      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3989      * environment.  Hence we've switched to LOCAL symbol table.
3990      */
3991     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3992     int j, wait = 0, n;
3993     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3994     char *in, *out, *err, mbx[512];
3995     FILE *tpipe = 0;
3996     char tfilebuf[NAM$C_MAXRSS+1];
3997     pInfo info = NULL;
3998     char cmd_sym_name[20];
3999     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4000                                       DSC$K_CLASS_S, symbol};
4001     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4002                                       DSC$K_CLASS_S, 0};
4003     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4004                                       DSC$K_CLASS_S, cmd_sym_name};
4005     struct dsc$descriptor_s *vmscmd;
4006     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4007     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4008     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4009
4010 #ifdef USE_VMS_DECTERM
4011     /* Check here for Xterm create request.  This means looking for
4012      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4013      *  is possible to create an xterm.
4014      */
4015     if (*in_mode == 'r') {
4016         PerlIO * xterm_fd;
4017
4018         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4019         if (xterm_fd != Nullfp)
4020             return xterm_fd;
4021     }
4022 #endif
4023
4024     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4025
4026     /* once-per-program initialization...
4027        note that the SETAST calls and the dual test of pipe_ef
4028        makes sure that only the FIRST thread through here does
4029        the initialization...all other threads wait until it's
4030        done.
4031
4032        Yeah, uglier than a pthread call, it's got all the stuff inline
4033        rather than in a separate routine.
4034     */
4035
4036     if (!pipe_ef) {
4037         _ckvmssts(sys$setast(0));
4038         if (!pipe_ef) {
4039             unsigned long int pidcode = JPI$_PID;
4040             $DESCRIPTOR(d_delay, RETRY_DELAY);
4041             _ckvmssts(lib$get_ef(&pipe_ef));
4042             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4043             _ckvmssts(sys$bintim(&d_delay, delaytime));
4044         }
4045         if (!handler_set_up) {
4046           _ckvmssts(sys$dclexh(&pipe_exitblock));
4047           handler_set_up = TRUE;
4048         }
4049         _ckvmssts(sys$setast(1));
4050     }
4051
4052     /* see if we can find a VMSPIPE.COM */
4053
4054     tfilebuf[0] = '@';
4055     vmspipe = find_vmspipe(aTHX);
4056     if (vmspipe) {
4057         strcpy(tfilebuf+1,vmspipe);
4058     } else {        /* uh, oh...we're in tempfile hell */
4059         tpipe = vmspipe_tempfile(aTHX);
4060         if (!tpipe) {       /* a fish popular in Boston */
4061             if (ckWARN(WARN_PIPE)) {
4062                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4063             }
4064         return Nullfp;
4065         }
4066         fgetname(tpipe,tfilebuf+1,1);
4067     }
4068     vmspipedsc.dsc$a_pointer = tfilebuf;
4069     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4070
4071     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4072     if (!(sts & 1)) {
4073       switch (sts) {
4074         case RMS$_FNF:  case RMS$_DNF:
4075           set_errno(ENOENT); break;
4076         case RMS$_DIR:
4077           set_errno(ENOTDIR); break;
4078         case RMS$_DEV:
4079           set_errno(ENODEV); break;
4080         case RMS$_PRV:
4081           set_errno(EACCES); break;
4082         case RMS$_SYN:
4083           set_errno(EINVAL); break;
4084         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4085           set_errno(E2BIG); break;
4086         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4087           _ckvmssts(sts); /* fall through */
4088         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4089           set_errno(EVMSERR);
4090       }
4091       set_vaxc_errno(sts);
4092       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4093         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4094       }
4095       *psts = sts;
4096       return Nullfp;
4097     }
4098     n = sizeof(Info);
4099     _ckvmssts(lib$get_vm(&n, &info));
4100
4101     strcpy(mode,in_mode);
4102     info->mode = *mode;
4103     info->done = FALSE;
4104     info->completion = 0;
4105     info->closing    = FALSE;
4106     info->in         = 0;
4107     info->out        = 0;
4108     info->err        = 0;
4109     info->fp         = Nullfp;
4110     info->useFILE    = 0;
4111     info->waiting    = 0;
4112     info->in_done    = TRUE;
4113     info->out_done   = TRUE;
4114     info->err_done   = TRUE;
4115     info->xchan      = 0;
4116     info->xchan_valid = 0;
4117
4118     in = PerlMem_malloc(VMS_MAXRSS);
4119     if (in == NULL) _ckvmssts(SS$_INSFMEM);
4120     out = PerlMem_malloc(VMS_MAXRSS);
4121     if (out == NULL) _ckvmssts(SS$_INSFMEM);
4122     err = PerlMem_malloc(VMS_MAXRSS);
4123     if (err == NULL) _ckvmssts(SS$_INSFMEM);
4124
4125     in[0] = out[0] = err[0] = '\0';
4126
4127     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4128         info->useFILE = 1;
4129         strcpy(p,p+1);
4130     }
4131     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4132         wait = 1;
4133         strcpy(p,p+1);
4134     }
4135
4136     if (*mode == 'r') {             /* piping from subroutine */
4137
4138         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4139         if (info->out) {
4140             info->out->pipe_done = &info->out_done;
4141             info->out_done = FALSE;
4142             info->out->info = info;
4143         }
4144         if (!info->useFILE) {
4145             info->fp  = PerlIO_open(mbx, mode);
4146         } else {
4147             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4148             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4149         }
4150
4151         if (!info->fp && info->out) {
4152             sys$cancel(info->out->chan_out);
4153
4154             while (!info->out_done) {
4155                 int done;
4156                 _ckvmssts(sys$setast(0));
4157                 done = info->out_done;
4158                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4159                 _ckvmssts(sys$setast(1));
4160                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4161             }
4162
4163             if (info->out->buf) {
4164                 n = info->out->bufsize * sizeof(char);
4165                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4166             }
4167             n = sizeof(Pipe);
4168             _ckvmssts(lib$free_vm(&n, &info->out));
4169             n = sizeof(Info);
4170             _ckvmssts(lib$free_vm(&n, &info));
4171             *psts = RMS$_FNF;
4172             return Nullfp;
4173         }
4174
4175         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4176         if (info->err) {
4177             info->err->pipe_done = &info->err_done;
4178             info->err_done = FALSE;
4179             info->err->info = info;
4180         }
4181
4182     } else if (*mode == 'w') {      /* piping to subroutine */
4183
4184         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4185         if (info->out) {
4186             info->out->pipe_done = &info->out_done;
4187             info->out_done = FALSE;
4188             info->out->info = info;
4189         }
4190
4191         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4192         if (info->err) {
4193             info->err->pipe_done = &info->err_done;
4194             info->err_done = FALSE;
4195             info->err->info = info;
4196         }
4197
4198         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4199         if (!info->useFILE) {
4200             info->fp  = PerlIO_open(mbx, mode);
4201         } else {
4202             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4203             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4204         }
4205
4206         if (info->in) {
4207             info->in->pipe_done = &info->in_done;
4208             info->in_done = FALSE;
4209             info->in->info = info;
4210         }
4211
4212         /* error cleanup */
4213         if (!info->fp && info->in) {
4214             info->done = TRUE;
4215             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4216                               0, 0, 0, 0, 0, 0, 0, 0));
4217
4218             while (!info->in_done) {
4219                 int done;
4220                 _ckvmssts(sys$setast(0));
4221                 done = info->in_done;
4222                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4223                 _ckvmssts(sys$setast(1));
4224                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4225             }
4226
4227             if (info->in->buf) {
4228                 n = info->in->bufsize * sizeof(char);
4229                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4230             }
4231             n = sizeof(Pipe);
4232             _ckvmssts(lib$free_vm(&n, &info->in));
4233             n = sizeof(Info);
4234             _ckvmssts(lib$free_vm(&n, &info));
4235             *psts = RMS$_FNF;
4236             return Nullfp;
4237         }
4238
4239
4240     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4241         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4242         if (info->out) {
4243             info->out->pipe_done = &info->out_done;
4244             info->out_done = FALSE;
4245             info->out->info = info;
4246         }
4247
4248         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4249         if (info->err) {
4250             info->err->pipe_done = &info->err_done;
4251             info->err_done = FALSE;
4252             info->err->info = info;
4253         }
4254     }
4255
4256     symbol[MAX_DCL_SYMBOL] = '\0';
4257
4258     strncpy(symbol, in, MAX_DCL_SYMBOL);
4259     d_symbol.dsc$w_length = strlen(symbol);
4260     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4261
4262     strncpy(symbol, err, MAX_DCL_SYMBOL);
4263     d_symbol.dsc$w_length = strlen(symbol);
4264     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4265
4266     strncpy(symbol, out, MAX_DCL_SYMBOL);
4267     d_symbol.dsc$w_length = strlen(symbol);
4268     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4269
4270     /* Done with the names for the pipes */
4271     PerlMem_free(err);
4272     PerlMem_free(out);
4273     PerlMem_free(in);
4274
4275     p = vmscmd->dsc$a_pointer;
4276     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4277     if (*p == '$') p++;                         /* remove leading $ */
4278     while (*p == ' ' || *p == '\t') p++;
4279
4280     for (j = 0; j < 4; j++) {
4281         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4282         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4283
4284     strncpy(symbol, p, MAX_DCL_SYMBOL);
4285     d_symbol.dsc$w_length = strlen(symbol);
4286     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4287
4288         if (strlen(p) > MAX_DCL_SYMBOL) {
4289             p += MAX_DCL_SYMBOL;
4290         } else {
4291             p += strlen(p);
4292         }
4293     }
4294     _ckvmssts(sys$setast(0));
4295     info->next=open_pipes;  /* prepend to list */
4296     open_pipes=info;
4297     _ckvmssts(sys$setast(1));
4298     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4299      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4300      * have SYS$COMMAND if we need it.
4301      */
4302     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4303                       0, &info->pid, &info->completion,
4304                       0, popen_completion_ast,info,0,0,0));
4305
4306     /* if we were using a tempfile, close it now */
4307
4308     if (tpipe) fclose(tpipe);
4309
4310     /* once the subprocess is spawned, it has copied the symbols and
4311        we can get rid of ours */
4312
4313     for (j = 0; j < 4; j++) {
4314         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4315         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4316     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4317     }
4318     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4319     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4320     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4321     vms_execfree(vmscmd);
4322
4323 #ifdef PERL_IMPLICIT_CONTEXT
4324     if (aTHX)
4325 #endif
4326     PL_forkprocess = info->pid;
4327
4328     if (wait) {
4329          int done = 0;
4330          while (!done) {
4331              _ckvmssts(sys$setast(0));
4332              done = info->done;
4333              if (!done) _ckvmssts(sys$clref(pipe_ef));
4334              _ckvmssts(sys$setast(1));
4335              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4336          }
4337         *psts = info->completion;
4338 /* Caller thinks it is open and tries to close it. */
4339 /* This causes some problems, as it changes the error status */
4340 /*        my_pclose(info->fp); */
4341     } else {
4342         *psts = SS$_NORMAL;
4343     }
4344     return info->fp;
4345 }  /* end of safe_popen */
4346
4347
4348 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4349 PerlIO *
4350 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4351 {
4352     int sts;
4353     TAINT_ENV();
4354     TAINT_PROPER("popen");
4355     PERL_FLUSHALL_FOR_CHILD;
4356     return safe_popen(aTHX_ cmd,mode,&sts);
4357 }
4358
4359 /*}}}*/
4360
4361 /*{{{  I32 my_pclose(PerlIO *fp)*/
4362 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4363 {
4364     pInfo info, last = NULL;
4365     unsigned long int retsts;
4366     int done, iss, n;
4367     int status;
4368
4369     for (info = open_pipes; info != NULL; last = info, info = info->next)
4370         if (info->fp == fp) break;
4371
4372     if (info == NULL) {  /* no such pipe open */
4373       set_errno(ECHILD); /* quoth POSIX */
4374       set_vaxc_errno(SS$_NONEXPR);
4375       return -1;
4376     }
4377
4378     /* If we were writing to a subprocess, insure that someone reading from
4379      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4380      * produce an EOF record in the mailbox.
4381      *
4382      *  well, at least sometimes it *does*, so we have to watch out for
4383      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4384      */
4385      if (info->fp) {
4386         if (!info->useFILE
4387 #if defined(USE_ITHREADS)
4388           && my_perl
4389 #endif
4390           && PL_perlio_fd_refcnt)
4391             PerlIO_flush(info->fp);
4392         else
4393             fflush((FILE *)info->fp);
4394     }
4395
4396     _ckvmssts(sys$setast(0));
4397      info->closing = TRUE;
4398      done = info->done && info->in_done && info->out_done && info->err_done;
4399      /* hanging on write to Perl's input? cancel it */
4400      if (info->mode == 'r' && info->out && !info->out_done) {
4401         if (info->out->chan_out) {
4402             _ckvmssts(sys$cancel(info->out->chan_out));
4403             if (!info->out->chan_in) {   /* EOF generation, need AST */
4404                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4405             }
4406         }
4407      }
4408      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4409          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4410                            0, 0, 0, 0, 0, 0));
4411     _ckvmssts(sys$setast(1));
4412     if (info->fp) {
4413      if (!info->useFILE
4414 #if defined(USE_ITHREADS)
4415          && my_perl
4416 #endif
4417          && PL_perlio_fd_refcnt)
4418         PerlIO_close(info->fp);
4419      else
4420         fclose((FILE *)info->fp);
4421     }
4422      /*
4423         we have to wait until subprocess completes, but ALSO wait until all
4424         the i/o completes...otherwise we'll be freeing the "info" structure
4425         that the i/o ASTs could still be using...
4426      */
4427
4428      while (!done) {
4429          _ckvmssts(sys$setast(0));
4430          done = info->done && info->in_done && info->out_done && info->err_done;
4431          if (!done) _ckvmssts(sys$clref(pipe_ef));
4432          _ckvmssts(sys$setast(1));
4433          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4434      }
4435      retsts = info->completion;
4436
4437     /* remove from list of open pipes */
4438     _ckvmssts(sys$setast(0));
4439     if (last) last->next = info->next;
4440     else open_pipes = info->next;
4441     _ckvmssts(sys$setast(1));
4442
4443     /* free buffers and structures */
4444
4445     if (info->in) {
4446         if (info->in->buf) {
4447             n = info->in->bufsize * sizeof(char);
4448             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4449         }
4450         n = sizeof(Pipe);
4451         _ckvmssts(lib$free_vm(&n, &info->in));
4452     }
4453     if (info->out) {
4454         if (info->out->buf) {
4455             n = info->out->bufsize * sizeof(char);
4456             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4457         }
4458         n = sizeof(Pipe);
4459         _ckvmssts(lib$free_vm(&n, &info->out));
4460     }
4461     if (info->err) {
4462         if (info->err->buf) {
4463             n = info->err->bufsize * sizeof(char);
4464             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4465         }
4466         n = sizeof(Pipe);
4467         _ckvmssts(lib$free_vm(&n, &info->err));
4468     }
4469     n = sizeof(Info);
4470     _ckvmssts(lib$free_vm(&n, &info));
4471
4472     return retsts;
4473
4474 }  /* end of my_pclose() */
4475
4476 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4477   /* Roll our own prototype because we want this regardless of whether
4478    * _VMS_WAIT is defined.
4479    */
4480   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4481 #endif
4482 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4483    created with popen(); otherwise partially emulate waitpid() unless
4484    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4485    Also check processes not considered by the CRTL waitpid().
4486  */
4487 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4488 Pid_t
4489 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4490 {
4491     pInfo info;
4492     int done;
4493     int sts;
4494     int j;
4495
4496     if (statusp) *statusp = 0;
4497
4498     for (info = open_pipes; info != NULL; info = info->next)
4499         if (info->pid == pid) break;
4500
4501     if (info != NULL) {  /* we know about this child */
4502       while (!info->done) {
4503           _ckvmssts(sys$setast(0));
4504           done = info->done;
4505           if (!done) _ckvmssts(sys$clref(pipe_ef));
4506           _ckvmssts(sys$setast(1));
4507           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4508       }
4509
4510       if (statusp) *statusp = info->completion;
4511       return pid;
4512     }
4513
4514     /* child that already terminated? */
4515
4516     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4517         if (closed_list[j].pid == pid) {
4518             if (statusp) *statusp = closed_list[j].completion;
4519             return pid;
4520         }
4521     }
4522
4523     /* fall through if this child is not one of our own pipe children */
4524
4525 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4526
4527       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4528        * in 7.2 did we get a version that fills in the VMS completion
4529        * status as Perl has always tried to do.
4530        */
4531
4532       sts = __vms_waitpid( pid, statusp, flags );
4533
4534       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4535          return sts;
4536
4537       /* If the real waitpid tells us the child does not exist, we
4538        * fall through here to implement waiting for a child that
4539        * was created by some means other than exec() (say, spawned
4540        * from DCL) or to wait for a process that is not a subprocess
4541        * of the current process.
4542        */
4543
4544 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4545
4546     {
4547       $DESCRIPTOR(intdsc,"0 00:00:01");
4548       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4549       unsigned long int pidcode = JPI$_PID, mypid;
4550       unsigned long int interval[2];
4551       unsigned int jpi_iosb[2];
4552       struct itmlst_3 jpilist[2] = {
4553           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4554           {                      0,         0,                 0, 0}
4555       };
4556
4557       if (pid <= 0) {
4558         /* Sorry folks, we don't presently implement rooting around for
4559            the first child we can find, and we definitely don't want to
4560            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4561          */
4562         set_errno(ENOTSUP);
4563         return -1;
4564       }
4565
4566       /* Get the owner of the child so I can warn if it's not mine. If the
4567        * process doesn't exist or I don't have the privs to look at it,
4568        * I can go home early.
4569        */
4570       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4571       if (sts & 1) sts = jpi_iosb[0];
4572       if (!(sts & 1)) {
4573         switch (sts) {
4574             case SS$_NONEXPR:
4575                 set_errno(ECHILD);
4576                 break;
4577             case SS$_NOPRIV:
4578                 set_errno(EACCES);
4579                 break;
4580             default:
4581                 _ckvmssts(sts);
4582         }
4583         set_vaxc_errno(sts);
4584         return -1;
4585       }
4586
4587       if (ckWARN(WARN_EXEC)) {
4588         /* remind folks they are asking for non-standard waitpid behavior */
4589         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4590         if (ownerpid != mypid)
4591           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4592                       "waitpid: process %x is not a child of process %x",
4593                       pid,mypid);
4594       }
4595
4596       /* simply check on it once a second until it's not there anymore. */
4597
4598       _ckvmssts(sys$bintim(&intdsc,interval));
4599       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4600             _ckvmssts(sys$schdwk(0,0,interval,0));
4601             _ckvmssts(sys$hiber());
4602       }
4603       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4604
4605       _ckvmssts(sts);
4606       return pid;
4607     }
4608 }  /* end of waitpid() */
4609 /*}}}*/
4610 /*}}}*/
4611 /*}}}*/
4612
4613 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4614 char *
4615 my_gconvert(double val, int ndig, int trail, char *buf)
4616 {
4617   static char __gcvtbuf[DBL_DIG+1];
4618   char *loc;
4619
4620   loc = buf ? buf : __gcvtbuf;
4621
4622 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4623   if (val < 1) {
4624     sprintf(loc,"%.*g",ndig,val);
4625     return loc;
4626   }
4627 #endif
4628
4629   if (val) {
4630     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4631     return gcvt(val,ndig,loc);
4632   }
4633   else {
4634     loc[0] = '0'; loc[1] = '\0';
4635     return loc;
4636   }
4637
4638 }
4639 /*}}}*/
4640
4641 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4642 static int rms_free_search_context(struct FAB * fab)
4643 {
4644 struct NAM * nam;
4645
4646     nam = fab->fab$l_nam;
4647     nam->nam$b_nop |= NAM$M_SYNCHK;
4648     nam->nam$l_rlf = NULL;
4649     fab->fab$b_dns = 0;
4650     return sys$parse(fab, NULL, NULL);
4651 }
4652
4653 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4654 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4655 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4656 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4657 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4658 #define rms_nam_esll(nam) nam.nam$b_esl
4659 #define rms_nam_esl(nam) nam.nam$b_esl
4660 #define rms_nam_name(nam) nam.nam$l_name
4661 #define rms_nam_namel(nam) nam.nam$l_name
4662 #define rms_nam_type(nam) nam.nam$l_type
4663 #define rms_nam_typel(nam) nam.nam$l_type
4664 #define rms_nam_ver(nam) nam.nam$l_ver
4665 #define rms_nam_verl(nam) nam.nam$l_ver
4666 #define rms_nam_rsll(nam) nam.nam$b_rsl
4667 #define rms_nam_rsl(nam) nam.nam$b_rsl
4668 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4669 #define rms_set_fna(fab, nam, name, size) \
4670         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4671 #define rms_get_fna(fab, nam) fab.fab$l_fna
4672 #define rms_set_dna(fab, nam, name, size) \
4673         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4674 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4675 #define rms_set_esa(fab, nam, name, size) \
4676         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4677 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4678         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4679 #define rms_set_rsa(nam, name, size) \
4680         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4681 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4682         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4683 #define rms_nam_name_type_l_size(nam) \
4684         (nam.nam$b_name + nam.nam$b_type)
4685 #else
4686 static int rms_free_search_context(struct FAB * fab)
4687 {
4688 struct NAML * nam;
4689
4690     nam = fab->fab$l_naml;
4691     nam->naml$b_nop |= NAM$M_SYNCHK;
4692     nam->naml$l_rlf = NULL;
4693     nam->naml$l_long_defname_size = 0;
4694
4695     fab->fab$b_dns = 0;
4696     return sys$parse(fab, NULL, NULL);
4697 }
4698
4699 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4700 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4701 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4702 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4703 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4704 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4705 #define rms_nam_esl(nam) nam.naml$b_esl
4706 #define rms_nam_name(nam) nam.naml$l_name
4707 #define rms_nam_namel(nam) nam.naml$l_long_name
4708 #define rms_nam_type(nam) nam.naml$l_type
4709 #define rms_nam_typel(nam) nam.naml$l_long_type
4710 #define rms_nam_ver(nam) nam.naml$l_ver
4711 #define rms_nam_verl(nam) nam.naml$l_long_ver
4712 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4713 #define rms_nam_rsl(nam) nam.naml$b_rsl
4714 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4715 #define rms_set_fna(fab, nam, name, size) \
4716         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4717         nam.naml$l_long_filename_size = size; \
4718         nam.naml$l_long_filename = name;}
4719 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4720 #define rms_set_dna(fab, nam, name, size) \
4721         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4722         nam.naml$l_long_defname_size = size; \
4723         nam.naml$l_long_defname = name; }
4724 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4725 #define rms_set_esa(fab, nam, name, size) \
4726         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4727         nam.naml$l_long_expand_alloc = size; \
4728         nam.naml$l_long_expand = name; }
4729 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4730         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4731         nam.naml$l_long_expand = l_name; \
4732         nam.naml$l_long_expand_alloc = l_size; }
4733 #define rms_set_rsa(nam, name, size) \
4734         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4735         nam.naml$l_long_result = name; \
4736         nam.naml$l_long_result_alloc = size; }
4737 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4738         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4739         nam.naml$l_long_result = l_name; \
4740         nam.naml$l_long_result_alloc = l_size; }
4741 #define rms_nam_name_type_l_size(nam) \
4742         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4743 #endif
4744
4745
4746 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4747 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4748  * to expand file specification.  Allows for a single default file
4749  * specification and a simple mask of options.  If outbuf is non-NULL,
4750  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4751  * the resultant file specification is placed.  If outbuf is NULL, the
4752  * resultant file specification is placed into a static buffer.
4753  * The third argument, if non-NULL, is taken to be a default file
4754  * specification string.  The fourth argument is unused at present.
4755  * rmesexpand() returns the address of the resultant string if
4756  * successful, and NULL on error.
4757  *
4758  * New functionality for previously unused opts value:
4759  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4760  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
4761  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4762  */
4763 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4764
4765 static char *
4766 mp_do_rmsexpand
4767    (pTHX_ const char *filespec,
4768     char *outbuf,
4769     int ts,
4770     const char *defspec,
4771     unsigned opts,
4772     int * fs_utf8,
4773     int * dfs_utf8)
4774 {
4775   static char __rmsexpand_retbuf[VMS_MAXRSS];
4776   char * vmsfspec, *tmpfspec;
4777   char * esa, *cp, *out = NULL;
4778   char * tbuf;
4779   char * esal = NULL;
4780   char * outbufl;
4781   struct FAB myfab = cc$rms_fab;
4782   rms_setup_nam(mynam);
4783   STRLEN speclen;
4784   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4785   int sts;
4786
4787   /* temp hack until UTF8 is actually implemented */
4788   if (fs_utf8 != NULL)
4789     *fs_utf8 = 0;
4790
4791   if (!filespec || !*filespec) {
4792     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4793     return NULL;
4794   }
4795   if (!outbuf) {
4796     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4797     else    outbuf = __rmsexpand_retbuf;
4798   }
4799
4800   vmsfspec = NULL;
4801   tmpfspec = NULL;
4802   outbufl = NULL;
4803
4804   isunix = 0;
4805   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4806     isunix = is_unix_filespec(filespec);
4807     if (isunix) {
4808       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4809       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4810       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4811         PerlMem_free(vmsfspec);
4812         if (out)
4813            Safefree(out);
4814         return NULL;
4815       }
4816       filespec = vmsfspec;
4817
4818       /* Unless we are forcing to VMS format, a UNIX input means
4819        * UNIX output, and that requires long names to be used
4820        */
4821       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4822         opts |= PERL_RMSEXPAND_M_LONG;
4823       else {
4824         isunix = 0;
4825       }
4826     }
4827   }
4828
4829   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4830   rms_bind_fab_nam(myfab, mynam);
4831
4832   if (defspec && *defspec) {
4833     int t_isunix;
4834     t_isunix = is_unix_filespec(defspec);
4835     if (t_isunix) {
4836       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4837       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4838       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4839         PerlMem_free(tmpfspec);
4840         if (vmsfspec != NULL)
4841             PerlMem_free(vmsfspec);
4842         if (out)
4843            Safefree(out);
4844         return NULL;
4845       }
4846       defspec = tmpfspec;
4847     }
4848     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4849   }
4850
4851   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4852   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4853 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4854   esal = PerlMem_malloc(VMS_MAXRSS);
4855   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4856 #endif
4857   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4858
4859   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4860     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4861   }
4862   else {
4863 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4864     outbufl = PerlMem_malloc(VMS_MAXRSS);
4865     if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4866     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4867 #else
4868     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4869 #endif
4870   }
4871
4872 #ifdef NAM$M_NO_SHORT_UPCASE
4873   if (decc_efs_case_preserve)
4874     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4875 #endif
4876
4877   /* First attempt to parse as an existing file */
4878   retsts = sys$parse(&myfab,0,0);
4879   if (!(retsts & STS$K_SUCCESS)) {
4880
4881     /* Could not find the file, try as syntax only if error is not fatal */
4882     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4883     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4884       retsts = sys$parse(&myfab,0,0);
4885       if (retsts & STS$K_SUCCESS) goto expanded;
4886     }
4887
4888      /* Still could not parse the file specification */
4889     /*----------------------------------------------*/
4890     sts = rms_free_search_context(&myfab); /* Free search context */
4891     if (out) Safefree(out);
4892     if (tmpfspec != NULL)
4893         PerlMem_free(tmpfspec);
4894     if (vmsfspec != NULL)
4895         PerlMem_free(vmsfspec);
4896     if (outbufl != NULL)
4897         PerlMem_free(outbufl);
4898     PerlMem_free(esa);
4899     if (esal != NULL)
4900         PerlMem_free(esal);
4901     set_vaxc_errno(retsts);
4902     if      (retsts == RMS$_PRV) set_errno(EACCES);
4903     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4904     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4905     else                         set_errno(EVMSERR);
4906     return NULL;
4907   }
4908   retsts = sys$search(&myfab,0,0);
4909   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4910     sts = rms_free_search_context(&myfab); /* Free search context */
4911     if (out) Safefree(out);
4912     if (tmpfspec != NULL)
4913         PerlMem_free(tmpfspec);
4914     if (vmsfspec != NULL)
4915         PerlMem_free(vmsfspec);
4916     if (outbufl != NULL)
4917         PerlMem_free(outbufl);
4918     PerlMem_free(esa);
4919     if (esal != NULL)
4920         PerlMem_free(esal);
4921     set_vaxc_errno(retsts);
4922     if      (retsts == RMS$_PRV) set_errno(EACCES);
4923     else                         set_errno(EVMSERR);
4924     return NULL;
4925   }
4926
4927   /* If the input filespec contained any lowercase characters,
4928    * downcase the result for compatibility with Unix-minded code. */
4929   expanded:
4930   if (!decc_efs_case_preserve) {
4931     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4932       if (islower(*tbuf)) { haslower = 1; break; }
4933   }
4934
4935    /* Is a long or a short name expected */
4936   /*------------------------------------*/
4937   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4938     if (rms_nam_rsll(mynam)) {
4939         tbuf = outbuf;
4940         speclen = rms_nam_rsll(mynam);
4941     }
4942     else {
4943         tbuf = esal; /* Not esa */
4944         speclen = rms_nam_esll(mynam);
4945     }
4946   }
4947   else {
4948     if (rms_nam_rsl(mynam)) {
4949         tbuf = outbuf;
4950         speclen = rms_nam_rsl(mynam);
4951     }
4952     else {
4953         tbuf = esa; /* Not esal */
4954         speclen = rms_nam_esl(mynam);
4955     }
4956   }
4957   tbuf[speclen] = '\0';
4958
4959   /* Trim off null fields added by $PARSE
4960    * If type > 1 char, must have been specified in original or default spec
4961    * (not true for version; $SEARCH may have added version of existing file).
4962    */
4963   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4964   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4965     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4966              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4967   }
4968   else {
4969     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4970              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4971   }
4972   if (trimver || trimtype) {
4973     if (defspec && *defspec) {
4974       char *defesal = NULL;
4975       defesal = PerlMem_malloc(VMS_MAXRSS + 1);
4976       if (defesal != NULL) {
4977         struct FAB deffab = cc$rms_fab;
4978         rms_setup_nam(defnam);
4979
4980         rms_bind_fab_nam(deffab, defnam);
4981
4982         /* Cast ok */
4983         rms_set_fna
4984             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4985
4986         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4987
4988         rms_clear_nam_nop(defnam);
4989         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4990 #ifdef NAM$M_NO_SHORT_UPCASE
4991         if (decc_efs_case_preserve)
4992           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4993 #endif
4994         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4995           if (trimver) {
4996              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4997           }
4998           if (trimtype) {
4999             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5000           }
5001         }
5002         PerlMem_free(defesal);
5003       }
5004     }
5005     if (trimver) {
5006       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5007         if (*(rms_nam_verl(mynam)) != '\"')
5008           speclen = rms_nam_verl(mynam) - tbuf;
5009       }
5010       else {
5011         if (*(rms_nam_ver(mynam)) != '\"')
5012           speclen = rms_nam_ver(mynam) - tbuf;
5013       }
5014     }
5015     if (trimtype) {
5016       /* If we didn't already trim version, copy down */
5017       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5018         if (speclen > rms_nam_verl(mynam) - tbuf)
5019           memmove
5020            (rms_nam_typel(mynam),
5021             rms_nam_verl(mynam),
5022             speclen - (rms_nam_verl(mynam) - tbuf));
5023           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5024       }
5025       else {
5026         if (speclen > rms_nam_ver(mynam) - tbuf)
5027           memmove
5028            (rms_nam_type(mynam),
5029             rms_nam_ver(mynam),
5030             speclen - (rms_nam_ver(mynam) - tbuf));
5031           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5032       }
5033     }
5034   }
5035
5036    /* Done with these copies of the input files */
5037   /*-------------------------------------------*/
5038   if (vmsfspec != NULL)
5039         PerlMem_free(vmsfspec);
5040   if (tmpfspec != NULL)
5041         PerlMem_free(tmpfspec);
5042
5043   /* If we just had a directory spec on input, $PARSE "helpfully"
5044    * adds an empty name and type for us */
5045   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5046     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5047         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5048         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5049       speclen = rms_nam_namel(mynam) - tbuf;
5050   }
5051   else {
5052     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5053         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5054         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5055       speclen = rms_nam_name(mynam) - tbuf;
5056   }
5057
5058   /* Posix format specifications must have matching quotes */
5059   if (speclen < (VMS_MAXRSS - 1)) {
5060     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5061       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5062         tbuf[speclen] = '\"';
5063         speclen++;
5064       }
5065     }
5066   }
5067   tbuf[speclen] = '\0';
5068   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5069
5070   /* Have we been working with an expanded, but not resultant, spec? */
5071   /* Also, convert back to Unix syntax if necessary. */
5072
5073   if (!rms_nam_rsll(mynam)) {
5074     if (isunix) {
5075       if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
5076         if (out) Safefree(out);
5077         if (esal != NULL)
5078             PerlMem_free(esal);
5079         PerlMem_free(esa);
5080         if (outbufl != NULL)
5081             PerlMem_free(outbufl);
5082         return NULL;
5083       }
5084     }
5085     else strcpy(outbuf,esa);
5086   }
5087   else if (isunix) {
5088     tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5089     if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5090     if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
5091         if (out) Safefree(out);
5092         PerlMem_free(esa);
5093         if (esal != NULL)
5094             PerlMem_free(esal);
5095         PerlMem_free(tmpfspec);
5096         if (outbufl != NULL)
5097             PerlMem_free(outbufl);
5098         return NULL;
5099     }
5100     strcpy(outbuf,tmpfspec);
5101     PerlMem_free(tmpfspec);
5102   }
5103
5104   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5105   sts = rms_free_search_context(&myfab); /* Free search context */
5106   PerlMem_free(esa);
5107   if (esal != NULL)
5108      PerlMem_free(esal);
5109   if (outbufl != NULL)
5110      PerlMem_free(outbufl);
5111   return outbuf;
5112 }
5113 /*}}}*/
5114 /* External entry points */
5115 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5116 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5117 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5118 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5119 char *Perl_rmsexpand_utf8
5120   (pTHX_ const char *spec, char *buf, const char *def,
5121    unsigned opt, int * fs_utf8, int * dfs_utf8)
5122 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5123 char *Perl_rmsexpand_utf8_ts
5124   (pTHX_ const char *spec, char *buf, const char *def,
5125    unsigned opt, int * fs_utf8, int * dfs_utf8)
5126 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5127
5128
5129 /*
5130 ** The following routines are provided to make life easier when
5131 ** converting among VMS-style and Unix-style directory specifications.
5132 ** All will take input specifications in either VMS or Unix syntax. On
5133 ** failure, all return NULL.  If successful, the routines listed below
5134 ** return a pointer to a buffer containing the appropriately
5135 ** reformatted spec (and, therefore, subsequent calls to that routine
5136 ** will clobber the result), while the routines of the same names with
5137 ** a _ts suffix appended will return a pointer to a mallocd string
5138 ** containing the appropriately reformatted spec.
5139 ** In all cases, only explicit syntax is altered; no check is made that
5140 ** the resulting string is valid or that the directory in question
5141 ** actually exists.
5142 **
5143 **   fileify_dirspec() - convert a directory spec into the name of the
5144 **     directory file (i.e. what you can stat() to see if it's a dir).
5145 **     The style (VMS or Unix) of the result is the same as the style
5146 **     of the parameter passed in.
5147 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5148 **     what you prepend to a filename to indicate what directory it's in).
5149 **     The style (VMS or Unix) of the result is the same as the style
5150 **     of the parameter passed in.
5151 **   tounixpath() - convert a directory spec into a Unix-style path.
5152 **   tovmspath() - convert a directory spec into a VMS-style path.
5153 **   tounixspec() - convert any file spec into a Unix-style file spec.
5154 **   tovmsspec() - convert any file spec into a VMS-style spec.
5155 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5156 **
5157 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5158 ** Permission is given to distribute this code as part of the Perl
5159 ** standard distribution under the terms of the GNU General Public
5160 ** License or the Perl Artistic License.  Copies of each may be
5161 ** found in the Perl standard distribution.
5162  */
5163
5164 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5165 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5166 {
5167     static char __fileify_retbuf[VMS_MAXRSS];
5168     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5169     char *retspec, *cp1, *cp2, *lastdir;
5170     char *trndir, *vmsdir;
5171     unsigned short int trnlnm_iter_count;
5172     int sts;
5173     if (utf8_fl != NULL)
5174         *utf8_fl = 0;
5175
5176     if (!dir || !*dir) {
5177       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5178     }
5179     dirlen = strlen(dir);
5180     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5181     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5182       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5183         dir = "/sys$disk";
5184         dirlen = 9;
5185       }
5186       else
5187         dirlen = 1;
5188     }
5189     if (dirlen > (VMS_MAXRSS - 1)) {
5190       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5191       return NULL;
5192     }
5193     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5194     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5195     if (!strpbrk(dir+1,"/]>:")  &&
5196         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5197       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5198       trnlnm_iter_count = 0;
5199       while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5200         trnlnm_iter_count++;
5201         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5202       }
5203       dirlen = strlen(trndir);
5204     }
5205     else {
5206       strncpy(trndir,dir,dirlen);
5207       trndir[dirlen] = '\0';
5208     }
5209
5210     /* At this point we are done with *dir and use *trndir which is a
5211      * copy that can be modified.  *dir must not be modified.
5212      */
5213
5214     /* If we were handed a rooted logical name or spec, treat it like a
5215      * simple directory, so that
5216      *    $ Define myroot dev:[dir.]
5217      *    ... do_fileify_dirspec("myroot",buf,1) ...
5218      * does something useful.
5219      */
5220     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5221       trndir[--dirlen] = '\0';
5222       trndir[dirlen-1] = ']';
5223     }
5224     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5225       trndir[--dirlen] = '\0';
5226       trndir[dirlen-1] = '>';
5227     }
5228
5229     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5230       /* If we've got an explicit filename, we can just shuffle the string. */
5231       if (*(cp1+1)) hasfilename = 1;
5232       /* Similarly, we can just back up a level if we've got multiple levels
5233          of explicit directories in a VMS spec which ends with directories. */
5234       else {
5235         for (cp2 = cp1; cp2 > trndir; cp2--) {
5236           if (*cp2 == '.') {
5237             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5238 /* fix-me, can not scan EFS file specs backward like this */
5239               *cp2 = *cp1; *cp1 = '\0';
5240               hasfilename = 1;
5241               break;
5242             }
5243           }
5244           if (*cp2 == '[' || *cp2 == '<') break;
5245         }
5246       }
5247     }
5248
5249     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5250     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5251     cp1 = strpbrk(trndir,"]:>");
5252     if (hasfilename || !cp1) { /* Unix-style path or filename */
5253       if (trndir[0] == '.') {
5254         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5255           PerlMem_free(trndir);
5256           PerlMem_free(vmsdir);
5257           return do_fileify_dirspec("[]",buf,ts,NULL);
5258         }
5259         else if (trndir[1] == '.' &&
5260                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5261           PerlMem_free(trndir);
5262           PerlMem_free(vmsdir);
5263           return do_fileify_dirspec("[-]",buf,ts,NULL);
5264         }
5265       }
5266       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5267         dirlen -= 1;                 /* to last element */
5268         lastdir = strrchr(trndir,'/');
5269       }
5270       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5271         /* If we have "/." or "/..", VMSify it and let the VMS code
5272          * below expand it, rather than repeating the code to handle
5273          * relative components of a filespec here */
5274         do {
5275           if (*(cp1+2) == '.') cp1++;
5276           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5277             char * ret_chr;
5278             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5279                 PerlMem_free(trndir);
5280                 PerlMem_free(vmsdir);
5281                 return NULL;
5282             }
5283             if (strchr(vmsdir,'/') != NULL) {
5284               /* If do_tovmsspec() returned it, it must have VMS syntax
5285                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5286                * the time to check this here only so we avoid a recursion
5287                * loop; otherwise, gigo.
5288                */
5289               PerlMem_free(trndir);
5290               PerlMem_free(vmsdir);
5291               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5292               return NULL;
5293             }
5294             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5295                 PerlMem_free(trndir);
5296                 PerlMem_free(vmsdir);
5297                 return NULL;
5298             }
5299             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5300             PerlMem_free(trndir);
5301             PerlMem_free(vmsdir);
5302             return ret_chr;
5303           }
5304           cp1++;
5305         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5306         lastdir = strrchr(trndir,'/');
5307       }
5308       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5309         char * ret_chr;
5310         /* Ditto for specs that end in an MFD -- let the VMS code
5311          * figure out whether it's a real device or a rooted logical. */
5312
5313         /* This should not happen any more.  Allowing the fake /000000
5314          * in a UNIX pathname causes all sorts of problems when trying
5315          * to run in UNIX emulation.  So the VMS to UNIX conversions
5316          * now remove the fake /000000 directories.
5317          */
5318
5319         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5320         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5321             PerlMem_free(trndir);
5322             PerlMem_free(vmsdir);
5323             return NULL;
5324         }
5325         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5326             PerlMem_free(trndir);
5327             PerlMem_free(vmsdir);
5328             return NULL;
5329         }
5330         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5331         PerlMem_free(trndir);
5332         PerlMem_free(vmsdir);
5333         return ret_chr;
5334       }
5335       else {
5336
5337         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5338              !(lastdir = cp1 = strrchr(trndir,']')) &&
5339              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5340         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5341           int ver; char *cp3;
5342
5343           /* For EFS or ODS-5 look for the last dot */
5344           if (decc_efs_charset) {
5345               cp2 = strrchr(cp1,'.');
5346           }
5347           if (vms_process_case_tolerant) {
5348               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5349                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5350                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5351                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5352                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5353                             (ver || *cp3)))))) {
5354                   PerlMem_free(trndir);
5355                   PerlMem_free(vmsdir);
5356                   set_errno(ENOTDIR);
5357                   set_vaxc_errno(RMS$_DIR);
5358                   return NULL;
5359               }
5360           }
5361           else {
5362               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5363                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5364                   !*(cp2+3) || *(cp2+3) != 'R' ||
5365                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5366                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5367                             (ver || *cp3)))))) {
5368                  PerlMem_free(trndir);
5369                  PerlMem_free(vmsdir);
5370                  set_errno(ENOTDIR);
5371                  set_vaxc_errno(RMS$_DIR);
5372                  return NULL;
5373               }
5374           }
5375           dirlen = cp2 - trndir;
5376         }
5377       }
5378
5379       retlen = dirlen + 6;
5380       if (buf) retspec = buf;
5381       else if (ts) Newx(retspec,retlen+1,char);
5382       else retspec = __fileify_retbuf;
5383       memcpy(retspec,trndir,dirlen);
5384       retspec[dirlen] = '\0';
5385
5386       /* We've picked up everything up to the directory file name.
5387          Now just add the type and version, and we're set. */
5388       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5389         strcat(retspec,".dir;1");
5390       else
5391         strcat(retspec,".DIR;1");
5392       PerlMem_free(trndir);
5393       PerlMem_free(vmsdir);
5394       return retspec;
5395     }
5396     else {  /* VMS-style directory spec */
5397
5398       char *esa, term, *cp;
5399       unsigned long int sts, cmplen, haslower = 0;
5400       unsigned int nam_fnb;
5401       char * nam_type;
5402       struct FAB dirfab = cc$rms_fab;
5403       rms_setup_nam(savnam);
5404       rms_setup_nam(dirnam);
5405
5406       esa = PerlMem_malloc(VMS_MAXRSS + 1);
5407       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5408       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5409       rms_bind_fab_nam(dirfab, dirnam);
5410       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5411       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5412 #ifdef NAM$M_NO_SHORT_UPCASE
5413       if (decc_efs_case_preserve)
5414         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5415 #endif
5416
5417       for (cp = trndir; *cp; cp++)
5418         if (islower(*cp)) { haslower = 1; break; }
5419       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5420         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5421           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5422           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5423         }
5424         if (!sts) {
5425           PerlMem_free(esa);
5426           PerlMem_free(trndir);
5427           PerlMem_free(vmsdir);
5428           set_errno(EVMSERR);
5429           set_vaxc_errno(dirfab.fab$l_sts);
5430           return NULL;
5431         }
5432       }
5433       else {
5434         savnam = dirnam;
5435         /* Does the file really exist? */
5436         if (sys$search(&dirfab)& STS$K_SUCCESS) {
5437           /* Yes; fake the fnb bits so we'll check type below */
5438         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5439         }
5440         else { /* No; just work with potential name */
5441           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5442           else {
5443             int fab_sts;
5444             fab_sts = dirfab.fab$l_sts;
5445             sts = rms_free_search_context(&dirfab);
5446             PerlMem_free(esa);
5447             PerlMem_free(trndir);
5448             PerlMem_free(vmsdir);
5449             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
5450             return NULL;
5451           }
5452         }
5453       }
5454       esa[rms_nam_esll(dirnam)] = '\0';
5455       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5456         cp1 = strchr(esa,']');
5457         if (!cp1) cp1 = strchr(esa,'>');
5458         if (cp1) {  /* Should always be true */
5459           rms_nam_esll(dirnam) -= cp1 - esa - 1;
5460           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5461         }
5462       }
5463       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5464         /* Yep; check version while we're at it, if it's there. */
5465         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5466         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5467           /* Something other than .DIR[;1].  Bzzt. */
5468           sts = rms_free_search_context(&dirfab);
5469           PerlMem_free(esa);
5470           PerlMem_free(trndir);
5471           PerlMem_free(vmsdir);
5472           set_errno(ENOTDIR);
5473           set_vaxc_errno(RMS$_DIR);
5474           return NULL;
5475         }
5476       }
5477
5478       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5479         /* They provided at least the name; we added the type, if necessary, */
5480         if (buf) retspec = buf;                            /* in sys$parse() */
5481         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5482         else retspec = __fileify_retbuf;
5483         strcpy(retspec,esa);
5484         sts = rms_free_search_context(&dirfab);
5485         PerlMem_free(trndir);
5486         PerlMem_free(esa);
5487         PerlMem_free(vmsdir);
5488         return retspec;
5489       }
5490       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5491         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5492         *cp1 = '\0';
5493         rms_nam_esll(dirnam) -= 9;
5494       }
5495       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5496       if (cp1 == NULL) { /* should never happen */
5497         sts = rms_free_search_context(&dirfab);
5498         PerlMem_free(trndir);
5499         PerlMem_free(esa);
5500         PerlMem_free(vmsdir);
5501         return NULL;
5502       }
5503       term = *cp1;
5504       *cp1 = '\0';
5505       retlen = strlen(esa);
5506       cp1 = strrchr(esa,'.');
5507       /* ODS-5 directory specifications can have extra "." in them. */
5508       /* Fix-me, can not scan EFS file specifications backwards */
5509       while (cp1 != NULL) {
5510         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5511           break;
5512         else {
5513            cp1--;
5514            while ((cp1 > esa) && (*cp1 != '.'))
5515              cp1--;
5516         }
5517         if (cp1 == esa)
5518           cp1 = NULL;
5519       }
5520
5521       if ((cp1) != NULL) {
5522         /* There's more than one directory in the path.  Just roll back. */
5523         *cp1 = term;
5524         if (buf) retspec = buf;
5525         else if (ts) Newx(retspec,retlen+7,char);
5526         else retspec = __fileify_retbuf;
5527         strcpy(retspec,esa);
5528       }
5529       else {
5530         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5531           /* Go back and expand rooted logical name */
5532           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5533 #ifdef NAM$M_NO_SHORT_UPCASE
5534           if (decc_efs_case_preserve)
5535             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5536 #endif
5537           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5538             sts = rms_free_search_context(&dirfab);
5539             PerlMem_free(esa);
5540             PerlMem_free(trndir);
5541             PerlMem_free(vmsdir);
5542             set_errno(EVMSERR);
5543             set_vaxc_errno(dirfab.fab$l_sts);
5544             return NULL;
5545           }
5546           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5547           if (buf) retspec = buf;
5548           else if (ts) Newx(retspec,retlen+16,char);
5549           else retspec = __fileify_retbuf;
5550           cp1 = strstr(esa,"][");
5551           if (!cp1) cp1 = strstr(esa,"]<");
5552           dirlen = cp1 - esa;
5553           memcpy(retspec,esa,dirlen);
5554           if (!strncmp(cp1+2,"000000]",7)) {
5555             retspec[dirlen-1] = '\0';
5556             /* fix-me Not full ODS-5, just extra dots in directories for now */
5557             cp1 = retspec + dirlen - 1;
5558             while (cp1 > retspec)
5559             {
5560               if (*cp1 == '[')
5561                 break;
5562               if (*cp1 == '.') {
5563                 if (*(cp1-1) != '^')
5564                   break;
5565               }
5566               cp1--;
5567             }
5568             if (*cp1 == '.') *cp1 = ']';
5569             else {
5570               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5571               memmove(cp1+1,"000000]",7);
5572             }
5573           }
5574           else {
5575             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5576             retspec[retlen] = '\0';
5577             /* Convert last '.' to ']' */
5578             cp1 = retspec+retlen-1;
5579             while (*cp != '[') {
5580               cp1--;
5581               if (*cp1 == '.') {
5582                 /* Do not trip on extra dots in ODS-5 directories */
5583                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5584                 break;
5585               }
5586             }
5587             if (*cp1 == '.') *cp1 = ']';
5588             else {
5589               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5590               memmove(cp1+1,"000000]",7);
5591             }
5592           }
5593         }
5594         else {  /* This is a top-level dir.  Add the MFD to the path. */
5595           if (buf) retspec = buf;
5596           else if (ts) Newx(retspec,retlen+16,char);
5597           else retspec = __fileify_retbuf;
5598           cp1 = esa;
5599           cp2 = retspec;
5600           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5601           strcpy(cp2,":[000000]");
5602           cp1 += 2;
5603           strcpy(cp2+9,cp1);
5604         }
5605       }
5606       sts = rms_free_search_context(&dirfab);
5607       /* We've set up the string up through the filename.  Add the
5608          type and version, and we're done. */
5609       strcat(retspec,".DIR;1");
5610
5611       /* $PARSE may have upcased filespec, so convert output to lower
5612        * case if input contained any lowercase characters. */
5613       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5614       PerlMem_free(trndir);
5615       PerlMem_free(esa);
5616       PerlMem_free(vmsdir);
5617       return retspec;
5618     }
5619 }  /* end of do_fileify_dirspec() */
5620 /*}}}*/
5621 /* External entry points */
5622 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5623 { return do_fileify_dirspec(dir,buf,0,NULL); }
5624 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5625 { return do_fileify_dirspec(dir,buf,1,NULL); }
5626 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5627 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5628 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5629 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5630
5631 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5632 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5633 {
5634     static char __pathify_retbuf[VMS_MAXRSS];
5635     unsigned long int retlen;
5636     char *retpath, *cp1, *cp2, *trndir;
5637     unsigned short int trnlnm_iter_count;
5638     STRLEN trnlen;
5639     int sts;
5640     if (utf8_fl != NULL)
5641         *utf8_fl = 0;
5642
5643     if (!dir || !*dir) {
5644       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5645     }
5646
5647     trndir = PerlMem_malloc(VMS_MAXRSS);
5648     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5649     if (*dir) strcpy(trndir,dir);
5650     else getcwd(trndir,VMS_MAXRSS - 1);
5651
5652     trnlnm_iter_count = 0;
5653     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5654            && my_trnlnm(trndir,trndir,0)) {
5655       trnlnm_iter_count++;
5656       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5657       trnlen = strlen(trndir);
5658
5659       /* Trap simple rooted lnms, and return lnm:[000000] */
5660       if (!strcmp(trndir+trnlen-2,".]")) {
5661         if (buf) retpath = buf;
5662         else if (ts) Newx(retpath,strlen(dir)+10,char);
5663         else retpath = __pathify_retbuf;
5664         strcpy(retpath,dir);
5665         strcat(retpath,":[000000]");
5666         PerlMem_free(trndir);
5667         return retpath;
5668       }
5669     }
5670
5671     /* At this point we do not work with *dir, but the copy in
5672      * *trndir that is modifiable.
5673      */
5674
5675     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5676       if (*trndir == '.' && (*(trndir+1) == '\0' ||
5677                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5678         retlen = 2 + (*(trndir+1) != '\0');
5679       else {
5680         if ( !(cp1 = strrchr(trndir,'/')) &&
5681              !(cp1 = strrchr(trndir,']')) &&
5682              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5683         if ((cp2 = strchr(cp1,'.')) != NULL &&
5684             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
5685              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
5686               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5687               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5688           int ver; char *cp3;
5689
5690           /* For EFS or ODS-5 look for the last dot */
5691           if (decc_efs_charset) {
5692             cp2 = strrchr(cp1,'.');
5693           }
5694           if (vms_process_case_tolerant) {
5695               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5696                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5697                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5698                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5699                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5700                             (ver || *cp3)))))) {
5701                 PerlMem_free(trndir);
5702                 set_errno(ENOTDIR);
5703                 set_vaxc_errno(RMS$_DIR);
5704                 return NULL;
5705               }
5706           }
5707           else {
5708               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5709                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5710                   !*(cp2+3) || *(cp2+3) != 'R' ||
5711                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5712                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5713                             (ver || *cp3)))))) {
5714                 PerlMem_free(trndir);
5715                 set_errno(ENOTDIR);
5716                 set_vaxc_errno(RMS$_DIR);
5717                 return NULL;
5718               }
5719           }
5720           retlen = cp2 - trndir + 1;
5721         }
5722         else {  /* No file type present.  Treat the filename as a directory. */
5723           retlen = strlen(trndir) + 1;
5724         }
5725       }
5726       if (buf) retpath = buf;
5727       else if (ts) Newx(retpath,retlen+1,char);
5728       else retpath = __pathify_retbuf;
5729       strncpy(retpath, trndir, retlen-1);
5730       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5731         retpath[retlen-1] = '/';      /* with '/', add it. */
5732         retpath[retlen] = '\0';
5733       }
5734       else retpath[retlen-1] = '\0';
5735     }
5736     else {  /* VMS-style directory spec */
5737       char *esa, *cp;
5738       unsigned long int sts, cmplen, haslower;
5739       struct FAB dirfab = cc$rms_fab;
5740       int dirlen;
5741       rms_setup_nam(savnam);
5742       rms_setup_nam(dirnam);
5743
5744       /* If we've got an explicit filename, we can just shuffle the string. */
5745       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5746              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
5747         if ((cp2 = strchr(cp1,'.')) != NULL) {
5748           int ver; char *cp3;
5749           if (vms_process_case_tolerant) {
5750               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5751                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5752                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5753                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5754                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5755                             (ver || *cp3)))))) {
5756                PerlMem_free(trndir);
5757                set_errno(ENOTDIR);
5758                set_vaxc_errno(RMS$_DIR);
5759                return NULL;
5760              }
5761           }
5762           else {
5763               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5764                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5765                   !*(cp2+3) || *(cp2+3) != 'R' ||
5766                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5767                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5768                             (ver || *cp3)))))) {
5769                PerlMem_free(trndir);
5770                set_errno(ENOTDIR);
5771                set_vaxc_errno(RMS$_DIR);
5772                return NULL;
5773              }
5774           }
5775         }
5776         else {  /* No file type, so just draw name into directory part */
5777           for (cp2 = cp1; *cp2; cp2++) ;
5778         }
5779         *cp2 = *cp1;
5780         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5781         *cp1 = '.';
5782         /* We've now got a VMS 'path'; fall through */
5783       }
5784
5785       dirlen = strlen(trndir);
5786       if (trndir[dirlen-1] == ']' ||
5787           trndir[dirlen-1] == '>' ||
5788           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5789         if (buf) retpath = buf;
5790         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5791         else retpath = __pathify_retbuf;
5792         strcpy(retpath,trndir);
5793         PerlMem_free(trndir);
5794         return retpath;
5795       }
5796       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5797       esa = PerlMem_malloc(VMS_MAXRSS);
5798       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5799       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5800       rms_bind_fab_nam(dirfab, dirnam);
5801       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5802 #ifdef NAM$M_NO_SHORT_UPCASE
5803       if (decc_efs_case_preserve)
5804           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5805 #endif
5806
5807       for (cp = trndir; *cp; cp++)
5808         if (islower(*cp)) { haslower = 1; break; }
5809
5810       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5811         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5812           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5813           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5814         }
5815         if (!sts) {
5816           PerlMem_free(trndir);
5817           PerlMem_free(esa);
5818           set_errno(EVMSERR);
5819           set_vaxc_errno(dirfab.fab$l_sts);
5820           return NULL;
5821         }
5822       }
5823       else {
5824         savnam = dirnam;
5825         /* Does the file really exist? */
5826         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5827           if (dirfab.fab$l_sts != RMS$_FNF) {
5828             int sts1;
5829             sts1 = rms_free_search_context(&dirfab);
5830             PerlMem_free(trndir);
5831             PerlMem_free(esa);
5832             set_errno(EVMSERR);
5833             set_vaxc_errno(dirfab.fab$l_sts);
5834             return NULL;
5835           }
5836           dirnam = savnam; /* No; just work with potential name */
5837         }
5838       }
5839       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5840         /* Yep; check version while we're at it, if it's there. */
5841         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5842         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5843           int sts2;
5844           /* Something other than .DIR[;1].  Bzzt. */
5845           sts2 = rms_free_search_context(&dirfab);
5846           PerlMem_free(trndir);
5847           PerlMem_free(esa);
5848           set_errno(ENOTDIR);
5849           set_vaxc_errno(RMS$_DIR);
5850           return NULL;
5851         }
5852       }
5853       /* OK, the type was fine.  Now pull any file name into the
5854          directory path. */
5855       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5856       else {
5857         cp1 = strrchr(esa,'>');
5858         *(rms_nam_typel(dirnam)) = '>';
5859       }
5860       *cp1 = '.';
5861       *(rms_nam_typel(dirnam) + 1) = '\0';
5862       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5863       if (buf) retpath = buf;
5864       else if (ts) Newx(retpath,retlen,char);
5865       else retpath = __pathify_retbuf;
5866       strcpy(retpath,esa);
5867       PerlMem_free(esa);
5868       sts = rms_free_search_context(&dirfab);
5869       /* $PARSE may have upcased filespec, so convert output to lower
5870        * case if input contained any lowercase characters. */
5871       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5872     }
5873
5874     PerlMem_free(trndir);
5875     return retpath;
5876 }  /* end of do_pathify_dirspec() */
5877 /*}}}*/
5878 /* External entry points */
5879 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5880 { return do_pathify_dirspec(dir,buf,0,NULL); }
5881 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5882 { return do_pathify_dirspec(dir,buf,1,NULL); }
5883 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5884 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5885 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5886 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5887
5888 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5889 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5890 {
5891   static char __tounixspec_retbuf[VMS_MAXRSS];
5892   char *dirend, *rslt, *cp1, *cp3, *tmp;
5893   const char *cp2;
5894   int devlen, dirlen, retlen = VMS_MAXRSS;
5895   int expand = 1; /* guarantee room for leading and trailing slashes */
5896   unsigned short int trnlnm_iter_count;
5897   int cmp_rslt;
5898   if (utf8_fl != NULL)
5899     *utf8_fl = 0;
5900
5901   if (spec == NULL) return NULL;
5902   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5903   if (buf) rslt = buf;
5904   else if (ts) {
5905     Newx(rslt, VMS_MAXRSS, char);
5906   }
5907   else rslt = __tounixspec_retbuf;
5908
5909   /* New VMS specific format needs translation
5910    * glob passes filenames with trailing '\n' and expects this preserved.
5911    */
5912   if (decc_posix_compliant_pathnames) {
5913     if (strncmp(spec, "\"^UP^", 5) == 0) {
5914       char * uspec;
5915       char *tunix;
5916       int tunix_len;
5917       int nl_flag;
5918
5919       tunix = PerlMem_malloc(VMS_MAXRSS);
5920       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5921       strcpy(tunix, spec);
5922       tunix_len = strlen(tunix);
5923       nl_flag = 0;
5924       if (tunix[tunix_len - 1] == '\n') {
5925         tunix[tunix_len - 1] = '\"';
5926         tunix[tunix_len] = '\0';
5927         tunix_len--;
5928         nl_flag = 1;
5929       }
5930       uspec = decc$translate_vms(tunix);
5931       PerlMem_free(tunix);
5932       if ((int)uspec > 0) {
5933         strcpy(rslt,uspec);
5934         if (nl_flag) {
5935           strcat(rslt,"\n");
5936         }
5937         else {
5938           /* If we can not translate it, makemaker wants as-is */
5939           strcpy(rslt, spec);
5940         }
5941         return rslt;
5942       }
5943     }
5944   }
5945
5946   cmp_rslt = 0; /* Presume VMS */
5947   cp1 = strchr(spec, '/');
5948   if (cp1 == NULL)
5949     cmp_rslt = 0;
5950
5951     /* Look for EFS ^/ */
5952     if (decc_efs_charset) {
5953       while (cp1 != NULL) {
5954         cp2 = cp1 - 1;
5955         if (*cp2 != '^') {
5956           /* Found illegal VMS, assume UNIX */
5957           cmp_rslt = 1;
5958           break;
5959         }
5960       cp1++;
5961       cp1 = strchr(cp1, '/');
5962     }
5963   }
5964
5965   /* Look for "." and ".." */
5966   if (decc_filename_unix_report) {
5967     if (spec[0] == '.') {
5968       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5969         cmp_rslt = 1;
5970       }
5971       else {
5972         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5973           cmp_rslt = 1;
5974         }
5975       }
5976     }
5977   }
5978   /* This is already UNIX or at least nothing VMS understands */
5979   if (cmp_rslt) {
5980     strcpy(rslt,spec);
5981     return rslt;
5982   }
5983
5984   cp1 = rslt;
5985   cp2 = spec;
5986   dirend = strrchr(spec,']');
5987   if (dirend == NULL) dirend = strrchr(spec,'>');
5988   if (dirend == NULL) dirend = strchr(spec,':');
5989   if (dirend == NULL) {
5990     strcpy(rslt,spec);
5991     return rslt;
5992   }
5993
5994   /* Special case 1 - sys$posix_root = / */
5995 #if __CRTL_VER >= 70000000
5996   if (!decc_disable_posix_root) {
5997     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5998       *cp1 = '/';
5999       cp1++;
6000       cp2 = cp2 + 15;
6001       }
6002   }
6003 #endif
6004
6005   /* Special case 2 - Convert NLA0: to /dev/null */
6006 #if __CRTL_VER < 70000000
6007   cmp_rslt = strncmp(spec,"NLA0:", 5);
6008   if (cmp_rslt != 0)
6009      cmp_rslt = strncmp(spec,"nla0:", 5);
6010 #else
6011   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6012 #endif
6013   if (cmp_rslt == 0) {
6014     strcpy(rslt, "/dev/null");
6015     cp1 = cp1 + 9;
6016     cp2 = cp2 + 5;
6017     if (spec[6] != '\0') {
6018       cp1[9] == '/';
6019       cp1++;
6020       cp2++;
6021     }
6022   }
6023
6024    /* Also handle special case "SYS$SCRATCH:" */
6025 #if __CRTL_VER < 70000000
6026   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6027   if (cmp_rslt != 0)
6028      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6029 #else
6030   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6031 #endif
6032   tmp = PerlMem_malloc(VMS_MAXRSS);
6033   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6034   if (cmp_rslt == 0) {
6035   int islnm;
6036
6037     islnm = my_trnlnm(tmp, "TMP", 0);
6038     if (!islnm) {
6039       strcpy(rslt, "/tmp");
6040       cp1 = cp1 + 4;
6041       cp2 = cp2 + 12;
6042       if (spec[12] != '\0') {
6043         cp1[4] == '/';
6044         cp1++;
6045         cp2++;
6046       }
6047     }
6048   }
6049
6050   if (*cp2 != '[' && *cp2 != '<') {
6051     *(cp1++) = '/';
6052   }
6053   else {  /* the VMS spec begins with directories */
6054     cp2++;
6055     if (*cp2 == ']' || *cp2 == '>') {
6056       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6057       PerlMem_free(tmp);
6058       return rslt;
6059     }
6060     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6061       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6062         if (ts) Safefree(rslt);
6063         PerlMem_free(tmp);
6064         return NULL;
6065       }
6066       trnlnm_iter_count = 0;
6067       do {
6068         cp3 = tmp;
6069         while (*cp3 != ':' && *cp3) cp3++;
6070         *(cp3++) = '\0';
6071         if (strchr(cp3,']') != NULL) break;
6072         trnlnm_iter_count++;
6073         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6074       } while (vmstrnenv(tmp,tmp,0,fildev,0));
6075       if (ts && !buf &&
6076           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6077         retlen = devlen + dirlen;
6078         Renew(rslt,retlen+1+2*expand,char);
6079         cp1 = rslt;
6080       }
6081       cp3 = tmp;
6082       *(cp1++) = '/';
6083       while (*cp3) {
6084         *(cp1++) = *(cp3++);
6085         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6086             PerlMem_free(tmp);
6087             return NULL; /* No room */
6088         }
6089       }
6090       *(cp1++) = '/';
6091     }
6092     if ((*cp2 == '^')) {
6093         /* EFS file escape, pass the next character as is */
6094         /* Fix me: HEX encoding for UNICODE not implemented */
6095         cp2++;
6096     }
6097     else if ( *cp2 == '.') {
6098       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6099         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6100         cp2 += 3;
6101       }
6102       else cp2++;
6103     }
6104   }
6105   PerlMem_free(tmp);
6106   for (; cp2 <= dirend; cp2++) {
6107     if ((*cp2 == '^')) {
6108         /* EFS file escape, pass the next character as is */
6109         /* Fix me: HEX encoding for UNICODE not implemented */
6110         *(cp1++) = *(++cp2);
6111         /* An escaped dot stays as is -- don't convert to slash */
6112         if (*cp2 == '.') cp2++;
6113     }
6114     if (*cp2 == ':') {
6115       *(cp1++) = '/';
6116       if (*(cp2+1) == '[') cp2++;
6117     }
6118     else if (*cp2 == ']' || *cp2 == '>') {
6119       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6120     }
6121     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6122       *(cp1++) = '/';
6123       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6124         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6125                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6126         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6127             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6128       }
6129       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6130         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6131         cp2 += 2;
6132       }
6133     }
6134     else if (*cp2 == '-') {
6135       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6136         while (*cp2 == '-') {
6137           cp2++;
6138           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6139         }
6140         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6141           if (ts) Safefree(rslt);                        /* filespecs like */
6142           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
6143           return NULL;
6144         }
6145       }
6146       else *(cp1++) = *cp2;
6147     }
6148     else *(cp1++) = *cp2;
6149   }
6150   while (*cp2) {
6151     if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++;  /* '^.' --> '.' */
6152     *(cp1++) = *(cp2++);
6153   }
6154   *cp1 = '\0';
6155
6156   /* This still leaves /000000/ when working with a
6157    * VMS device root or concealed root.
6158    */
6159   {
6160   int ulen;
6161   char * zeros;
6162
6163       ulen = strlen(rslt);
6164
6165       /* Get rid of "000000/ in rooted filespecs */
6166       if (ulen > 7) {
6167         zeros = strstr(rslt, "/000000/");
6168         if (zeros != NULL) {
6169           int mlen;
6170           mlen = ulen - (zeros - rslt) - 7;
6171           memmove(zeros, &zeros[7], mlen);
6172           ulen = ulen - 7;
6173           rslt[ulen] = '\0';
6174         }
6175       }
6176   }
6177
6178   return rslt;
6179
6180 }  /* end of do_tounixspec() */
6181 /*}}}*/
6182 /* External entry points */
6183 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6184   { return do_tounixspec(spec,buf,0, NULL); }
6185 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6186   { return do_tounixspec(spec,buf,1, NULL); }
6187 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6188   { return do_tounixspec(spec,buf,0, utf8_fl); }
6189 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6190   { return do_tounixspec(spec,buf,1, utf8_fl); }
6191
6192 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6193
6194 /*
6195  This procedure is used to identify if a path is based in either
6196  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6197  it returns the OpenVMS format directory for it.
6198
6199  It is expecting specifications of only '/' or '/xxxx/'
6200
6201  If a posix root does not exist, or 'xxxx' is not a directory
6202  in the posix root, it returns a failure.
6203
6204  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6205
6206  It is used only internally by posix_to_vmsspec_hardway().
6207  */
6208
6209 static int posix_root_to_vms
6210   (char *vmspath, int vmspath_len,
6211    const char *unixpath,
6212    const int * utf8_fl) {
6213 int sts;
6214 struct FAB myfab = cc$rms_fab;
6215 struct NAML mynam = cc$rms_naml;
6216 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6217  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6218 char *esa;
6219 char *vms_delim;
6220 int dir_flag;
6221 int unixlen;
6222
6223     dir_flag = 0;
6224     unixlen = strlen(unixpath);
6225     if (unixlen == 0) {
6226       vmspath[0] = '\0';
6227       return RMS$_FNF;
6228     }
6229
6230 #if __CRTL_VER >= 80200000
6231   /* If not a posix spec already, convert it */
6232   if (decc_posix_compliant_pathnames) {
6233     if (strncmp(unixpath,"\"^UP^",5) != 0) {
6234       sprintf(vmspath,"\"^UP^%s\"",unixpath);
6235     }
6236     else {
6237       /* This is already a VMS specification, no conversion */
6238       unixlen--;
6239       strncpy(vmspath,unixpath, vmspath_len);
6240     }
6241   }
6242   else
6243 #endif
6244   {
6245   int path_len;
6246   int i,j;
6247
6248      /* Check to see if this is under the POSIX root */
6249      if (decc_disable_posix_root) {
6250         return RMS$_FNF;
6251      }
6252
6253      /* Skip leading / */
6254      if (unixpath[0] == '/') {
6255         unixpath++;
6256         unixlen--;
6257      }
6258
6259
6260      strcpy(vmspath,"SYS$POSIX_ROOT:");
6261
6262      /* If this is only the / , or blank, then... */
6263      if (unixpath[0] == '\0') {
6264         /* by definition, this is the answer */
6265         return SS$_NORMAL;
6266      }
6267
6268      /* Need to look up a directory */
6269      vmspath[15] = '[';
6270      vmspath[16] = '\0';
6271
6272      /* Copy and add '^' escape characters as needed */
6273      j = 16;
6274      i = 0;
6275      while (unixpath[i] != 0) {
6276      int k;
6277
6278         j += copy_expand_unix_filename_escape
6279             (&vmspath[j], &unixpath[i], &k, utf8_fl);
6280         i += k;
6281      }
6282
6283      path_len = strlen(vmspath);
6284      if (vmspath[path_len - 1] == '/')
6285         path_len--;
6286      vmspath[path_len] = ']';
6287      path_len++;
6288      vmspath[path_len] = '\0';
6289
6290   }
6291   vmspath[vmspath_len] = 0;
6292   if (unixpath[unixlen - 1] == '/')
6293   dir_flag = 1;
6294   esa = PerlMem_malloc(VMS_MAXRSS);
6295   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6296   myfab.fab$l_fna = vmspath;
6297   myfab.fab$b_fns = strlen(vmspath);
6298   myfab.fab$l_naml = &mynam;
6299   mynam.naml$l_esa = NULL;
6300   mynam.naml$b_ess = 0;
6301   mynam.naml$l_long_expand = esa;
6302   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6303   mynam.naml$l_rsa = NULL;
6304   mynam.naml$b_rss = 0;
6305   if (decc_efs_case_preserve)
6306     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6307 #ifdef NAML$M_OPEN_SPECIAL
6308   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6309 #endif
6310
6311   /* Set up the remaining naml fields */
6312   sts = sys$parse(&myfab);
6313
6314   /* It failed! Try again as a UNIX filespec */
6315   if (!(sts & 1)) {
6316     PerlMem_free(esa);
6317     return sts;
6318   }
6319
6320    /* get the Device ID and the FID */
6321    sts = sys$search(&myfab);
6322    /* on any failure, returned the POSIX ^UP^ filespec */
6323    if (!(sts & 1)) {
6324       PerlMem_free(esa);
6325       return sts;
6326    }
6327    specdsc.dsc$a_pointer = vmspath;
6328    specdsc.dsc$w_length = vmspath_len;
6329
6330    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6331    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6332    sts = lib$fid_to_name
6333       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6334
6335   /* on any failure, returned the POSIX ^UP^ filespec */
6336   if (!(sts & 1)) {
6337      /* This can happen if user does not have permission to read directories */
6338      if (strncmp(unixpath,"\"^UP^",5) != 0)
6339        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6340      else
6341        strcpy(vmspath, unixpath);
6342   }
6343   else {
6344     vmspath[specdsc.dsc$w_length] = 0;
6345
6346     /* Are we expecting a directory? */
6347     if (dir_flag != 0) {
6348     int i;
6349     char *eptr;
6350
6351       eptr = NULL;
6352
6353       i = specdsc.dsc$w_length - 1;
6354       while (i > 0) {
6355       int zercnt;
6356         zercnt = 0;
6357         /* Version must be '1' */
6358         if (vmspath[i--] != '1')
6359           break;
6360         /* Version delimiter is one of ".;" */
6361         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6362           break;
6363         i--;
6364         if (vmspath[i--] != 'R')
6365           break;
6366         if (vmspath[i--] != 'I')
6367           break;
6368         if (vmspath[i--] != 'D')
6369           break;
6370         if (vmspath[i--] != '.')
6371           break;
6372         eptr = &vmspath[i+1];
6373         while (i > 0) {
6374           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6375             if (vmspath[i-1] != '^') {
6376               if (zercnt != 6) {
6377                 *eptr = vmspath[i];
6378                 eptr[1] = '\0';
6379                 vmspath[i] = '.';
6380                 break;
6381               }
6382               else {
6383                 /* Get rid of 6 imaginary zero directory filename */
6384                 vmspath[i+1] = '\0';
6385               }
6386             }
6387           }
6388           if (vmspath[i] == '0')
6389             zercnt++;
6390           else
6391             zercnt = 10;
6392           i--;
6393         }
6394         break;
6395       }
6396     }
6397   }
6398   PerlMem_free(esa);
6399   return sts;
6400 }
6401
6402 /* /dev/mumble needs to be handled special.
6403    /dev/null becomes NLA0:, And there is the potential for other stuff
6404    like /dev/tty which may need to be mapped to something.
6405 */
6406
6407 static int
6408 slash_dev_special_to_vms
6409    (const char * unixptr,
6410     char * vmspath,
6411     int vmspath_len)
6412 {
6413 char * nextslash;
6414 int len;
6415 int cmp;
6416 int islnm;
6417
6418     unixptr += 4;
6419     nextslash = strchr(unixptr, '/');
6420     len = strlen(unixptr);
6421     if (nextslash != NULL)
6422         len = nextslash - unixptr;
6423     cmp = strncmp("null", unixptr, 5);
6424     if (cmp == 0) {
6425         if (vmspath_len >= 6) {
6426             strcpy(vmspath, "_NLA0:");
6427             return SS$_NORMAL;
6428         }
6429     }
6430 }
6431
6432
6433 /* The built in routines do not understand perl's special needs, so
6434     doing a manual conversion from UNIX to VMS
6435
6436     If the utf8_fl is not null and points to a non-zero value, then
6437     treat 8 bit characters as UTF-8.
6438
6439     The sequence starting with '$(' and ending with ')' will be passed
6440     through with out interpretation instead of being escaped.
6441
6442   */
6443 static int posix_to_vmsspec_hardway
6444   (char *vmspath, int vmspath_len,
6445    const char *unixpath,
6446    int dir_flag,
6447    int * utf8_fl) {
6448
6449 char *esa;
6450 const char *unixptr;
6451 const char *unixend;
6452 char *vmsptr;
6453 const char *lastslash;
6454 const char *lastdot;
6455 int unixlen;
6456 int vmslen;
6457 int dir_start;
6458 int dir_dot;
6459 int quoted;
6460 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6461 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6462
6463   if (utf8_fl != NULL)
6464     *utf8_fl = 0;
6465
6466   unixptr = unixpath;
6467   dir_dot = 0;
6468
6469   /* Ignore leading "/" characters */
6470   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6471     unixptr++;
6472   }
6473   unixlen = strlen(unixptr);
6474
6475   /* Do nothing with blank paths */
6476   if (unixlen == 0) {
6477     vmspath[0] = '\0';
6478     return SS$_NORMAL;
6479   }
6480
6481   quoted = 0;
6482   /* This could have a "^UP^ on the front */
6483   if (strncmp(unixptr,"\"^UP^",5) == 0) {
6484     quoted = 1;
6485     unixptr+= 5;
6486     unixlen-= 5;
6487   }
6488
6489   lastslash = strrchr(unixptr,'/');
6490   lastdot = strrchr(unixptr,'.');
6491   unixend = strrchr(unixptr,'\"');
6492   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6493     unixend = unixptr + unixlen;
6494   }
6495
6496   /* last dot is last dot or past end of string */
6497   if (lastdot == NULL)
6498     lastdot = unixptr + unixlen;
6499
6500   /* if no directories, set last slash to beginning of string */
6501   if (lastslash == NULL) {
6502     lastslash = unixptr;
6503   }
6504   else {
6505     /* Watch out for trailing "." after last slash, still a directory */
6506     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6507       lastslash = unixptr + unixlen;
6508     }
6509
6510     /* Watch out for traiing ".." after last slash, still a directory */
6511     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6512       lastslash = unixptr + unixlen;
6513     }
6514
6515     /* dots in directories are aways escaped */
6516     if (lastdot < lastslash)
6517       lastdot = unixptr + unixlen;
6518   }
6519
6520   /* if (unixptr < lastslash) then we are in a directory */
6521
6522   dir_start = 0;
6523
6524   vmsptr = vmspath;
6525   vmslen = 0;
6526
6527   /* Start with the UNIX path */
6528   if (*unixptr != '/') {
6529     /* relative paths */
6530
6531     /* If allowing logical names on relative pathnames, then handle here */
6532     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6533         !decc_posix_compliant_pathnames) {
6534     char * nextslash;
6535     int seg_len;
6536     char * trn;
6537     int islnm;
6538
6539         /* Find the next slash */
6540         nextslash = strchr(unixptr,'/');
6541
6542         esa = PerlMem_malloc(vmspath_len);
6543         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6544
6545         trn = PerlMem_malloc(VMS_MAXRSS);
6546         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6547
6548         if (nextslash != NULL) {
6549
6550             seg_len = nextslash - unixptr;
6551             strncpy(esa, unixptr, seg_len);
6552             esa[seg_len] = 0;
6553         }
6554         else {
6555             strcpy(esa, unixptr);
6556             seg_len = strlen(unixptr);
6557         }
6558         /* trnlnm(section) */
6559         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6560
6561         if (islnm) {
6562             /* Now fix up the directory */
6563
6564             /* Split up the path to find the components */
6565             sts = vms_split_path
6566                   (trn,
6567                    &v_spec,
6568                    &v_len,
6569                    &r_spec,
6570                    &r_len,
6571                    &d_spec,
6572                    &d_len,
6573                    &n_spec,
6574                    &n_len,
6575                    &e_spec,
6576                    &e_len,
6577                    &vs_spec,
6578                    &vs_len);
6579
6580             while (sts == 0) {
6581             char * strt;
6582             int cmp;
6583
6584                 /* A logical name must be a directory  or the full
6585                    specification.  It is only a full specification if
6586                    it is the only component */
6587                 if ((unixptr[seg_len] == '\0') ||
6588                     (unixptr[seg_len+1] == '\0')) {
6589
6590                     /* Is a directory being required? */
6591                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6592                         /* Not a logical name */
6593                         break;
6594                     }
6595
6596
6597                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6598                         /* This must be a directory */
6599                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6600                             strcpy(vmsptr, esa);
6601                             vmslen=strlen(vmsptr);
6602                             vmsptr[vmslen] = ':';
6603                             vmslen++;
6604                             vmsptr[vmslen] = '\0';
6605                             return SS$_NORMAL;
6606                         }
6607                     }
6608
6609                 }
6610
6611
6612                 /* must be dev/directory - ignore version */
6613                 if ((n_len + e_len) != 0)
6614                     break;
6615
6616                 /* transfer the volume */
6617                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6618                     strncpy(vmsptr, v_spec, v_len);
6619                     vmsptr += v_len;
6620                     vmsptr[0] = '\0';
6621                     vmslen += v_len;
6622                 }
6623
6624                 /* unroot the rooted directory */
6625                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6626                     r_spec[0] = '[';
6627                     r_spec[r_len - 1] = ']';
6628
6629                     /* This should not be there, but nothing is perfect */
6630                     if (r_len > 9) {
6631                         cmp = strcmp(&r_spec[1], "000000.");
6632                         if (cmp == 0) {
6633                             r_spec += 7;
6634                             r_spec[7] = '[';
6635                             r_len -= 7;
6636                             if (r_len == 2)
6637                                 r_len = 0;
6638                         }
6639                     }
6640                     if (r_len > 0) {
6641                         strncpy(vmsptr, r_spec, r_len);
6642                         vmsptr += r_len;
6643                         vmslen += r_len;
6644                         vmsptr[0] = '\0';
6645                     }
6646                 }
6647                 /* Bring over the directory. */
6648                 if ((d_len > 0) &&
6649                     ((d_len + vmslen) < vmspath_len)) {
6650                     d_spec[0] = '[';
6651                     d_spec[d_len - 1] = ']';
6652                     if (d_len > 9) {
6653                         cmp = strcmp(&d_spec[1], "000000.");
6654                         if (cmp == 0) {
6655                             d_spec += 7;
6656                             d_spec[7] = '[';
6657                             d_len -= 7;
6658                             if (d_len == 2)
6659                                 d_len = 0;
6660                         }
6661                     }
6662
6663                     if (r_len > 0) {
6664                         /* Remove the redundant root */
6665                         if (r_len > 0) {
6666                             /* remove the ][ */
6667                             vmsptr--;
6668                             vmslen--;
6669                             d_spec++;
6670                             d_len--;
6671                         }
6672                         strncpy(vmsptr, d_spec, d_len);
6673                             vmsptr += d_len;
6674                             vmslen += d_len;
6675                             vmsptr[0] = '\0';
6676                     }
6677                 }
6678                 break;
6679             }
6680         }
6681
6682         PerlMem_free(esa);
6683         PerlMem_free(trn);
6684     }
6685
6686     if (lastslash > unixptr) {
6687     int dotdir_seen;
6688
6689       /* skip leading ./ */
6690       dotdir_seen = 0;
6691       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6692         dotdir_seen = 1;
6693         unixptr++;
6694         unixptr++;
6695       }
6696
6697       /* Are we still in a directory? */
6698       if (unixptr <= lastslash) {
6699         *vmsptr++ = '[';
6700         vmslen = 1;
6701         dir_start = 1;
6702
6703         /* if not backing up, then it is relative forward. */
6704         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6705               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6706           *vmsptr++ = '.';
6707           vmslen++;
6708           dir_dot = 1;
6709           }
6710        }
6711        else {
6712          if (dotdir_seen) {
6713            /* Perl wants an empty directory here to tell the difference
6714             * between a DCL commmand and a filename
6715             */
6716           *vmsptr++ = '[';
6717           *vmsptr++ = ']';
6718           vmslen = 2;
6719         }
6720       }
6721     }
6722     else {
6723       /* Handle two special files . and .. */
6724       if (unixptr[0] == '.') {
6725         if (&unixptr[1] == unixend) {
6726           *vmsptr++ = '[';
6727           *vmsptr++ = ']';
6728           vmslen += 2;
6729           *vmsptr++ = '\0';
6730           return SS$_NORMAL;
6731         }
6732         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6733           *vmsptr++ = '[';
6734           *vmsptr++ = '-';
6735           *vmsptr++ = ']';
6736           vmslen += 3;
6737           *vmsptr++ = '\0';
6738           return SS$_NORMAL;
6739         }
6740       }
6741     }
6742   }
6743   else {        /* Absolute PATH handling */
6744   int sts;
6745   char * nextslash;
6746   int seg_len;
6747     /* Need to find out where root is */
6748
6749     /* In theory, this procedure should never get an absolute POSIX pathname
6750      * that can not be found on the POSIX root.
6751      * In practice, that can not be relied on, and things will show up
6752      * here that are a VMS device name or concealed logical name instead.
6753      * So to make things work, this procedure must be tolerant.
6754      */
6755     esa = PerlMem_malloc(vmspath_len);
6756     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6757
6758     sts = SS$_NORMAL;
6759     nextslash = strchr(&unixptr[1],'/');
6760     seg_len = 0;
6761     if (nextslash != NULL) {
6762     int cmp;
6763       seg_len = nextslash - &unixptr[1];
6764       strncpy(vmspath, unixptr, seg_len + 1);
6765       vmspath[seg_len+1] = 0;
6766       cmp = 1;
6767       if (seg_len == 3) {
6768         cmp = strncmp(vmspath, "dev", 4);
6769         if (cmp == 0) {
6770             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6771             if (sts = SS$_NORMAL)
6772                 return SS$_NORMAL;
6773         }
6774       }
6775       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6776     }
6777
6778     if ($VMS_STATUS_SUCCESS(sts)) {
6779       /* This is verified to be a real path */
6780
6781       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6782       if ($VMS_STATUS_SUCCESS(sts)) {
6783         strcpy(vmspath, esa);
6784         vmslen = strlen(vmspath);
6785         vmsptr = vmspath + vmslen;
6786         unixptr++;
6787         if (unixptr < lastslash) {
6788         char * rptr;
6789           vmsptr--;
6790           *vmsptr++ = '.';
6791           dir_start = 1;
6792           dir_dot = 1;
6793           if (vmslen > 7) {
6794           int cmp;
6795             rptr = vmsptr - 7;
6796             cmp = strcmp(rptr,"000000.");
6797             if (cmp == 0) {
6798               vmslen -= 7;
6799               vmsptr -= 7;
6800               vmsptr[1] = '\0';
6801             } /* removing 6 zeros */
6802           } /* vmslen < 7, no 6 zeros possible */
6803         } /* Not in a directory */
6804       } /* Posix root found */
6805       else {
6806         /* No posix root, fall back to default directory */
6807         strcpy(vmspath, "SYS$DISK:[");
6808         vmsptr = &vmspath[10];
6809         vmslen = 10;
6810         if (unixptr > lastslash) {
6811            *vmsptr = ']';
6812            vmsptr++;
6813            vmslen++;
6814         }
6815         else {
6816            dir_start = 1;
6817         }
6818       }
6819     } /* end of verified real path handling */
6820     else {
6821     int add_6zero;
6822     int islnm;
6823
6824       /* Ok, we have a device or a concealed root that is not in POSIX
6825        * or we have garbage.  Make the best of it.
6826        */
6827
6828       /* Posix to VMS destroyed this, so copy it again */
6829       strncpy(vmspath, &unixptr[1], seg_len);
6830       vmspath[seg_len] = 0;
6831       vmslen = seg_len;
6832       vmsptr = &vmsptr[vmslen];
6833       islnm = 0;
6834
6835       /* Now do we need to add the fake 6 zero directory to it? */
6836       add_6zero = 1;
6837       if ((*lastslash == '/') && (nextslash < lastslash)) {
6838         /* No there is another directory */
6839         add_6zero = 0;
6840       }
6841       else {
6842       int trnend;
6843       int cmp;
6844
6845         /* now we have foo:bar or foo:[000000]bar to decide from */
6846         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6847
6848         if (!islnm && !decc_posix_compliant_pathnames) {
6849
6850             cmp = strncmp("bin", vmspath, 4);
6851             if (cmp == 0) {
6852                 /* bin => SYS$SYSTEM: */
6853                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6854             }
6855             else {
6856                 /* tmp => SYS$SCRATCH: */
6857                 cmp = strncmp("tmp", vmspath, 4);
6858                 if (cmp == 0) {
6859                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6860                 }
6861             }
6862         }
6863
6864         trnend = islnm ? islnm - 1 : 0;
6865
6866         /* if this was a logical name, ']' or '>' must be present */
6867         /* if not a logical name, then assume a device and hope. */
6868         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6869
6870         /* if log name and trailing '.' then rooted - treat as device */
6871         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6872
6873         /* Fix me, if not a logical name, a device lookup should be
6874          * done to see if the device is file structured.  If the device
6875          * is not file structured, the 6 zeros should not be put on.
6876          *
6877          * As it is, perl is occasionally looking for dev:[000000]tty.
6878          * which looks a little strange.
6879          *
6880          * Not that easy to detect as "/dev" may be file structured with
6881          * special device files.
6882          */
6883
6884         if ((add_6zero == 0) && (*nextslash == '/') &&
6885             (&nextslash[1] == unixend)) {
6886           /* No real directory present */
6887           add_6zero = 1;
6888         }
6889       }
6890
6891       /* Put the device delimiter on */
6892       *vmsptr++ = ':';
6893       vmslen++;
6894       unixptr = nextslash;
6895       unixptr++;
6896
6897       /* Start directory if needed */
6898       if (!islnm || add_6zero) {
6899         *vmsptr++ = '[';
6900         vmslen++;
6901         dir_start = 1;
6902       }
6903
6904       /* add fake 000000] if needed */
6905       if (add_6zero) {
6906         *vmsptr++ = '0';
6907         *vmsptr++ = '0';
6908         *vmsptr++ = '0';
6909         *vmsptr++ = '0';
6910         *vmsptr++ = '0';
6911         *vmsptr++ = '0';
6912         *vmsptr++ = ']';
6913         vmslen += 7;
6914         dir_start = 0;
6915       }
6916
6917     } /* non-POSIX translation */
6918     PerlMem_free(esa);
6919   } /* End of relative/absolute path handling */
6920
6921   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6922   int dash_flag;
6923   int in_cnt;
6924   int out_cnt;
6925
6926     dash_flag = 0;
6927
6928     if (dir_start != 0) {
6929
6930       /* First characters in a directory are handled special */
6931       while ((*unixptr == '/') ||
6932              ((*unixptr == '.') &&
6933               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6934                 (&unixptr[1]==unixend)))) {
6935       int loop_flag;
6936
6937         loop_flag = 0;
6938
6939         /* Skip redundant / in specification */
6940         while ((*unixptr == '/') && (dir_start != 0)) {
6941           loop_flag = 1;
6942           unixptr++;
6943           if (unixptr == lastslash)
6944             break;
6945         }
6946         if (unixptr == lastslash)
6947           break;
6948
6949         /* Skip redundant ./ characters */
6950         while ((*unixptr == '.') &&
6951                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6952           loop_flag = 1;
6953           unixptr++;
6954           if (unixptr == lastslash)
6955             break;
6956           if (*unixptr == '/')
6957             unixptr++;
6958         }
6959         if (unixptr == lastslash)
6960           break;
6961
6962         /* Skip redundant ../ characters */
6963         while ((*unixptr == '.') && (unixptr[1] == '.') &&
6964              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6965           /* Set the backing up flag */
6966           loop_flag = 1;
6967           dir_dot = 0;
6968           dash_flag = 1;
6969           *vmsptr++ = '-';
6970           vmslen++;
6971           unixptr++; /* first . */
6972           unixptr++; /* second . */
6973           if (unixptr == lastslash)
6974             break;
6975           if (*unixptr == '/') /* The slash */
6976             unixptr++;
6977         }
6978         if (unixptr == lastslash)
6979           break;
6980
6981         /* To do: Perl expects /.../ to be translated to [...] on VMS */
6982         /* Not needed when VMS is pretending to be UNIX. */
6983
6984         /* Is this loop stuck because of too many dots? */
6985         if (loop_flag == 0) {
6986           /* Exit the loop and pass the rest through */
6987           break;
6988         }
6989       }
6990
6991       /* Are we done with directories yet? */
6992       if (unixptr >= lastslash) {
6993
6994         /* Watch out for trailing dots */
6995         if (dir_dot != 0) {
6996             vmslen --;
6997             vmsptr--;
6998         }
6999         *vmsptr++ = ']';
7000         vmslen++;
7001         dash_flag = 0;
7002         dir_start = 0;
7003         if (*unixptr == '/')
7004           unixptr++;
7005       }
7006       else {
7007         /* Have we stopped backing up? */
7008         if (dash_flag) {
7009           *vmsptr++ = '.';
7010           vmslen++;
7011           dash_flag = 0;
7012           /* dir_start continues to be = 1 */
7013         }
7014         if (*unixptr == '-') {
7015           *vmsptr++ = '^';
7016           *vmsptr++ = *unixptr++;
7017           vmslen += 2;
7018           dir_start = 0;
7019
7020           /* Now are we done with directories yet? */
7021           if (unixptr >= lastslash) {
7022
7023             /* Watch out for trailing dots */
7024             if (dir_dot != 0) {
7025               vmslen --;
7026               vmsptr--;
7027             }
7028
7029             *vmsptr++ = ']';
7030             vmslen++;
7031             dash_flag = 0;
7032             dir_start = 0;
7033           }
7034         }
7035       }
7036     }
7037
7038     /* All done? */
7039     if (unixptr >= unixend)
7040       break;
7041
7042     /* Normal characters - More EFS work probably needed */
7043     dir_start = 0;
7044     dir_dot = 0;
7045
7046     switch(*unixptr) {
7047     case '/':
7048         /* remove multiple / */
7049         while (unixptr[1] == '/') {
7050            unixptr++;
7051         }
7052         if (unixptr == lastslash) {
7053           /* Watch out for trailing dots */
7054           if (dir_dot != 0) {
7055             vmslen --;
7056             vmsptr--;
7057           }
7058           *vmsptr++ = ']';
7059         }
7060         else {
7061           dir_start = 1;
7062           *vmsptr++ = '.';
7063           dir_dot = 1;
7064
7065           /* To do: Perl expects /.../ to be translated to [...] on VMS */
7066           /* Not needed when VMS is pretending to be UNIX. */
7067
7068         }
7069         dash_flag = 0;
7070         if (unixptr != unixend)
7071           unixptr++;
7072         vmslen++;
7073         break;
7074     case '.':
7075         if ((unixptr < lastdot) || (unixptr < lastslash) ||
7076             (&unixptr[1] == unixend)) {
7077           *vmsptr++ = '^';
7078           *vmsptr++ = '.';
7079           vmslen += 2;
7080           unixptr++;
7081
7082           /* trailing dot ==> '^..' on VMS */
7083           if (unixptr == unixend) {
7084             *vmsptr++ = '.';
7085             vmslen++;
7086             unixptr++;
7087           }
7088           break;
7089         }
7090
7091         *vmsptr++ = *unixptr++;
7092         vmslen ++;
7093         break;
7094     case '"':
7095         if (quoted && (&unixptr[1] == unixend)) {
7096             unixptr++;
7097             break;
7098         }
7099         in_cnt = copy_expand_unix_filename_escape
7100                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7101         vmsptr += out_cnt;
7102         unixptr += in_cnt;
7103         break;
7104     case '~':
7105     case ';':
7106     case '\\':
7107     case '?':
7108     case ' ':
7109     default:
7110         in_cnt = copy_expand_unix_filename_escape
7111                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7112         vmsptr += out_cnt;
7113         unixptr += in_cnt;
7114         break;
7115     }
7116   }
7117
7118   /* Make sure directory is closed */
7119   if (unixptr == lastslash) {
7120     char *vmsptr2;
7121     vmsptr2 = vmsptr - 1;
7122
7123     if (*vmsptr2 != ']') {
7124       *vmsptr2--;
7125
7126       /* directories do not end in a dot bracket */
7127       if (*vmsptr2 == '.') {
7128         vmsptr2--;
7129
7130         /* ^. is allowed */
7131         if (*vmsptr2 != '^') {
7132           vmsptr--; /* back up over the dot */
7133         }
7134       }
7135       *vmsptr++ = ']';
7136     }
7137   }
7138   else {
7139     char *vmsptr2;
7140     /* Add a trailing dot if a file with no extension */
7141     vmsptr2 = vmsptr - 1;
7142     if ((vmslen > 1) &&
7143         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7144         (*vmsptr2 != ')') && (*lastdot != '.')) {
7145         *vmsptr++ = '.';
7146         vmslen++;
7147     }
7148   }
7149
7150   *vmsptr = '\0';
7151   return SS$_NORMAL;
7152 }
7153 #endif
7154
7155  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7156 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7157 {
7158 char * result;
7159 int utf8_flag;
7160
7161    /* If a UTF8 flag is being passed, honor it */
7162    utf8_flag = 0;
7163    if (utf8_fl != NULL) {
7164      utf8_flag = *utf8_fl;
7165     *utf8_fl = 0;
7166    }
7167
7168    if (utf8_flag) {
7169      /* If there is a possibility of UTF8, then if any UTF8 characters
7170         are present, then they must be converted to VTF-7
7171       */
7172      result = strcpy(rslt, path); /* FIX-ME */
7173    }
7174    else
7175      result = strcpy(rslt, path);
7176
7177    return result;
7178 }
7179
7180
7181 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7182 static char *mp_do_tovmsspec
7183    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7184   static char __tovmsspec_retbuf[VMS_MAXRSS];
7185   char *rslt, *dirend;
7186   char *lastdot;
7187   char *vms_delim;
7188   register char *cp1;
7189   const char *cp2;
7190   unsigned long int infront = 0, hasdir = 1;
7191   int rslt_len;
7192   int no_type_seen;
7193   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7194   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7195
7196   if (path == NULL) return NULL;
7197   rslt_len = VMS_MAXRSS-1;
7198   if (buf) rslt = buf;
7199   else if (ts) Newx(rslt, VMS_MAXRSS, char);
7200   else rslt = __tovmsspec_retbuf;
7201
7202   /* '.' and '..' are "[]" and "[-]" for a quick check */
7203   if (path[0] == '.') {
7204     if (path[1] == '\0') {
7205       strcpy(rslt,"[]");
7206       if (utf8_flag != NULL)
7207         *utf8_flag = 0;
7208       return rslt;
7209     }
7210     else {
7211       if (path[1] == '.' && path[2] == '\0') {
7212         strcpy(rslt,"[-]");
7213         if (utf8_flag != NULL)
7214            *utf8_flag = 0;
7215         return rslt;
7216       }
7217     }
7218   }
7219
7220    /* Posix specifications are now a native VMS format */
7221   /*--------------------------------------------------*/
7222 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7223   if (decc_posix_compliant_pathnames) {
7224     if (strncmp(path,"\"^UP^",5) == 0) {
7225       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7226       return rslt;
7227     }
7228   }
7229 #endif
7230
7231   /* This is really the only way to see if this is already in VMS format */
7232   sts = vms_split_path
7233        (path,
7234         &v_spec,
7235         &v_len,
7236         &r_spec,
7237         &r_len,
7238         &d_spec,
7239         &d_len,
7240         &n_spec,
7241         &n_len,
7242         &e_spec,
7243         &e_len,
7244         &vs_spec,
7245         &vs_len);
7246   if (sts == 0) {
7247     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7248        replacement, because the above parse just took care of most of
7249        what is needed to do vmspath when the specification is already
7250        in VMS format.
7251
7252        And if it is not already, it is easier to do the conversion as
7253        part of this routine than to call this routine and then work on
7254        the result.
7255      */
7256
7257     /* If VMS punctuation was found, it is already VMS format */
7258     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7259       if (utf8_flag != NULL)
7260         *utf8_flag = 0;
7261       strcpy(rslt, path);
7262       return rslt;
7263     }
7264     /* Now, what to do with trailing "." cases where there is no
7265        extension?  If this is a UNIX specification, and EFS characters
7266        are enabled, then the trailing "." should be converted to a "^.".
7267        But if this was already a VMS specification, then it should be
7268        left alone.
7269
7270        So in the case of ambiguity, leave the specification alone.
7271      */
7272
7273
7274     /* If there is a possibility of UTF8, then if any UTF8 characters
7275         are present, then they must be converted to VTF-7
7276      */
7277     if (utf8_flag != NULL)
7278       *utf8_flag = 0;
7279     strcpy(rslt, path);
7280     return rslt;
7281   }
7282
7283   dirend = strrchr(path,'/');
7284
7285   if (dirend == NULL) {
7286      /* If we get here with no UNIX directory delimiters, then this is
7287         not a complete file specification, either garbage a UNIX glob
7288         specification that can not be converted to a VMS wildcard, or
7289         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7290         so apparently other programs expect this also.
7291
7292         utf8 flag setting needs to be preserved.
7293       */
7294       strcpy(rslt, path);
7295       return rslt;
7296   }
7297
7298 /* If POSIX mode active, handle the conversion */
7299 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7300   if (decc_efs_charset) {
7301     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7302     return rslt;
7303   }
7304 #endif
7305
7306   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7307     if (!*(dirend+2)) dirend +=2;
7308     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7309     if (decc_efs_charset == 0) {
7310       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7311     }
7312   }
7313
7314   cp1 = rslt;
7315   cp2 = path;
7316   lastdot = strrchr(cp2,'.');
7317   if (*cp2 == '/') {
7318     char *trndev;
7319     int islnm, rooted;
7320     STRLEN trnend;
7321
7322     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7323     if (!*(cp2+1)) {
7324       if (decc_disable_posix_root) {
7325         strcpy(rslt,"sys$disk:[000000]");
7326       }
7327       else {
7328         strcpy(rslt,"sys$posix_root:[000000]");
7329       }
7330       if (utf8_flag != NULL)
7331         *utf8_flag = 0;
7332       return rslt;
7333     }
7334     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7335     *cp1 = '\0';
7336     trndev = PerlMem_malloc(VMS_MAXRSS);
7337     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7338     islnm =  my_trnlnm(rslt,trndev,0);
7339
7340      /* DECC special handling */
7341     if (!islnm) {
7342       if (strcmp(rslt,"bin") == 0) {
7343         strcpy(rslt,"sys$system");
7344         cp1 = rslt + 10;
7345         *cp1 = 0;
7346         islnm =  my_trnlnm(rslt,trndev,0);
7347       }
7348       else if (strcmp(rslt,"tmp") == 0) {
7349         strcpy(rslt,"sys$scratch");
7350         cp1 = rslt + 11;
7351         *cp1 = 0;
7352         islnm =  my_trnlnm(rslt,trndev,0);
7353       }
7354       else if (!decc_disable_posix_root) {
7355         strcpy(rslt, "sys$posix_root");
7356         cp1 = rslt + 13;
7357         *cp1 = 0;
7358         cp2 = path;
7359         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7360         islnm =  my_trnlnm(rslt,trndev,0);
7361       }
7362       else if (strcmp(rslt,"dev") == 0) {
7363         if (strncmp(cp2,"/null", 5) == 0) {
7364           if ((cp2[5] == 0) || (cp2[5] == '/')) {
7365             strcpy(rslt,"NLA0");
7366             cp1 = rslt + 4;
7367             *cp1 = 0;
7368             cp2 = cp2 + 5;
7369             islnm =  my_trnlnm(rslt,trndev,0);
7370           }
7371         }
7372       }
7373     }
7374
7375     trnend = islnm ? strlen(trndev) - 1 : 0;
7376     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7377     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7378     /* If the first element of the path is a logical name, determine
7379      * whether it has to be translated so we can add more directories. */
7380     if (!islnm || rooted) {
7381       *(cp1++) = ':';
7382       *(cp1++) = '[';
7383       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7384       else cp2++;
7385     }
7386     else {
7387       if (cp2 != dirend) {
7388         strcpy(rslt,trndev);
7389         cp1 = rslt + trnend;
7390         if (*cp2 != 0) {
7391           *(cp1++) = '.';
7392           cp2++;
7393         }
7394       }
7395       else {
7396         if (decc_disable_posix_root) {
7397           *(cp1++) = ':';
7398           hasdir = 0;
7399         }
7400       }
7401     }
7402     PerlMem_free(trndev);
7403   }
7404   else {
7405     *(cp1++) = '[';
7406     if (*cp2 == '.') {
7407       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7408         cp2 += 2;         /* skip over "./" - it's redundant */
7409         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
7410       }
7411       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7412         *(cp1++) = '-';                                 /* "../" --> "-" */
7413         cp2 += 3;
7414       }
7415       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7416                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7417         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7418         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7419         cp2 += 4;
7420       }
7421       else if ((cp2 != lastdot) || (lastdot < dirend)) {
7422         /* Escape the extra dots in EFS file specifications */
7423         *(cp1++) = '^';
7424       }
7425       if (cp2 > dirend) cp2 = dirend;
7426     }
7427     else *(cp1++) = '.';
7428   }
7429   for (; cp2 < dirend; cp2++) {
7430     if (*cp2 == '/') {
7431       if (*(cp2-1) == '/') continue;
7432       if (*(cp1-1) != '.') *(cp1++) = '.';
7433       infront = 0;
7434     }
7435     else if (!infront && *cp2 == '.') {
7436       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7437       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
7438       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7439         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7440         else if (*(cp1-2) == '[') *(cp1-1) = '-';
7441         else {  /* back up over previous directory name */
7442           cp1--;
7443           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7444           if (*(cp1-1) == '[') {
7445             memcpy(cp1,"000000.",7);
7446             cp1 += 7;
7447           }
7448         }
7449         cp2 += 2;
7450         if (cp2 == dirend) break;
7451       }
7452       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7453                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7454         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7455         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7456         if (!*(cp2+3)) {
7457           *(cp1++) = '.';  /* Simulate trailing '/' */
7458           cp2 += 2;  /* for loop will incr this to == dirend */
7459         }
7460         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
7461       }
7462       else {
7463         if (decc_efs_charset == 0)
7464           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
7465         else {
7466           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
7467           *(cp1++) = '.';
7468         }
7469       }
7470     }
7471     else {
7472       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
7473       if (*cp2 == '.') {
7474         if (decc_efs_charset == 0)
7475           *(cp1++) = '_';
7476         else {
7477           *(cp1++) = '^';
7478           *(cp1++) = '.';
7479         }
7480       }
7481       else                  *(cp1++) =  *cp2;
7482       infront = 1;
7483     }
7484   }
7485   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7486   if (hasdir) *(cp1++) = ']';
7487   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
7488   /* fixme for ODS5 */
7489   no_type_seen = 0;
7490   if (cp2 > lastdot)
7491     no_type_seen = 1;
7492   while (*cp2) {
7493     switch(*cp2) {
7494     case '?':
7495         if (decc_efs_charset == 0)
7496           *(cp1++) = '%';
7497         else
7498           *(cp1++) = '?';
7499         cp2++;
7500     case ' ':
7501         *(cp1)++ = '^';
7502         *(cp1)++ = '_';
7503         cp2++;
7504         break;
7505     case '.':
7506         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7507             decc_readdir_dropdotnotype) {
7508           *(cp1)++ = '^';
7509           *(cp1)++ = '.';
7510           cp2++;
7511
7512           /* trailing dot ==> '^..' on VMS */
7513           if (*cp2 == '\0') {
7514             *(cp1++) = '.';
7515             no_type_seen = 0;
7516           }
7517         }
7518         else {
7519           *(cp1++) = *(cp2++);
7520           no_type_seen = 0;
7521         }
7522         break;
7523     case '$':
7524          /* This could be a macro to be passed through */
7525         *(cp1++) = *(cp2++);
7526         if (*cp2 == '(') {
7527         const char * save_cp2;
7528         char * save_cp1;
7529         int is_macro;
7530
7531             /* paranoid check */
7532             save_cp2 = cp2;
7533             save_cp1 = cp1;
7534             is_macro = 0;
7535
7536             /* Test through */
7537             *(cp1++) = *(cp2++);
7538             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7539                 *(cp1++) = *(cp2++);
7540                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7541                     *(cp1++) = *(cp2++);
7542                 }
7543                 if (*cp2 == ')') {
7544                     *(cp1++) = *(cp2++);
7545                     is_macro = 1;
7546                 }
7547             }
7548             if (is_macro == 0) {
7549                 /* Not really a macro - never mind */
7550                 cp2 = save_cp2;
7551                 cp1 = save_cp1;
7552             }
7553         }
7554         break;
7555     case '\"':
7556     case '~':
7557     case '`':
7558     case '!':
7559     case '#':
7560     case '%':
7561     case '^':
7562     case '&':
7563     case '(':
7564     case ')':
7565     case '=':
7566     case '+':
7567     case '\'':
7568     case '@':
7569     case '[':
7570     case ']':
7571     case '{':
7572     case '}':
7573     case ':':
7574     case '\\':
7575     case '|':
7576     case '<':
7577     case '>':
7578         *(cp1++) = '^';
7579         *(cp1++) = *(cp2++);
7580         break;
7581     case ';':
7582         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7583          * which is wrong.  UNIX notation should be ".dir." unless
7584          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7585          * changing this behavior could break more things at this time.
7586          * efs character set effectively does not allow "." to be a version
7587          * delimiter as a further complication about changing this.
7588          */
7589         if (decc_filename_unix_report != 0) {
7590           *(cp1++) = '^';
7591         }
7592         *(cp1++) = *(cp2++);
7593         break;
7594     default:
7595         *(cp1++) = *(cp2++);
7596     }
7597   }
7598   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7599   char *lcp1;
7600     lcp1 = cp1;
7601     lcp1--;
7602      /* Fix me for "^]", but that requires making sure that you do
7603       * not back up past the start of the filename
7604       */
7605     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7606       *cp1++ = '.';
7607   }
7608   *cp1 = '\0';
7609
7610   if (utf8_flag != NULL)
7611     *utf8_flag = 0;
7612   return rslt;
7613
7614 }  /* end of do_tovmsspec() */
7615 /*}}}*/
7616 /* External entry points */
7617 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7618   { return do_tovmsspec(path,buf,0,NULL); }
7619 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7620   { return do_tovmsspec(path,buf,1,NULL); }
7621 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7622   { return do_tovmsspec(path,buf,0,utf8_fl); }
7623 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7624   { return do_tovmsspec(path,buf,1,utf8_fl); }
7625
7626 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7627 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7628   static char __tovmspath_retbuf[VMS_MAXRSS];
7629   int vmslen;
7630   char *pathified, *vmsified, *cp;
7631
7632   if (path == NULL) return NULL;
7633   pathified = PerlMem_malloc(VMS_MAXRSS);
7634   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7635   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7636     PerlMem_free(pathified);
7637     return NULL;
7638   }
7639
7640   vmsified = NULL;
7641   if (buf == NULL)
7642      Newx(vmsified, VMS_MAXRSS, char);
7643   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7644     PerlMem_free(pathified);
7645     if (vmsified) Safefree(vmsified);
7646     return NULL;
7647   }
7648   PerlMem_free(pathified);
7649   if (buf) {
7650     return buf;
7651   }
7652   else if (ts) {
7653     vmslen = strlen(vmsified);
7654     Newx(cp,vmslen+1,char);
7655     memcpy(cp,vmsified,vmslen);
7656     cp[vmslen] = '\0';
7657     Safefree(vmsified);
7658     return cp;
7659   }
7660   else {
7661     strcpy(__tovmspath_retbuf,vmsified);
7662     Safefree(vmsified);
7663     return __tovmspath_retbuf;
7664   }
7665
7666 }  /* end of do_tovmspath() */
7667 /*}}}*/
7668 /* External entry points */
7669 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7670   { return do_tovmspath(path,buf,0, NULL); }
7671 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7672   { return do_tovmspath(path,buf,1, NULL); }
7673 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7674   { return do_tovmspath(path,buf,0,utf8_fl); }
7675 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7676   { return do_tovmspath(path,buf,1,utf8_fl); }
7677
7678
7679 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7680 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7681   static char __tounixpath_retbuf[VMS_MAXRSS];
7682   int unixlen;
7683   char *pathified, *unixified, *cp;
7684
7685   if (path == NULL) return NULL;
7686   pathified = PerlMem_malloc(VMS_MAXRSS);
7687   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7688   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7689     PerlMem_free(pathified);
7690     return NULL;
7691   }
7692
7693   unixified = NULL;
7694   if (buf == NULL) {
7695       Newx(unixified, VMS_MAXRSS, char);
7696   }
7697   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7698     PerlMem_free(pathified);
7699     if (unixified) Safefree(unixified);
7700     return NULL;
7701   }
7702   PerlMem_free(pathified);
7703   if (buf) {
7704     return buf;
7705   }
7706   else if (ts) {
7707     unixlen = strlen(unixified);
7708     Newx(cp,unixlen+1,char);
7709     memcpy(cp,unixified,unixlen);
7710     cp[unixlen] = '\0';
7711     Safefree(unixified);
7712     return cp;
7713   }
7714   else {
7715     strcpy(__tounixpath_retbuf,unixified);
7716     Safefree(unixified);
7717     return __tounixpath_retbuf;
7718   }
7719
7720 }  /* end of do_tounixpath() */
7721 /*}}}*/
7722 /* External entry points */
7723 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7724   { return do_tounixpath(path,buf,0,NULL); }
7725 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7726   { return do_tounixpath(path,buf,1,NULL); }
7727 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7728   { return do_tounixpath(path,buf,0,utf8_fl); }
7729 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7730   { return do_tounixpath(path,buf,1,utf8_fl); }
7731
7732 /*
7733  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
7734  *
7735  *****************************************************************************
7736  *                                                                           *
7737  *  Copyright (C) 1989-1994, 2007 by                                         *
7738  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
7739  *                                                                           *
7740  *  Permission is hereby granted for the reproduction of this software       *
7741  *  on condition that this copyright notice is included in source            *
7742  *  distributions of the software.  The code may be modified and             *
7743  *  distributed under the same terms as Perl itself.                         *
7744  *                                                                           *
7745  *  27-Aug-1994 Modified for inclusion in perl5                              *
7746  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
7747  *****************************************************************************
7748  */
7749
7750 /*
7751  * getredirection() is intended to aid in porting C programs
7752  * to VMS (Vax-11 C).  The native VMS environment does not support
7753  * '>' and '<' I/O redirection, or command line wild card expansion,
7754  * or a command line pipe mechanism using the '|' AND background
7755  * command execution '&'.  All of these capabilities are provided to any
7756  * C program which calls this procedure as the first thing in the
7757  * main program.
7758  * The piping mechanism will probably work with almost any 'filter' type
7759  * of program.  With suitable modification, it may useful for other
7760  * portability problems as well.
7761  *
7762  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
7763  */
7764 struct list_item
7765     {
7766     struct list_item *next;
7767     char *value;
7768     };
7769
7770 static void add_item(struct list_item **head,
7771                      struct list_item **tail,
7772                      char *value,
7773                      int *count);
7774
7775 static void mp_expand_wild_cards(pTHX_ char *item,
7776                                 struct list_item **head,
7777                                 struct list_item **tail,
7778                                 int *count);
7779
7780 static int background_process(pTHX_ int argc, char **argv);
7781
7782 static void pipe_and_fork(pTHX_ char **cmargv);
7783
7784 /*{{{ void getredirection(int *ac, char ***av)*/
7785 static void
7786 mp_getredirection(pTHX_ int *ac, char ***av)
7787 /*
7788  * Process vms redirection arg's.  Exit if any error is seen.
7789  * If getredirection() processes an argument, it is erased
7790  * from the vector.  getredirection() returns a new argc and argv value.
7791  * In the event that a background command is requested (by a trailing "&"),
7792  * this routine creates a background subprocess, and simply exits the program.
7793  *
7794  * Warning: do not try to simplify the code for vms.  The code
7795  * presupposes that getredirection() is called before any data is
7796  * read from stdin or written to stdout.
7797  *
7798  * Normal usage is as follows:
7799  *
7800  *      main(argc, argv)
7801  *      int             argc;
7802  *      char            *argv[];
7803  *      {
7804  *              getredirection(&argc, &argv);
7805  *      }
7806  */
7807 {
7808     int                 argc = *ac;     /* Argument Count         */
7809     char                **argv = *av;   /* Argument Vector        */
7810     char                *ap;            /* Argument pointer       */
7811     int                 j;              /* argv[] index           */
7812     int                 item_count = 0; /* Count of Items in List */
7813     struct list_item    *list_head = 0; /* First Item in List       */
7814     struct list_item    *list_tail;     /* Last Item in List        */
7815     char                *in = NULL;     /* Input File Name          */
7816     char                *out = NULL;    /* Output File Name         */
7817     char                *outmode = "w"; /* Mode to Open Output File */
7818     char                *err = NULL;    /* Error File Name          */
7819     char                *errmode = "w"; /* Mode to Open Error File  */
7820     int                 cmargc = 0;     /* Piped Command Arg Count  */
7821     char                **cmargv = NULL;/* Piped Command Arg Vector */
7822
7823     /*
7824      * First handle the case where the last thing on the line ends with
7825      * a '&'.  This indicates the desire for the command to be run in a
7826      * subprocess, so we satisfy that desire.
7827      */
7828     ap = argv[argc-1];
7829     if (0 == strcmp("&", ap))
7830        exit(background_process(aTHX_ --argc, argv));
7831     if (*ap && '&' == ap[strlen(ap)-1])
7832         {
7833         ap[strlen(ap)-1] = '\0';
7834        exit(background_process(aTHX_ argc, argv));
7835         }
7836     /*
7837      * Now we handle the general redirection cases that involve '>', '>>',
7838      * '<', and pipes '|'.
7839      */
7840     for (j = 0; j < argc; ++j)
7841         {
7842         if (0 == strcmp("<", argv[j]))
7843             {
7844             if (j+1 >= argc)
7845                 {
7846                 fprintf(stderr,"No input file after < on command line");
7847                 exit(LIB$_WRONUMARG);
7848                 }
7849             in = argv[++j];
7850             continue;
7851             }
7852         if ('<' == *(ap = argv[j]))
7853             {
7854             in = 1 + ap;
7855             continue;
7856             }
7857         if (0 == strcmp(">", ap))
7858             {
7859             if (j+1 >= argc)
7860                 {
7861                 fprintf(stderr,"No output file after > on command line");
7862                 exit(LIB$_WRONUMARG);
7863                 }
7864             out = argv[++j];
7865             continue;
7866             }
7867         if ('>' == *ap)
7868             {
7869             if ('>' == ap[1])
7870                 {
7871                 outmode = "a";
7872                 if ('\0' == ap[2])
7873                     out = argv[++j];
7874                 else
7875                     out = 2 + ap;
7876                 }
7877             else
7878                 out = 1 + ap;
7879             if (j >= argc)
7880                 {
7881                 fprintf(stderr,"No output file after > or >> on command line");
7882                 exit(LIB$_WRONUMARG);
7883                 }
7884             continue;
7885             }
7886         if (('2' == *ap) && ('>' == ap[1]))
7887             {
7888             if ('>' == ap[2])
7889                 {
7890                 errmode = "a";
7891                 if ('\0' == ap[3])
7892                     err = argv[++j];
7893                 else
7894                     err = 3 + ap;
7895                 }
7896             else
7897                 if ('\0' == ap[2])
7898                     err = argv[++j];
7899                 else
7900                     err = 2 + ap;
7901             if (j >= argc)
7902                 {
7903                 fprintf(stderr,"No output file after 2> or 2>> on command line");
7904                 exit(LIB$_WRONUMARG);
7905                 }
7906             continue;
7907             }
7908         if (0 == strcmp("|", argv[j]))
7909             {
7910             if (j+1 >= argc)
7911                 {
7912                 fprintf(stderr,"No command into which to pipe on command line");
7913                 exit(LIB$_WRONUMARG);
7914                 }
7915             cmargc = argc-(j+1);
7916             cmargv = &argv[j+1];
7917             argc = j;
7918             continue;
7919             }
7920         if ('|' == *(ap = argv[j]))
7921             {
7922             ++argv[j];
7923             cmargc = argc-j;
7924             cmargv = &argv[j];
7925             argc = j;
7926             continue;
7927             }
7928         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7929         }
7930     /*
7931      * Allocate and fill in the new argument vector, Some Unix's terminate
7932      * the list with an extra null pointer.
7933      */
7934     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7935     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7936     *av = argv;
7937     for (j = 0; j < item_count; ++j, list_head = list_head->next)
7938         argv[j] = list_head->value;
7939     *ac = item_count;
7940     if (cmargv != NULL)
7941         {
7942         if (out != NULL)
7943             {
7944             fprintf(stderr,"'|' and '>' may not both be specified on command line");
7945             exit(LIB$_INVARGORD);
7946             }
7947         pipe_and_fork(aTHX_ cmargv);
7948         }
7949
7950     /* Check for input from a pipe (mailbox) */
7951
7952     if (in == NULL && 1 == isapipe(0))
7953         {
7954         char mbxname[L_tmpnam];
7955         long int bufsize;
7956         long int dvi_item = DVI$_DEVBUFSIZ;
7957         $DESCRIPTOR(mbxnam, "");
7958         $DESCRIPTOR(mbxdevnam, "");
7959
7960         /* Input from a pipe, reopen it in binary mode to disable       */
7961         /* carriage control processing.                                 */
7962
7963         fgetname(stdin, mbxname);
7964         mbxnam.dsc$a_pointer = mbxname;
7965         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7966         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7967         mbxdevnam.dsc$a_pointer = mbxname;
7968         mbxdevnam.dsc$w_length = sizeof(mbxname);
7969         dvi_item = DVI$_DEVNAM;
7970         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7971         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7972         set_errno(0);
7973         set_vaxc_errno(1);
7974         freopen(mbxname, "rb", stdin);
7975         if (errno != 0)
7976             {
7977             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7978             exit(vaxc$errno);
7979             }
7980         }
7981     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7982         {
7983         fprintf(stderr,"Can't open input file %s as stdin",in);
7984         exit(vaxc$errno);
7985         }
7986     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7987         {
7988         fprintf(stderr,"Can't open output file %s as stdout",out);
7989         exit(vaxc$errno);
7990         }
7991         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7992
7993     if (err != NULL) {
7994         if (strcmp(err,"&1") == 0) {
7995             dup2(fileno(stdout), fileno(stderr));
7996             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7997         } else {
7998         FILE *tmperr;
7999         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8000             {
8001             fprintf(stderr,"Can't open error file %s as stderr",err);
8002             exit(vaxc$errno);
8003             }
8004             fclose(tmperr);
8005            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8006                 {
8007                 exit(vaxc$errno);
8008                 }
8009             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8010         }
8011         }
8012 #ifdef ARGPROC_DEBUG
8013     PerlIO_printf(Perl_debug_log, "Arglist:\n");
8014     for (j = 0; j < *ac;  ++j)
8015         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8016 #endif
8017    /* Clear errors we may have hit expanding wildcards, so they don't
8018       show up in Perl's $! later */
8019    set_errno(0); set_vaxc_errno(1);
8020 }  /* end of getredirection() */
8021 /*}}}*/
8022
8023 static void add_item(struct list_item **head,
8024                      struct list_item **tail,
8025                      char *value,
8026                      int *count)
8027 {
8028     if (*head == 0)
8029         {
8030         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8031         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8032         *tail = *head;
8033         }
8034     else {
8035         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8036         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8037         *tail = (*tail)->next;
8038         }
8039     (*tail)->value = value;
8040     ++(*count);
8041 }
8042
8043 static void mp_expand_wild_cards(pTHX_ char *item,
8044                               struct list_item **head,
8045                               struct list_item **tail,
8046                               int *count)
8047 {
8048 int expcount = 0;
8049 unsigned long int context = 0;
8050 int isunix = 0;
8051 int item_len = 0;
8052 char *had_version;
8053 char *had_device;
8054 int had_directory;
8055 char *devdir,*cp;
8056 char *vmsspec;
8057 $DESCRIPTOR(filespec, "");
8058 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8059 $DESCRIPTOR(resultspec, "");
8060 unsigned long int lff_flags = 0;
8061 int sts;
8062 int rms_sts;
8063
8064 #ifdef VMS_LONGNAME_SUPPORT
8065     lff_flags = LIB$M_FIL_LONG_NAMES;
8066 #endif
8067
8068     for (cp = item; *cp; cp++) {
8069         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8070         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8071     }
8072     if (!*cp || isspace(*cp))
8073         {
8074         add_item(head, tail, item, count);
8075         return;
8076         }
8077     else
8078         {
8079      /* "double quoted" wild card expressions pass as is */
8080      /* From DCL that means using e.g.:                  */
8081      /* perl program """perl.*"""                        */
8082      item_len = strlen(item);
8083      if ( '"' == *item && '"' == item[item_len-1] )
8084        {
8085        item++;
8086        item[item_len-2] = '\0';
8087        add_item(head, tail, item, count);
8088        return;
8089        }
8090      }
8091     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8092     resultspec.dsc$b_class = DSC$K_CLASS_D;
8093     resultspec.dsc$a_pointer = NULL;
8094     vmsspec = PerlMem_malloc(VMS_MAXRSS);
8095     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8096     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8097       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8098     if (!isunix || !filespec.dsc$a_pointer)
8099       filespec.dsc$a_pointer = item;
8100     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8101     /*
8102      * Only return version specs, if the caller specified a version
8103      */
8104     had_version = strchr(item, ';');
8105     /*
8106      * Only return device and directory specs, if the caller specifed either.
8107      */
8108     had_device = strchr(item, ':');
8109     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8110
8111     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8112                                  (&filespec, &resultspec, &context,
8113                                   &defaultspec, 0, &rms_sts, &lff_flags)))
8114         {
8115         char *string;
8116         char *c;
8117
8118         string = PerlMem_malloc(resultspec.dsc$w_length+1);
8119         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8120         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8121         string[resultspec.dsc$w_length] = '\0';
8122         if (NULL == had_version)
8123             *(strrchr(string, ';')) = '\0';
8124         if ((!had_directory) && (had_device == NULL))
8125             {
8126             if (NULL == (devdir = strrchr(string, ']')))
8127                 devdir = strrchr(string, '>');
8128             strcpy(string, devdir + 1);
8129             }
8130         /*
8131          * Be consistent with what the C RTL has already done to the rest of
8132          * the argv items and lowercase all of these names.
8133          */
8134         if (!decc_efs_case_preserve) {
8135             for (c = string; *c; ++c)
8136             if (isupper(*c))
8137                 *c = tolower(*c);
8138         }
8139         if (isunix) trim_unixpath(string,item,1);
8140         add_item(head, tail, string, count);
8141         ++expcount;
8142     }
8143     PerlMem_free(vmsspec);
8144     if (sts != RMS$_NMF)
8145         {
8146         set_vaxc_errno(sts);
8147         switch (sts)
8148             {
8149             case RMS$_FNF: case RMS$_DNF:
8150                 set_errno(ENOENT); break;
8151             case RMS$_DIR:
8152                 set_errno(ENOTDIR); break;
8153             case RMS$_DEV:
8154                 set_errno(ENODEV); break;
8155             case RMS$_FNM: case RMS$_SYN:
8156                 set_errno(EINVAL); break;
8157             case RMS$_PRV:
8158                 set_errno(EACCES); break;
8159             default:
8160                 _ckvmssts_noperl(sts);
8161             }
8162         }
8163     if (expcount == 0)
8164         add_item(head, tail, item, count);
8165     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8166     _ckvmssts_noperl(lib$find_file_end(&context));
8167 }
8168
8169 static int child_st[2];/* Event Flag set when child process completes   */
8170
8171 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
8172
8173 static unsigned long int exit_handler(int *status)
8174 {
8175 short iosb[4];
8176
8177     if (0 == child_st[0])
8178         {
8179 #ifdef ARGPROC_DEBUG
8180         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8181 #endif
8182         fflush(stdout);     /* Have to flush pipe for binary data to    */
8183                             /* terminate properly -- <tp@mccall.com>    */
8184         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8185         sys$dassgn(child_chan);
8186         fclose(stdout);
8187         sys$synch(0, child_st);
8188         }
8189     return(1);
8190 }
8191
8192 static void sig_child(int chan)
8193 {
8194 #ifdef ARGPROC_DEBUG
8195     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8196 #endif
8197     if (child_st[0] == 0)
8198         child_st[0] = 1;
8199 }
8200
8201 static struct exit_control_block exit_block =
8202     {
8203     0,
8204     exit_handler,
8205     1,
8206     &exit_block.exit_status,
8207     0
8208     };
8209
8210 static void
8211 pipe_and_fork(pTHX_ char **cmargv)
8212 {
8213     PerlIO *fp;
8214     struct dsc$descriptor_s *vmscmd;
8215     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8216     int sts, j, l, ismcr, quote, tquote = 0;
8217
8218     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8219     vms_execfree(vmscmd);
8220
8221     j = l = 0;
8222     p = subcmd;
8223     q = cmargv[0];
8224     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
8225               && toupper(*(q+2)) == 'R' && !*(q+3);
8226
8227     while (q && l < MAX_DCL_LINE_LENGTH) {
8228         if (!*q) {
8229             if (j > 0 && quote) {
8230                 *p++ = '"';
8231                 l++;
8232             }
8233             q = cmargv[++j];
8234             if (q) {
8235                 if (ismcr && j > 1) quote = 1;
8236                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
8237                 *p++ = ' ';
8238                 l++;
8239                 if (quote || tquote) {
8240                     *p++ = '"';
8241                     l++;
8242                 }
8243             }
8244         } else {
8245             if ((quote||tquote) && *q == '"') {
8246                 *p++ = '"';
8247                 l++;
8248             }
8249             *p++ = *q++;
8250             l++;
8251         }
8252     }
8253     *p = '\0';
8254
8255     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8256     if (fp == Nullfp) {
8257         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8258     }
8259 }
8260
8261 static int background_process(pTHX_ int argc, char **argv)
8262 {
8263 char command[MAX_DCL_SYMBOL + 1] = "$";
8264 $DESCRIPTOR(value, "");
8265 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8266 static $DESCRIPTOR(null, "NLA0:");
8267 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8268 char pidstring[80];
8269 $DESCRIPTOR(pidstr, "");
8270 int pid;
8271 unsigned long int flags = 17, one = 1, retsts;
8272 int len;
8273
8274     strcat(command, argv[0]);
8275     len = strlen(command);
8276     while (--argc && (len < MAX_DCL_SYMBOL))
8277         {
8278         strcat(command, " \"");
8279         strcat(command, *(++argv));
8280         strcat(command, "\"");
8281         len = strlen(command);
8282         }
8283     value.dsc$a_pointer = command;
8284     value.dsc$w_length = strlen(value.dsc$a_pointer);
8285     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8286     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8287     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8288         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8289     }
8290     else {
8291         _ckvmssts_noperl(retsts);
8292     }
8293 #ifdef ARGPROC_DEBUG
8294     PerlIO_printf(Perl_debug_log, "%s\n", command);
8295 #endif
8296     sprintf(pidstring, "%08X", pid);
8297     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8298     pidstr.dsc$a_pointer = pidstring;
8299     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8300     lib$set_symbol(&pidsymbol, &pidstr);
8301     return(SS$_NORMAL);
8302 }
8303 /*}}}*/
8304 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8305
8306
8307 /* OS-specific initialization at image activation (not thread startup) */
8308 /* Older VAXC header files lack these constants */
8309 #ifndef JPI$_RIGHTS_SIZE
8310 #  define JPI$_RIGHTS_SIZE 817
8311 #endif
8312 #ifndef KGB$M_SUBSYSTEM
8313 #  define KGB$M_SUBSYSTEM 0x8
8314 #endif
8315
8316 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8317
8318 /*{{{void vms_image_init(int *, char ***)*/
8319 void
8320 vms_image_init(int *argcp, char ***argvp)
8321 {
8322   char eqv[LNM$C_NAMLENGTH+1] = "";
8323   unsigned int len, tabct = 8, tabidx = 0;
8324   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8325   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8326   unsigned short int dummy, rlen;
8327   struct dsc$descriptor_s **tabvec;
8328 #if defined(PERL_IMPLICIT_CONTEXT)
8329   pTHX = NULL;
8330 #endif
8331   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8332                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8333                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8334                                  {          0,                0,    0,      0} };
8335
8336 #ifdef KILL_BY_SIGPRC
8337     Perl_csighandler_init();
8338 #endif
8339
8340   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8341   _ckvmssts_noperl(iosb[0]);
8342   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8343     if (iprv[i]) {           /* Running image installed with privs? */
8344       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8345       will_taint = TRUE;
8346       break;
8347     }
8348   }
8349   /* Rights identifiers might trigger tainting as well. */
8350   if (!will_taint && (rlen || rsz)) {
8351     while (rlen < rsz) {
8352       /* We didn't get all the identifiers on the first pass.  Allocate a
8353        * buffer much larger than $GETJPI wants (rsz is size in bytes that
8354        * were needed to hold all identifiers at time of last call; we'll
8355        * allocate that many unsigned long ints), and go back and get 'em.
8356        * If it gave us less than it wanted to despite ample buffer space,
8357        * something's broken.  Is your system missing a system identifier?
8358        */
8359       if (rsz <= jpilist[1].buflen) {
8360          /* Perl_croak accvios when used this early in startup. */
8361          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8362                          rsz, (unsigned long) jpilist[1].buflen,
8363                          "Check your rights database for corruption.\n");
8364          exit(SS$_ABORT);
8365       }
8366       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8367       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8368       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8369       jpilist[1].buflen = rsz * sizeof(unsigned long int);
8370       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8371       _ckvmssts_noperl(iosb[0]);
8372     }
8373     mask = jpilist[1].bufadr;
8374     /* Check attribute flags for each identifier (2nd longword); protected
8375      * subsystem identifiers trigger tainting.
8376      */
8377     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8378       if (mask[i] & KGB$M_SUBSYSTEM) {
8379         will_taint = TRUE;
8380         break;
8381       }
8382     }
8383     if (mask != rlst) PerlMem_free(mask);
8384   }
8385
8386   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8387    * logical, some versions of the CRTL will add a phanthom /000000/
8388    * directory.  This needs to be removed.
8389    */
8390   if (decc_filename_unix_report) {
8391   char * zeros;
8392   int ulen;
8393     ulen = strlen(argvp[0][0]);
8394     if (ulen > 7) {
8395       zeros = strstr(argvp[0][0], "/000000/");
8396       if (zeros != NULL) {
8397         int mlen;
8398         mlen = ulen - (zeros - argvp[0][0]) - 7;
8399         memmove(zeros, &zeros[7], mlen);
8400         ulen = ulen - 7;
8401         argvp[0][0][ulen] = '\0';
8402       }
8403     }
8404     /* It also may have a trailing dot that needs to be removed otherwise
8405      * it will be converted to VMS mode incorrectly.
8406      */
8407     ulen--;
8408     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8409       argvp[0][0][ulen] = '\0';
8410   }
8411
8412   /* We need to use this hack to tell Perl it should run with tainting,
8413    * since its tainting flag may be part of the PL_curinterp struct, which
8414    * hasn't been allocated when vms_image_init() is called.
8415    */
8416   if (will_taint) {
8417     char **newargv, **oldargv;
8418     oldargv = *argvp;
8419     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8420     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8421     newargv[0] = oldargv[0];
8422     newargv[1] = PerlMem_malloc(3 * sizeof(char));
8423     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8424     strcpy(newargv[1], "-T");
8425     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8426     (*argcp)++;
8427     newargv[*argcp] = NULL;
8428     /* We orphan the old argv, since we don't know where it's come from,
8429      * so we don't know how to free it.
8430      */
8431     *argvp = newargv;
8432   }
8433   else {  /* Did user explicitly request tainting? */
8434     int i;
8435     char *cp, **av = *argvp;
8436     for (i = 1; i < *argcp; i++) {
8437       if (*av[i] != '-') break;
8438       for (cp = av[i]+1; *cp; cp++) {
8439         if (*cp == 'T') { will_taint = 1; break; }
8440         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8441                   strchr("DFIiMmx",*cp)) break;
8442       }
8443       if (will_taint) break;
8444     }
8445   }
8446
8447   for (tabidx = 0;
8448        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8449        tabidx++) {
8450     if (!tabidx) {
8451       tabvec = (struct dsc$descriptor_s **)
8452             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8453       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8454     }
8455     else if (tabidx >= tabct) {
8456       tabct += 8;
8457       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8458       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8459     }
8460     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8461     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8462     tabvec[tabidx]->dsc$w_length  = 0;
8463     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
8464     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
8465     tabvec[tabidx]->dsc$a_pointer = NULL;
8466     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8467   }
8468   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8469
8470   getredirection(argcp,argvp);
8471 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8472   {
8473 # include <reentrancy.h>
8474   decc$set_reentrancy(C$C_MULTITHREAD);
8475   }
8476 #endif
8477   return;
8478 }
8479 /*}}}*/
8480
8481
8482 /* trim_unixpath()
8483  * Trim Unix-style prefix off filespec, so it looks like what a shell
8484  * glob expansion would return (i.e. from specified prefix on, not
8485  * full path).  Note that returned filespec is Unix-style, regardless
8486  * of whether input filespec was VMS-style or Unix-style.
8487  *
8488  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8489  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
8490  * vector of options; at present, only bit 0 is used, and if set tells
8491  * trim unixpath to try the current default directory as a prefix when
8492  * presented with a possibly ambiguous ... wildcard.
8493  *
8494  * Returns !=0 on success, with trimmed filespec replacing contents of
8495  * fspec, and 0 on failure, with contents of fpsec unchanged.
8496  */
8497 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8498 int
8499 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8500 {
8501   char *unixified, *unixwild,
8502        *template, *base, *end, *cp1, *cp2;
8503   register int tmplen, reslen = 0, dirs = 0;
8504
8505   unixwild = PerlMem_malloc(VMS_MAXRSS);
8506   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8507   if (!wildspec || !fspec) return 0;
8508   template = unixwild;
8509   if (strpbrk(wildspec,"]>:") != NULL) {
8510     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8511         PerlMem_free(unixwild);
8512         return 0;
8513     }
8514   }
8515   else {
8516     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8517     unixwild[VMS_MAXRSS-1] = 0;
8518   }
8519   unixified = PerlMem_malloc(VMS_MAXRSS);
8520   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8521   if (strpbrk(fspec,"]>:") != NULL) {
8522     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8523         PerlMem_free(unixwild);
8524         PerlMem_free(unixified);
8525         return 0;
8526     }
8527     else base = unixified;
8528     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8529      * check to see that final result fits into (isn't longer than) fspec */
8530     reslen = strlen(fspec);
8531   }
8532   else base = fspec;
8533
8534   /* No prefix or absolute path on wildcard, so nothing to remove */
8535   if (!*template || *template == '/') {
8536     PerlMem_free(unixwild);
8537     if (base == fspec) {
8538         PerlMem_free(unixified);
8539         return 1;
8540     }
8541     tmplen = strlen(unixified);
8542     if (tmplen > reslen) {
8543         PerlMem_free(unixified);
8544         return 0;  /* not enough space */
8545     }
8546     /* Copy unixified resultant, including trailing NUL */
8547     memmove(fspec,unixified,tmplen+1);
8548     PerlMem_free(unixified);
8549     return 1;
8550   }
8551
8552   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
8553   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8554     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8555     for (cp1 = end ;cp1 >= base; cp1--)
8556       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8557         { cp1++; break; }
8558     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8559     PerlMem_free(unixified);
8560     PerlMem_free(unixwild);
8561     return 1;
8562   }
8563   else {
8564     char *tpl, *lcres;
8565     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8566     int ells = 1, totells, segdirs, match;
8567     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8568                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8569
8570     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8571     totells = ells;
8572     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8573     tpl = PerlMem_malloc(VMS_MAXRSS);
8574     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8575     if (ellipsis == template && opts & 1) {
8576       /* Template begins with an ellipsis.  Since we can't tell how many
8577        * directory names at the front of the resultant to keep for an
8578        * arbitrary starting point, we arbitrarily choose the current
8579        * default directory as a starting point.  If it's there as a prefix,
8580        * clip it off.  If not, fall through and act as if the leading
8581        * ellipsis weren't there (i.e. return shortest possible path that
8582        * could match template).
8583        */
8584       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8585           PerlMem_free(tpl);
8586           PerlMem_free(unixified);
8587           PerlMem_free(unixwild);
8588           return 0;
8589       }
8590       if (!decc_efs_case_preserve) {
8591         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8592           if (_tolower(*cp1) != _tolower(*cp2)) break;
8593       }
8594       segdirs = dirs - totells;  /* Min # of dirs we must have left */
8595       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8596       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8597         memmove(fspec,cp2+1,end - cp2);
8598         PerlMem_free(tpl);
8599         PerlMem_free(unixified);
8600         PerlMem_free(unixwild);
8601         return 1;
8602       }
8603     }
8604     /* First off, back up over constant elements at end of path */
8605     if (dirs) {
8606       for (front = end ; front >= base; front--)
8607          if (*front == '/' && !dirs--) { front++; break; }
8608     }
8609     lcres = PerlMem_malloc(VMS_MAXRSS);
8610     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8611     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8612          cp1++,cp2++) {
8613             if (!decc_efs_case_preserve) {
8614                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
8615             }
8616             else {
8617                 *cp2 = *cp1;
8618             }
8619     }
8620     if (cp1 != '\0') {
8621         PerlMem_free(tpl);
8622         PerlMem_free(unixified);
8623         PerlMem_free(unixwild);
8624         PerlMem_free(lcres);
8625         return 0;  /* Path too long. */
8626     }
8627     lcend = cp2;
8628     *cp2 = '\0';  /* Pick up with memcpy later */
8629     lcfront = lcres + (front - base);
8630     /* Now skip over each ellipsis and try to match the path in front of it. */
8631     while (ells--) {
8632       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8633         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
8634             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
8635       if (cp1 < template) break; /* template started with an ellipsis */
8636       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8637         ellipsis = cp1; continue;
8638       }
8639       wilddsc.dsc$a_pointer = tpl;
8640       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8641       nextell = cp1;
8642       for (segdirs = 0, cp2 = tpl;
8643            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8644            cp1++, cp2++) {
8645          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8646          else {
8647             if (!decc_efs_case_preserve) {
8648               *cp2 = _tolower(*cp1);  /* else lowercase for match */
8649             }
8650             else {
8651               *cp2 = *cp1;  /* else preserve case for match */
8652             }
8653          }
8654          if (*cp2 == '/') segdirs++;
8655       }
8656       if (cp1 != ellipsis - 1) {
8657           PerlMem_free(tpl);
8658           PerlMem_free(unixified);
8659           PerlMem_free(unixwild);
8660           PerlMem_free(lcres);
8661           return 0; /* Path too long */
8662       }
8663       /* Back up at least as many dirs as in template before matching */
8664       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8665         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8666       for (match = 0; cp1 > lcres;) {
8667         resdsc.dsc$a_pointer = cp1;
8668         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8669           match++;
8670           if (match == 1) lcfront = cp1;
8671         }
8672         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8673       }
8674       if (!match) {
8675         PerlMem_free(tpl);
8676         PerlMem_free(unixified);
8677         PerlMem_free(unixwild);
8678         PerlMem_free(lcres);
8679         return 0;  /* Can't find prefix ??? */
8680       }
8681       if (match > 1 && opts & 1) {
8682         /* This ... wildcard could cover more than one set of dirs (i.e.
8683          * a set of similar dir names is repeated).  If the template
8684          * contains more than 1 ..., upstream elements could resolve the
8685          * ambiguity, but it's not worth a full backtracking setup here.
8686          * As a quick heuristic, clip off the current default directory
8687          * if it's present to find the trimmed spec, else use the
8688          * shortest string that this ... could cover.
8689          */
8690         char def[NAM$C_MAXRSS+1], *st;
8691
8692         if (getcwd(def, sizeof def,0) == NULL) {
8693             Safefree(unixified);
8694             Safefree(unixwild);
8695             Safefree(lcres);
8696             Safefree(tpl);
8697             return 0;
8698         }
8699         if (!decc_efs_case_preserve) {
8700           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8701             if (_tolower(*cp1) != _tolower(*cp2)) break;
8702         }
8703         segdirs = dirs - totells;  /* Min # of dirs we must have left */
8704         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8705         if (*cp1 == '\0' && *cp2 == '/') {
8706           memmove(fspec,cp2+1,end - cp2);
8707           PerlMem_free(tpl);
8708           PerlMem_free(unixified);
8709           PerlMem_free(unixwild);
8710           PerlMem_free(lcres);
8711           return 1;
8712         }
8713         /* Nope -- stick with lcfront from above and keep going. */
8714       }
8715     }
8716     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8717     PerlMem_free(tpl);
8718     PerlMem_free(unixified);
8719     PerlMem_free(unixwild);
8720     PerlMem_free(lcres);
8721     return 1;
8722     ellipsis = nextell;
8723   }
8724
8725 }  /* end of trim_unixpath() */
8726 /*}}}*/
8727
8728
8729 /*
8730  *  VMS readdir() routines.
8731  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8732  *
8733  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
8734  *  Minor modifications to original routines.
8735  */
8736
8737 /* readdir may have been redefined by reentr.h, so make sure we get
8738  * the local version for what we do here.
8739  */
8740 #ifdef readdir
8741 # undef readdir
8742 #endif
8743 #if !defined(PERL_IMPLICIT_CONTEXT)
8744 # define readdir Perl_readdir
8745 #else
8746 # define readdir(a) Perl_readdir(aTHX_ a)
8747 #endif
8748
8749     /* Number of elements in vms_versions array */
8750 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
8751
8752 /*
8753  *  Open a directory, return a handle for later use.
8754  */
8755 /*{{{ DIR *opendir(char*name) */
8756 DIR *
8757 Perl_opendir(pTHX_ const char *name)
8758 {
8759     DIR *dd;
8760     char *dir;
8761     Stat_t sb;
8762     int unix_flag = 0;
8763
8764     unix_flag = is_unix_filespec(name);
8765
8766     Newx(dir, VMS_MAXRSS, char);
8767     if (do_tovmspath(name,dir,0,NULL) == NULL) {
8768       Safefree(dir);
8769       return NULL;
8770     }
8771     /* Check access before stat; otherwise stat does not
8772      * accurately report whether it's a directory.
8773      */
8774     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8775       /* cando_by_name has already set errno */
8776       Safefree(dir);
8777       return NULL;
8778     }
8779     if (flex_stat(dir,&sb) == -1) return NULL;
8780     if (!S_ISDIR(sb.st_mode)) {
8781       Safefree(dir);
8782       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
8783       return NULL;
8784     }
8785     /* Get memory for the handle, and the pattern. */
8786     Newx(dd,1,DIR);
8787     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8788
8789     /* Fill in the fields; mainly playing with the descriptor. */
8790     sprintf(dd->pattern, "%s*.*",dir);
8791     Safefree(dir);
8792     dd->context = 0;
8793     dd->count = 0;
8794     dd->flags = 0;
8795     if (unix_flag)
8796         dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8797     dd->pat.dsc$a_pointer = dd->pattern;
8798     dd->pat.dsc$w_length = strlen(dd->pattern);
8799     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8800     dd->pat.dsc$b_class = DSC$K_CLASS_S;
8801 #if defined(USE_ITHREADS)
8802     Newx(dd->mutex,1,perl_mutex);
8803     MUTEX_INIT( (perl_mutex *) dd->mutex );
8804 #else
8805     dd->mutex = NULL;
8806 #endif
8807
8808     return dd;
8809 }  /* end of opendir() */
8810 /*}}}*/
8811
8812 /*
8813  *  Set the flag to indicate we want versions or not.
8814  */
8815 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8816 void
8817 vmsreaddirversions(DIR *dd, int flag)
8818 {
8819     if (flag)
8820         dd->flags |= PERL_VMSDIR_M_VERSIONS;
8821     else
8822         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8823 }
8824 /*}}}*/
8825
8826 /*
8827  *  Free up an opened directory.
8828  */
8829 /*{{{ void closedir(DIR *dd)*/
8830 void
8831 Perl_closedir(DIR *dd)
8832 {
8833     int sts;
8834
8835     sts = lib$find_file_end(&dd->context);
8836     Safefree(dd->pattern);
8837 #if defined(USE_ITHREADS)
8838     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8839     Safefree(dd->mutex);
8840 #endif
8841     Safefree(dd);
8842 }
8843 /*}}}*/
8844
8845 /*
8846  *  Collect all the version numbers for the current file.
8847  */
8848 static void
8849 collectversions(pTHX_ DIR *dd)
8850 {
8851     struct dsc$descriptor_s     pat;
8852     struct dsc$descriptor_s     res;
8853     struct dirent *e;
8854     char *p, *text, *buff;
8855     int i;
8856     unsigned long context, tmpsts;
8857
8858     /* Convenient shorthand. */
8859     e = &dd->entry;
8860
8861     /* Add the version wildcard, ignoring the "*.*" put on before */
8862     i = strlen(dd->pattern);
8863     Newx(text,i + e->d_namlen + 3,char);
8864     strcpy(text, dd->pattern);
8865     sprintf(&text[i - 3], "%s;*", e->d_name);
8866
8867     /* Set up the pattern descriptor. */
8868     pat.dsc$a_pointer = text;
8869     pat.dsc$w_length = i + e->d_namlen - 1;
8870     pat.dsc$b_dtype = DSC$K_DTYPE_T;
8871     pat.dsc$b_class = DSC$K_CLASS_S;
8872
8873     /* Set up result descriptor. */
8874     Newx(buff, VMS_MAXRSS, char);
8875     res.dsc$a_pointer = buff;
8876     res.dsc$w_length = VMS_MAXRSS - 1;
8877     res.dsc$b_dtype = DSC$K_DTYPE_T;
8878     res.dsc$b_class = DSC$K_CLASS_S;
8879
8880     /* Read files, collecting versions. */
8881     for (context = 0, e->vms_verscount = 0;
8882          e->vms_verscount < VERSIZE(e);
8883          e->vms_verscount++) {
8884         unsigned long rsts;
8885         unsigned long flags = 0;
8886
8887 #ifdef VMS_LONGNAME_SUPPORT
8888         flags = LIB$M_FIL_LONG_NAMES;
8889 #endif
8890         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8891         if (tmpsts == RMS$_NMF || context == 0) break;
8892         _ckvmssts(tmpsts);
8893         buff[VMS_MAXRSS - 1] = '\0';
8894         if ((p = strchr(buff, ';')))
8895             e->vms_versions[e->vms_verscount] = atoi(p + 1);
8896         else
8897             e->vms_versions[e->vms_verscount] = -1;
8898     }
8899
8900     _ckvmssts(lib$find_file_end(&context));
8901     Safefree(text);
8902     Safefree(buff);
8903
8904 }  /* end of collectversions() */
8905
8906 /*
8907  *  Read the next entry from the directory.
8908  */
8909 /*{{{ struct dirent *readdir(DIR *dd)*/
8910 struct dirent *
8911 Perl_readdir(pTHX_ DIR *dd)
8912 {
8913     struct dsc$descriptor_s     res;
8914     char *p, *buff;
8915     unsigned long int tmpsts;
8916     unsigned long rsts;
8917     unsigned long flags = 0;
8918     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8919     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8920
8921     /* Set up result descriptor, and get next file. */
8922     Newx(buff, VMS_MAXRSS, char);
8923     res.dsc$a_pointer = buff;
8924     res.dsc$w_length = VMS_MAXRSS - 1;
8925     res.dsc$b_dtype = DSC$K_DTYPE_T;
8926     res.dsc$b_class = DSC$K_CLASS_S;
8927
8928 #ifdef VMS_LONGNAME_SUPPORT
8929     flags = LIB$M_FIL_LONG_NAMES;
8930 #endif
8931
8932     tmpsts = lib$find_file
8933         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8934     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
8935     if (!(tmpsts & 1)) {
8936       set_vaxc_errno(tmpsts);
8937       switch (tmpsts) {
8938         case RMS$_PRV:
8939           set_errno(EACCES); break;
8940         case RMS$_DEV:
8941           set_errno(ENODEV); break;
8942         case RMS$_DIR:
8943           set_errno(ENOTDIR); break;
8944         case RMS$_FNF: case RMS$_DNF:
8945           set_errno(ENOENT); break;
8946         default:
8947           set_errno(EVMSERR);
8948       }
8949       Safefree(buff);
8950       return NULL;
8951     }
8952     dd->count++;
8953     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8954     if (!decc_efs_case_preserve) {
8955       buff[VMS_MAXRSS - 1] = '\0';
8956       for (p = buff; *p; p++) *p = _tolower(*p);
8957     }
8958     else {
8959       /* we don't want to force to lowercase, just null terminate */
8960       buff[res.dsc$w_length] = '\0';
8961     }
8962     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
8963     *p = '\0';
8964
8965     /* Skip any directory component and just copy the name. */
8966     sts = vms_split_path
8967        (buff,
8968         &v_spec,
8969         &v_len,
8970         &r_spec,
8971         &r_len,
8972         &d_spec,
8973         &d_len,
8974         &n_spec,
8975         &n_len,
8976         &e_spec,
8977         &e_len,
8978         &vs_spec,
8979         &vs_len);
8980
8981     /* Drop NULL extensions on UNIX file specification */
8982     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8983         (e_len == 1) && decc_readdir_dropdotnotype)) {
8984         e_len = 0;
8985         e_spec[0] = '\0';
8986     }
8987
8988     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8989     dd->entry.d_name[n_len + e_len] = '\0';
8990     dd->entry.d_namlen = strlen(dd->entry.d_name);
8991
8992     /* Convert the filename to UNIX format if needed */
8993     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8994
8995         /* Translate the encoded characters. */
8996         /* Fixme: unicode handling could result in embedded 0 characters */
8997         if (strchr(dd->entry.d_name, '^') != NULL) {
8998             char new_name[256];
8999             char * q;
9000             p = dd->entry.d_name;
9001             q = new_name;
9002             while (*p != 0) {
9003                 int inchars_read, outchars_added;
9004                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9005                 p += inchars_read;
9006                 q += outchars_added;
9007                 /* fix-me */
9008                 /* if outchars_added > 1, then this is a wide file specification */
9009                 /* Wide file specifications need to be passed in Perl */
9010                 /* counted strings apparently with a unicode flag */
9011             }
9012             *q = 0;
9013             strcpy(dd->entry.d_name, new_name);
9014             dd->entry.d_namlen = strlen(dd->entry.d_name);
9015         }
9016     }
9017
9018     dd->entry.vms_verscount = 0;
9019     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9020     Safefree(buff);
9021     return &dd->entry;
9022
9023 }  /* end of readdir() */
9024 /*}}}*/
9025
9026 /*
9027  *  Read the next entry from the directory -- thread-safe version.
9028  */
9029 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9030 int
9031 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9032 {
9033     int retval;
9034
9035     MUTEX_LOCK( (perl_mutex *) dd->mutex );
9036
9037     entry = readdir(dd);
9038     *result = entry;
9039     retval = ( *result == NULL ? errno : 0 );
9040
9041     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9042
9043     return retval;
9044
9045 }  /* end of readdir_r() */
9046 /*}}}*/
9047
9048 /*
9049  *  Return something that can be used in a seekdir later.
9050  */
9051 /*{{{ long telldir(DIR *dd)*/
9052 long
9053 Perl_telldir(DIR *dd)
9054 {
9055     return dd->count;
9056 }
9057 /*}}}*/
9058
9059 /*
9060  *  Return to a spot where we used to be.  Brute force.
9061  */
9062 /*{{{ void seekdir(DIR *dd,long count)*/
9063 void
9064 Perl_seekdir(pTHX_ DIR *dd, long count)
9065 {
9066     int old_flags;
9067
9068     /* If we haven't done anything yet... */
9069     if (dd->count == 0)
9070         return;
9071
9072     /* Remember some state, and clear it. */
9073     old_flags = dd->flags;
9074     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9075     _ckvmssts(lib$find_file_end(&dd->context));
9076     dd->context = 0;
9077
9078     /* The increment is in readdir(). */
9079     for (dd->count = 0; dd->count < count; )
9080         readdir(dd);
9081
9082     dd->flags = old_flags;
9083
9084 }  /* end of seekdir() */
9085 /*}}}*/
9086
9087 /* VMS subprocess management
9088  *
9089  * my_vfork() - just a vfork(), after setting a flag to record that
9090  * the current script is trying a Unix-style fork/exec.
9091  *
9092  * vms_do_aexec() and vms_do_exec() are called in response to the
9093  * perl 'exec' function.  If this follows a vfork call, then they
9094  * call out the regular perl routines in doio.c which do an
9095  * execvp (for those who really want to try this under VMS).
9096  * Otherwise, they do exactly what the perl docs say exec should
9097  * do - terminate the current script and invoke a new command
9098  * (See below for notes on command syntax.)
9099  *
9100  * do_aspawn() and do_spawn() implement the VMS side of the perl
9101  * 'system' function.
9102  *
9103  * Note on command arguments to perl 'exec' and 'system': When handled
9104  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9105  * are concatenated to form a DCL command string.  If the first arg
9106  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
9107  * the command string is handed off to DCL directly.  Otherwise,
9108  * the first token of the command is taken as the filespec of an image
9109  * to run.  The filespec is expanded using a default type of '.EXE' and
9110  * the process defaults for device, directory, etc., and if found, the resultant
9111  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9112  * the command string as parameters.  This is perhaps a bit complicated,
9113  * but I hope it will form a happy medium between what VMS folks expect
9114  * from lib$spawn and what Unix folks expect from exec.
9115  */
9116
9117 static int vfork_called;
9118
9119 /*{{{int my_vfork()*/
9120 int
9121 my_vfork()
9122 {
9123   vfork_called++;
9124   return vfork();
9125 }
9126 /*}}}*/
9127
9128
9129 static void
9130 vms_execfree(struct dsc$descriptor_s *vmscmd)
9131 {
9132   if (vmscmd) {
9133       if (vmscmd->dsc$a_pointer) {
9134           PerlMem_free(vmscmd->dsc$a_pointer);
9135       }
9136       PerlMem_free(vmscmd);
9137   }
9138 }
9139
9140 static char *
9141 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9142 {
9143   char *junk, *tmps = Nullch;
9144   register size_t cmdlen = 0;
9145   size_t rlen;
9146   register SV **idx;
9147   STRLEN n_a;
9148
9149   idx = mark;
9150   if (really) {
9151     tmps = SvPV(really,rlen);
9152     if (*tmps) {
9153       cmdlen += rlen + 1;
9154       idx++;
9155     }
9156   }
9157
9158   for (idx++; idx <= sp; idx++) {
9159     if (*idx) {
9160       junk = SvPVx(*idx,rlen);
9161       cmdlen += rlen ? rlen + 1 : 0;
9162     }
9163   }
9164   Newx(PL_Cmd, cmdlen+1, char);
9165
9166   if (tmps && *tmps) {
9167     strcpy(PL_Cmd,tmps);
9168     mark++;
9169   }
9170   else *PL_Cmd = '\0';
9171   while (++mark <= sp) {
9172     if (*mark) {
9173       char *s = SvPVx(*mark,n_a);
9174       if (!*s) continue;
9175       if (*PL_Cmd) strcat(PL_Cmd," ");
9176       strcat(PL_Cmd,s);
9177     }
9178   }
9179   return PL_Cmd;
9180
9181 }  /* end of setup_argstr() */
9182
9183
9184 static unsigned long int
9185 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9186                    struct dsc$descriptor_s **pvmscmd)
9187 {
9188   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9189   char image_name[NAM$C_MAXRSS+1];
9190   char image_argv[NAM$C_MAXRSS+1];
9191   $DESCRIPTOR(defdsc,".EXE");
9192   $DESCRIPTOR(defdsc2,".");
9193   $DESCRIPTOR(resdsc,resspec);
9194   struct dsc$descriptor_s *vmscmd;
9195   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9196   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9197   register char *s, *rest, *cp, *wordbreak;
9198   char * cmd;
9199   int cmdlen;
9200   register int isdcl;
9201
9202   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9203   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9204
9205   /* Make a copy for modification */
9206   cmdlen = strlen(incmd);
9207   cmd = PerlMem_malloc(cmdlen+1);
9208   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9209   strncpy(cmd, incmd, cmdlen);
9210   cmd[cmdlen] = 0;
9211   image_name[0] = 0;
9212   image_argv[0] = 0;
9213
9214   vmscmd->dsc$a_pointer = NULL;
9215   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
9216   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
9217   vmscmd->dsc$w_length = 0;
9218   if (pvmscmd) *pvmscmd = vmscmd;
9219
9220   if (suggest_quote) *suggest_quote = 0;
9221
9222   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9223     PerlMem_free(cmd);
9224     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
9225   }
9226
9227   s = cmd;
9228
9229   while (*s && isspace(*s)) s++;
9230
9231   if (*s == '@' || *s == '$') {
9232     vmsspec[0] = *s;  rest = s + 1;
9233     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9234   }
9235   else { cp = vmsspec; rest = s; }
9236   if (*rest == '.' || *rest == '/') {
9237     char *cp2;
9238     for (cp2 = resspec;
9239          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9240          rest++, cp2++) *cp2 = *rest;
9241     *cp2 = '\0';
9242     if (do_tovmsspec(resspec,cp,0,NULL)) {
9243       s = vmsspec;
9244       if (*rest) {
9245         for (cp2 = vmsspec + strlen(vmsspec);
9246              *rest && cp2 - vmsspec < sizeof vmsspec;
9247              rest++, cp2++) *cp2 = *rest;
9248         *cp2 = '\0';
9249       }
9250     }
9251   }
9252   /* Intuit whether verb (first word of cmd) is a DCL command:
9253    *   - if first nonspace char is '@', it's a DCL indirection
9254    * otherwise
9255    *   - if verb contains a filespec separator, it's not a DCL command
9256    *   - if it doesn't, caller tells us whether to default to a DCL
9257    *     command, or to a local image unless told it's DCL (by leading '$')
9258    */
9259   if (*s == '@') {
9260       isdcl = 1;
9261       if (suggest_quote) *suggest_quote = 1;
9262   } else {
9263     register char *filespec = strpbrk(s,":<[.;");
9264     rest = wordbreak = strpbrk(s," \"\t/");
9265     if (!wordbreak) wordbreak = s + strlen(s);
9266     if (*s == '$') check_img = 0;
9267     if (filespec && (filespec < wordbreak)) isdcl = 0;
9268     else isdcl = !check_img;
9269   }
9270
9271   if (!isdcl) {
9272     int rsts;
9273     imgdsc.dsc$a_pointer = s;
9274     imgdsc.dsc$w_length = wordbreak - s;
9275     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9276     if (!(retsts&1)) {
9277         _ckvmssts(lib$find_file_end(&cxt));
9278         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9279       if (!(retsts & 1) && *s == '$') {
9280         _ckvmssts(lib$find_file_end(&cxt));
9281         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9282         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9283         if (!(retsts&1)) {
9284           _ckvmssts(lib$find_file_end(&cxt));
9285           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9286         }
9287       }
9288     }
9289     _ckvmssts(lib$find_file_end(&cxt));
9290
9291     if (retsts & 1) {
9292       FILE *fp;
9293       s = resspec;
9294       while (*s && !isspace(*s)) s++;
9295       *s = '\0';
9296
9297       /* check that it's really not DCL with no file extension */
9298       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9299       if (fp) {
9300         char b[256] = {0,0,0,0};
9301         read(fileno(fp), b, 256);
9302         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9303         if (isdcl) {
9304           int shebang_len;
9305
9306           /* Check for script */
9307           shebang_len = 0;
9308           if ((b[0] == '#') && (b[1] == '!'))
9309              shebang_len = 2;
9310 #ifdef ALTERNATE_SHEBANG
9311           else {
9312             shebang_len = strlen(ALTERNATE_SHEBANG);
9313             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9314               char * perlstr;
9315                 perlstr = strstr("perl",b);
9316                 if (perlstr == NULL)
9317                   shebang_len = 0;
9318             }
9319             else
9320               shebang_len = 0;
9321           }
9322 #endif
9323
9324           if (shebang_len > 0) {
9325           int i;
9326           int j;
9327           char tmpspec[NAM$C_MAXRSS + 1];
9328
9329             i = shebang_len;
9330              /* Image is following after white space */
9331             /*--------------------------------------*/
9332             while (isprint(b[i]) && isspace(b[i]))
9333                 i++;
9334
9335             j = 0;
9336             while (isprint(b[i]) && !isspace(b[i])) {
9337                 tmpspec[j++] = b[i++];
9338                 if (j >= NAM$C_MAXRSS)
9339                    break;
9340             }
9341             tmpspec[j] = '\0';
9342
9343              /* There may be some default parameters to the image */
9344             /*---------------------------------------------------*/
9345             j = 0;
9346             while (isprint(b[i])) {
9347                 image_argv[j++] = b[i++];
9348                 if (j >= NAM$C_MAXRSS)
9349                    break;
9350             }
9351             while ((j > 0) && !isprint(image_argv[j-1]))
9352                 j--;
9353             image_argv[j] = 0;
9354
9355             /* It will need to be converted to VMS format and validated */
9356             if (tmpspec[0] != '\0') {
9357               char * iname;
9358
9359                /* Try to find the exact program requested to be run */
9360               /*---------------------------------------------------*/
9361               iname = do_rmsexpand
9362                  (tmpspec, image_name, 0, ".exe",
9363                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
9364               if (iname != NULL) {
9365                 if (cando_by_name_int
9366                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9367                   /* MCR prefix needed */
9368                   isdcl = 0;
9369                 }
9370                 else {
9371                    /* Try again with a null type */
9372                   /*----------------------------*/
9373                   iname = do_rmsexpand
9374                     (tmpspec, image_name, 0, ".",
9375                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
9376                   if (iname != NULL) {
9377                     if (cando_by_name_int
9378                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9379                       /* MCR prefix needed */
9380                       isdcl = 0;
9381                     }
9382                   }
9383                 }
9384
9385                  /* Did we find the image to run the script? */
9386                 /*------------------------------------------*/
9387                 if (isdcl) {
9388                   char *tchr;
9389
9390                    /* Assume DCL or foreign command exists */
9391                   /*--------------------------------------*/
9392                   tchr = strrchr(tmpspec, '/');
9393                   if (tchr != NULL) {
9394                     tchr++;
9395                   }
9396                   else {
9397                     tchr = tmpspec;
9398                   }
9399                   strcpy(image_name, tchr);
9400                 }
9401               }
9402             }
9403           }
9404         }
9405         fclose(fp);
9406       }
9407       if (check_img && isdcl) return RMS$_FNF;
9408
9409       if (cando_by_name(S_IXUSR,0,resspec)) {
9410         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9411         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9412         if (!isdcl) {
9413             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9414             if (image_name[0] != 0) {
9415                 strcat(vmscmd->dsc$a_pointer, image_name);
9416                 strcat(vmscmd->dsc$a_pointer, " ");
9417             }
9418         } else if (image_name[0] != 0) {
9419             strcpy(vmscmd->dsc$a_pointer, image_name);
9420             strcat(vmscmd->dsc$a_pointer, " ");
9421         } else {
9422             strcpy(vmscmd->dsc$a_pointer,"@");
9423         }
9424         if (suggest_quote) *suggest_quote = 1;
9425
9426         /* If there is an image name, use original command */
9427         if (image_name[0] == 0)
9428             strcat(vmscmd->dsc$a_pointer,resspec);
9429         else {
9430             rest = cmd;
9431             while (*rest && isspace(*rest)) rest++;
9432         }
9433
9434         if (image_argv[0] != 0) {
9435           strcat(vmscmd->dsc$a_pointer,image_argv);
9436           strcat(vmscmd->dsc$a_pointer, " ");
9437         }
9438         if (rest) {
9439            int rest_len;
9440            int vmscmd_len;
9441
9442            rest_len = strlen(rest);
9443            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9444            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9445               strcat(vmscmd->dsc$a_pointer,rest);
9446            else
9447              retsts = CLI$_BUFOVF;
9448         }
9449         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9450         PerlMem_free(cmd);
9451         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9452       }
9453       else
9454         retsts = RMS$_PRV;
9455     }
9456   }
9457   /* It's either a DCL command or we couldn't find a suitable image */
9458   vmscmd->dsc$w_length = strlen(cmd);
9459
9460   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9461   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9462   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9463
9464   PerlMem_free(cmd);
9465
9466   /* check if it's a symbol (for quoting purposes) */
9467   if (suggest_quote && !*suggest_quote) {
9468     int iss;
9469     char equiv[LNM$C_NAMLENGTH];
9470     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9471     eqvdsc.dsc$a_pointer = equiv;
9472
9473     iss = lib$get_symbol(vmscmd,&eqvdsc);
9474     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9475   }
9476   if (!(retsts & 1)) {
9477     /* just hand off status values likely to be due to user error */
9478     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9479         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9480        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9481     else { _ckvmssts(retsts); }
9482   }
9483
9484   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9485
9486 }  /* end of setup_cmddsc() */
9487
9488
9489 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9490 bool
9491 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9492 {
9493 bool exec_sts;
9494 char * cmd;
9495
9496   if (sp > mark) {
9497     if (vfork_called) {           /* this follows a vfork - act Unixish */
9498       vfork_called--;
9499       if (vfork_called < 0) {
9500         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9501         vfork_called = 0;
9502       }
9503       else return do_aexec(really,mark,sp);
9504     }
9505                                            /* no vfork - act VMSish */
9506     cmd = setup_argstr(aTHX_ really,mark,sp);
9507     exec_sts = vms_do_exec(cmd);
9508     Safefree(cmd);  /* Clean up from setup_argstr() */
9509     return exec_sts;
9510   }
9511
9512   return FALSE;
9513 }  /* end of vms_do_aexec() */
9514 /*}}}*/
9515
9516 /* {{{bool vms_do_exec(char *cmd) */
9517 bool
9518 Perl_vms_do_exec(pTHX_ const char *cmd)
9519 {
9520   struct dsc$descriptor_s *vmscmd;
9521
9522   if (vfork_called) {             /* this follows a vfork - act Unixish */
9523     vfork_called--;
9524     if (vfork_called < 0) {
9525       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9526       vfork_called = 0;
9527     }
9528     else return do_exec(cmd);
9529   }
9530
9531   {                               /* no vfork - act VMSish */
9532     unsigned long int retsts;
9533
9534     TAINT_ENV();
9535     TAINT_PROPER("exec");
9536     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9537       retsts = lib$do_command(vmscmd);
9538
9539     switch (retsts) {
9540       case RMS$_FNF: case RMS$_DNF:
9541         set_errno(ENOENT); break;
9542       case RMS$_DIR:
9543         set_errno(ENOTDIR); break;
9544       case RMS$_DEV:
9545         set_errno(ENODEV); break;
9546       case RMS$_PRV:
9547         set_errno(EACCES); break;
9548       case RMS$_SYN:
9549         set_errno(EINVAL); break;
9550       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9551         set_errno(E2BIG); break;
9552       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9553         _ckvmssts(retsts); /* fall through */
9554       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9555         set_errno(EVMSERR);
9556     }
9557     set_vaxc_errno(retsts);
9558     if (ckWARN(WARN_EXEC)) {
9559       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9560              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9561     }
9562     vms_execfree(vmscmd);
9563   }
9564
9565   return FALSE;
9566
9567 }  /* end of vms_do_exec() */
9568 /*}}}*/
9569
9570 unsigned long int Perl_do_spawn(pTHX_ const char *);
9571
9572 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9573 unsigned long int
9574 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9575 {
9576 unsigned long int sts;
9577 char * cmd;
9578
9579   if (sp > mark) {
9580     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9581     sts = do_spawn(cmd);
9582     /* pp_sys will clean up cmd */
9583     return sts;
9584   }
9585   return SS$_ABORT;
9586 }  /* end of do_aspawn() */
9587 /*}}}*/
9588
9589 /* {{{unsigned long int do_spawn(char *cmd) */
9590 unsigned long int
9591 Perl_do_spawn(pTHX_ const char *cmd)
9592 {
9593   unsigned long int sts, substs;
9594
9595   /* The caller of this routine expects to Safefree(PL_Cmd) */
9596   Newx(PL_Cmd,10,char);
9597
9598   TAINT_ENV();
9599   TAINT_PROPER("spawn");
9600   if (!cmd || !*cmd) {
9601     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9602     if (!(sts & 1)) {
9603       switch (sts) {
9604         case RMS$_FNF:  case RMS$_DNF:
9605           set_errno(ENOENT); break;
9606         case RMS$_DIR:
9607           set_errno(ENOTDIR); break;
9608         case RMS$_DEV:
9609           set_errno(ENODEV); break;
9610         case RMS$_PRV:
9611           set_errno(EACCES); break;
9612         case RMS$_SYN:
9613           set_errno(EINVAL); break;
9614         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9615           set_errno(E2BIG); break;
9616         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9617           _ckvmssts(sts); /* fall through */
9618         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9619           set_errno(EVMSERR);
9620       }
9621       set_vaxc_errno(sts);
9622       if (ckWARN(WARN_EXEC)) {
9623         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9624                     Strerror(errno));
9625       }
9626     }
9627     sts = substs;
9628   }
9629   else {
9630     PerlIO * fp;
9631     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9632     if (fp != NULL)
9633       my_pclose(fp);
9634   }
9635   return sts;
9636 }  /* end of do_spawn() */
9637 /*}}}*/
9638
9639
9640 static unsigned int *sockflags, sockflagsize;
9641
9642 /*
9643  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9644  * routines found in some versions of the CRTL can't deal with sockets.
9645  * We don't shim the other file open routines since a socket isn't
9646  * likely to be opened by a name.
9647  */
9648 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9649 FILE *my_fdopen(int fd, const char *mode)
9650 {
9651   FILE *fp = fdopen(fd, mode);
9652
9653   if (fp) {
9654     unsigned int fdoff = fd / sizeof(unsigned int);
9655     Stat_t sbuf; /* native stat; we don't need flex_stat */
9656     if (!sockflagsize || fdoff > sockflagsize) {
9657       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
9658       else           Newx  (sockflags,fdoff+2,unsigned int);
9659       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9660       sockflagsize = fdoff + 2;
9661     }
9662     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9663       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9664   }
9665   return fp;
9666
9667 }
9668 /*}}}*/
9669
9670
9671 /*
9672  * Clear the corresponding bit when the (possibly) socket stream is closed.
9673  * There still a small hole: we miss an implicit close which might occur
9674  * via freopen().  >> Todo
9675  */
9676 /*{{{ int my_fclose(FILE *fp)*/
9677 int my_fclose(FILE *fp) {
9678   if (fp) {
9679     unsigned int fd = fileno(fp);
9680     unsigned int fdoff = fd / sizeof(unsigned int);
9681
9682     if (sockflagsize && fdoff <= sockflagsize)
9683       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9684   }
9685   return fclose(fp);
9686 }
9687 /*}}}*/
9688
9689
9690 /*
9691  * A simple fwrite replacement which outputs itmsz*nitm chars without
9692  * introducing record boundaries every itmsz chars.
9693  * We are using fputs, which depends on a terminating null.  We may
9694  * well be writing binary data, so we need to accommodate not only
9695  * data with nulls sprinkled in the middle but also data with no null
9696  * byte at the end.
9697  */
9698 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9699 int
9700 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9701 {
9702   register char *cp, *end, *cpd, *data;
9703   register unsigned int fd = fileno(dest);
9704   register unsigned int fdoff = fd / sizeof(unsigned int);
9705   int retval;
9706   int bufsize = itmsz * nitm + 1;
9707
9708   if (fdoff < sockflagsize &&
9709       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9710     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9711     return nitm;
9712   }
9713
9714   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9715   memcpy( data, src, itmsz*nitm );
9716   data[itmsz*nitm] = '\0';
9717
9718   end = data + itmsz * nitm;
9719   retval = (int) nitm; /* on success return # items written */
9720
9721   cpd = data;
9722   while (cpd <= end) {
9723     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9724     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9725     if (cp < end)
9726       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9727     cpd = cp + 1;
9728   }
9729
9730   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9731   return retval;
9732
9733 }  /* end of my_fwrite() */
9734 /*}}}*/
9735
9736 /*{{{ int my_flush(FILE *fp)*/
9737 int
9738 Perl_my_flush(pTHX_ FILE *fp)
9739 {
9740     int res;
9741     if ((res = fflush(fp)) == 0 && fp) {
9742 #ifdef VMS_DO_SOCKETS
9743         Stat_t s;
9744         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9745 #endif
9746             res = fsync(fileno(fp));
9747     }
9748 /*
9749  * If the flush succeeded but set end-of-file, we need to clear
9750  * the error because our caller may check ferror().  BTW, this
9751  * probably means we just flushed an empty file.
9752  */
9753     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9754
9755     return res;
9756 }
9757 /*}}}*/
9758
9759 /*
9760  * Here are replacements for the following Unix routines in the VMS environment:
9761  *      getpwuid    Get information for a particular UIC or UID
9762  *      getpwnam    Get information for a named user
9763  *      getpwent    Get information for each user in the rights database
9764  *      setpwent    Reset search to the start of the rights database
9765  *      endpwent    Finish searching for users in the rights database
9766  *
9767  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9768  * (defined in pwd.h), which contains the following fields:-
9769  *      struct passwd {
9770  *              char        *pw_name;    Username (in lower case)
9771  *              char        *pw_passwd;  Hashed password
9772  *              unsigned int pw_uid;     UIC
9773  *              unsigned int pw_gid;     UIC group  number
9774  *              char        *pw_unixdir; Default device/directory (VMS-style)
9775  *              char        *pw_gecos;   Owner name
9776  *              char        *pw_dir;     Default device/directory (Unix-style)
9777  *              char        *pw_shell;   Default CLI name (eg. DCL)
9778  *      };
9779  * If the specified user does not exist, getpwuid and getpwnam return NULL.
9780  *
9781  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9782  * not the UIC member number (eg. what's returned by getuid()),
9783  * getpwuid() can accept either as input (if uid is specified, the caller's
9784  * UIC group is used), though it won't recognise gid=0.
9785  *
9786  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9787  * information about other users in your group or in other groups, respectively.
9788  * If the required privilege is not available, then these routines fill only
9789  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9790  * string).
9791  *
9792  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9793  */
9794
9795 /* sizes of various UAF record fields */
9796 #define UAI$S_USERNAME 12
9797 #define UAI$S_IDENT    31
9798 #define UAI$S_OWNER    31
9799 #define UAI$S_DEFDEV   31
9800 #define UAI$S_DEFDIR   63
9801 #define UAI$S_DEFCLI   31
9802 #define UAI$S_PWD       8
9803
9804 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
9805                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9806                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
9807
9808 static char __empty[]= "";
9809 static struct passwd __passwd_empty=
9810     {(char *) __empty, (char *) __empty, 0, 0,
9811      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9812 static int contxt= 0;
9813 static struct passwd __pwdcache;
9814 static char __pw_namecache[UAI$S_IDENT+1];
9815
9816 /*
9817  * This routine does most of the work extracting the user information.
9818  */
9819 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9820 {
9821     static struct {
9822         unsigned char length;
9823         char pw_gecos[UAI$S_OWNER+1];
9824     } owner;
9825     static union uicdef uic;
9826     static struct {
9827         unsigned char length;
9828         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9829     } defdev;
9830     static struct {
9831         unsigned char length;
9832         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9833     } defdir;
9834     static struct {
9835         unsigned char length;
9836         char pw_shell[UAI$S_DEFCLI+1];
9837     } defcli;
9838     static char pw_passwd[UAI$S_PWD+1];
9839
9840     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9841     struct dsc$descriptor_s name_desc;
9842     unsigned long int sts;
9843
9844     static struct itmlst_3 itmlst[]= {
9845         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
9846         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
9847         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
9848         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
9849         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
9850         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
9851         {0,                0,           NULL,    NULL}};
9852
9853     name_desc.dsc$w_length=  strlen(name);
9854     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9855     name_desc.dsc$b_class=   DSC$K_CLASS_S;
9856     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9857
9858 /*  Note that sys$getuai returns many fields as counted strings. */
9859     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9860     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9861       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9862     }
9863     else { _ckvmssts(sts); }
9864     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
9865
9866     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
9867     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9868     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9869     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9870     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9871     owner.pw_gecos[lowner]=            '\0';
9872     defdev.pw_dir[ldefdev+ldefdir]= '\0';
9873     defcli.pw_shell[ldefcli]=          '\0';
9874     if (valid_uic(uic)) {
9875         pwd->pw_uid= uic.uic$l_uic;
9876         pwd->pw_gid= uic.uic$v_group;
9877     }
9878     else
9879       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9880     pwd->pw_passwd=  pw_passwd;
9881     pwd->pw_gecos=   owner.pw_gecos;
9882     pwd->pw_dir=     defdev.pw_dir;
9883     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9884     pwd->pw_shell=   defcli.pw_shell;
9885     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9886         int ldir;
9887         ldir= strlen(pwd->pw_unixdir) - 1;
9888         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9889     }
9890     else
9891         strcpy(pwd->pw_unixdir, pwd->pw_dir);
9892     if (!decc_efs_case_preserve)
9893         __mystrtolower(pwd->pw_unixdir);
9894     return 1;
9895 }
9896
9897 /*
9898  * Get information for a named user.
9899 */
9900 /*{{{struct passwd *getpwnam(char *name)*/
9901 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9902 {
9903     struct dsc$descriptor_s name_desc;
9904     union uicdef uic;
9905     unsigned long int status, sts;
9906
9907     __pwdcache = __passwd_empty;
9908     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9909       /* We still may be able to determine pw_uid and pw_gid */
9910       name_desc.dsc$w_length=  strlen(name);
9911       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9912       name_desc.dsc$b_class=   DSC$K_CLASS_S;
9913       name_desc.dsc$a_pointer= (char *) name;
9914       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9915         __pwdcache.pw_uid= uic.uic$l_uic;
9916         __pwdcache.pw_gid= uic.uic$v_group;
9917       }
9918       else {
9919         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9920           set_vaxc_errno(sts);
9921           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9922           return NULL;
9923         }
9924         else { _ckvmssts(sts); }
9925       }
9926     }
9927     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9928     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9929     __pwdcache.pw_name= __pw_namecache;
9930     return &__pwdcache;
9931 }  /* end of my_getpwnam() */
9932 /*}}}*/
9933
9934 /*
9935  * Get information for a particular UIC or UID.
9936  * Called by my_getpwent with uid=-1 to list all users.
9937 */
9938 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9939 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9940 {
9941     const $DESCRIPTOR(name_desc,__pw_namecache);
9942     unsigned short lname;
9943     union uicdef uic;
9944     unsigned long int status;
9945
9946     if (uid == (unsigned int) -1) {
9947       do {
9948         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9949         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9950           set_vaxc_errno(status);
9951           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9952           my_endpwent();
9953           return NULL;
9954         }
9955         else { _ckvmssts(status); }
9956       } while (!valid_uic (uic));
9957     }
9958     else {
9959       uic.uic$l_uic= uid;
9960       if (!uic.uic$v_group)
9961         uic.uic$v_group= PerlProc_getgid();
9962       if (valid_uic(uic))
9963         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9964       else status = SS$_IVIDENT;
9965       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9966           status == RMS$_PRV) {
9967         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9968         return NULL;
9969       }
9970       else { _ckvmssts(status); }
9971     }
9972     __pw_namecache[lname]= '\0';
9973     __mystrtolower(__pw_namecache);
9974
9975     __pwdcache = __passwd_empty;
9976     __pwdcache.pw_name = __pw_namecache;
9977
9978 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9979     The identifier's value is usually the UIC, but it doesn't have to be,
9980     so if we can, we let fillpasswd update this. */
9981     __pwdcache.pw_uid =  uic.uic$l_uic;
9982     __pwdcache.pw_gid =  uic.uic$v_group;
9983
9984     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9985     return &__pwdcache;
9986
9987 }  /* end of my_getpwuid() */
9988 /*}}}*/
9989
9990 /*
9991  * Get information for next user.
9992 */
9993 /*{{{struct passwd *my_getpwent()*/
9994 struct passwd *Perl_my_getpwent(pTHX)
9995 {
9996     return (my_getpwuid((unsigned int) -1));
9997 }
9998 /*}}}*/
9999
10000 /*
10001  * Finish searching rights database for users.
10002 */
10003 /*{{{void my_endpwent()*/
10004 void Perl_my_endpwent(pTHX)
10005 {
10006     if (contxt) {
10007       _ckvmssts(sys$finish_rdb(&contxt));
10008       contxt= 0;
10009     }
10010 }
10011 /*}}}*/
10012
10013 #ifdef HOMEGROWN_POSIX_SIGNALS
10014   /* Signal handling routines, pulled into the core from POSIX.xs.
10015    *
10016    * We need these for threads, so they've been rolled into the core,
10017    * rather than left in POSIX.xs.
10018    *
10019    * (DRS, Oct 23, 1997)
10020    */
10021
10022   /* sigset_t is atomic under VMS, so these routines are easy */
10023 /*{{{int my_sigemptyset(sigset_t *) */
10024 int my_sigemptyset(sigset_t *set) {
10025     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10026     *set = 0; return 0;
10027 }
10028 /*}}}*/
10029
10030
10031 /*{{{int my_sigfillset(sigset_t *)*/
10032 int my_sigfillset(sigset_t *set) {
10033     int i;
10034     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10035     for (i = 0; i < NSIG; i++) *set |= (1 << i);
10036     return 0;
10037 }
10038 /*}}}*/
10039
10040
10041 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10042 int my_sigaddset(sigset_t *set, int sig) {
10043     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10044     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10045     *set |= (1 << (sig - 1));
10046     return 0;
10047 }
10048 /*}}}*/
10049
10050
10051 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10052 int my_sigdelset(sigset_t *set, int sig) {
10053     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10054     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10055     *set &= ~(1 << (sig - 1));
10056     return 0;
10057 }
10058 /*}}}*/
10059
10060
10061 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10062 int my_sigismember(sigset_t *set, int sig) {
10063     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10064     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10065     return *set & (1 << (sig - 1));
10066 }
10067 /*}}}*/
10068
10069
10070 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10071 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10072     sigset_t tempmask;
10073
10074     /* If set and oset are both null, then things are badly wrong. Bail out. */
10075     if ((oset == NULL) && (set == NULL)) {
10076       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10077       return -1;
10078     }
10079
10080     /* If set's null, then we're just handling a fetch. */
10081     if (set == NULL) {
10082         tempmask = sigblock(0);
10083     }
10084     else {
10085       switch (how) {
10086       case SIG_SETMASK:
10087         tempmask = sigsetmask(*set);
10088         break;
10089       case SIG_BLOCK:
10090         tempmask = sigblock(*set);
10091         break;
10092       case SIG_UNBLOCK:
10093         tempmask = sigblock(0);
10094         sigsetmask(*oset & ~tempmask);
10095         break;
10096       default:
10097         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10098         return -1;
10099       }
10100     }
10101
10102     /* Did they pass us an oset? If so, stick our holding mask into it */
10103     if (oset)
10104       *oset = tempmask;
10105
10106     return 0;
10107 }
10108 /*}}}*/
10109 #endif  /* HOMEGROWN_POSIX_SIGNALS */
10110
10111
10112 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10113  * my_utime(), and flex_stat(), all of which operate on UTC unless
10114  * VMSISH_TIMES is true.
10115  */
10116 /* method used to handle UTC conversions:
10117  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
10118  */
10119 static int gmtime_emulation_type;
10120 /* number of secs to add to UTC POSIX-style time to get local time */
10121 static long int utc_offset_secs;
10122
10123 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10124  * in vmsish.h.  #undef them here so we can call the CRTL routines
10125  * directly.
10126  */
10127 #undef gmtime
10128 #undef localtime
10129 #undef time
10130
10131
10132 /*
10133  * DEC C previous to 6.0 corrupts the behavior of the /prefix
10134  * qualifier with the extern prefix pragma.  This provisional
10135  * hack circumvents this prefix pragma problem in previous
10136  * precompilers.
10137  */
10138 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10139 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10140 #    pragma __extern_prefix save
10141 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
10142 #    define gmtime decc$__utctz_gmtime
10143 #    define localtime decc$__utctz_localtime
10144 #    define time decc$__utc_time
10145 #    pragma __extern_prefix restore
10146
10147      struct tm *gmtime(), *localtime();
10148
10149 #  endif
10150 #endif
10151
10152
10153 static time_t toutc_dst(time_t loc) {
10154   struct tm *rsltmp;
10155
10156   if ((rsltmp = localtime(&loc)) == NULL) return -1;
10157   loc -= utc_offset_secs;
10158   if (rsltmp->tm_isdst) loc -= 3600;
10159   return loc;
10160 }
10161 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10162        ((gmtime_emulation_type || my_time(NULL)), \
10163        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10164        ((secs) - utc_offset_secs))))
10165
10166 static time_t toloc_dst(time_t utc) {
10167   struct tm *rsltmp;
10168
10169   utc += utc_offset_secs;
10170   if ((rsltmp = localtime(&utc)) == NULL) return -1;
10171   if (rsltmp->tm_isdst) utc += 3600;
10172   return utc;
10173 }
10174 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10175        ((gmtime_emulation_type || my_time(NULL)), \
10176        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10177        ((secs) + utc_offset_secs))))
10178
10179 #ifndef RTL_USES_UTC
10180 /*
10181
10182     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
10183         DST starts on 1st sun of april      at 02:00  std time
10184             ends on last sun of october     at 02:00  dst time
10185     see the UCX management command reference, SET CONFIG TIMEZONE
10186     for formatting info.
10187
10188     No, it's not as general as it should be, but then again, NOTHING
10189     will handle UK times in a sensible way.
10190 */
10191
10192
10193 /*
10194     parse the DST start/end info:
10195     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10196 */
10197
10198 static char *
10199 tz_parse_startend(char *s, struct tm *w, int *past)
10200 {
10201     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10202     int ly, dozjd, d, m, n, hour, min, sec, j, k;
10203     time_t g;
10204
10205     if (!s)    return 0;
10206     if (!w) return 0;
10207     if (!past) return 0;
10208
10209     ly = 0;
10210     if (w->tm_year % 4        == 0) ly = 1;
10211     if (w->tm_year % 100      == 0) ly = 0;
10212     if (w->tm_year+1900 % 400 == 0) ly = 1;
10213     if (ly) dinm[1]++;
10214
10215     dozjd = isdigit(*s);
10216     if (*s == 'J' || *s == 'j' || dozjd) {
10217         if (!dozjd && !isdigit(*++s)) return 0;
10218         d = *s++ - '0';
10219         if (isdigit(*s)) {
10220             d = d*10 + *s++ - '0';
10221             if (isdigit(*s)) {
10222                 d = d*10 + *s++ - '0';
10223             }
10224         }
10225         if (d == 0) return 0;
10226         if (d > 366) return 0;
10227         d--;
10228         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
10229         g = d * 86400;
10230         dozjd = 1;
10231     } else if (*s == 'M' || *s == 'm') {
10232         if (!isdigit(*++s)) return 0;
10233         m = *s++ - '0';
10234         if (isdigit(*s)) m = 10*m + *s++ - '0';
10235         if (*s != '.') return 0;
10236         if (!isdigit(*++s)) return 0;
10237         n = *s++ - '0';
10238         if (n < 1 || n > 5) return 0;
10239         if (*s != '.') return 0;
10240         if (!isdigit(*++s)) return 0;
10241         d = *s++ - '0';
10242         if (d > 6) return 0;
10243     }
10244
10245     if (*s == '/') {
10246         if (!isdigit(*++s)) return 0;
10247         hour = *s++ - '0';
10248         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10249         if (*s == ':') {
10250             if (!isdigit(*++s)) return 0;
10251             min = *s++ - '0';
10252             if (isdigit(*s)) min = 10*min + *s++ - '0';
10253             if (*s == ':') {
10254                 if (!isdigit(*++s)) return 0;
10255                 sec = *s++ - '0';
10256                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10257             }
10258         }
10259     } else {
10260         hour = 2;
10261         min = 0;
10262         sec = 0;
10263     }
10264
10265     if (dozjd) {
10266         if (w->tm_yday < d) goto before;
10267         if (w->tm_yday > d) goto after;
10268     } else {
10269         if (w->tm_mon+1 < m) goto before;
10270         if (w->tm_mon+1 > m) goto after;
10271
10272         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
10273         k = d - j; /* mday of first d */
10274         if (k <= 0) k += 7;
10275         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
10276         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10277         if (w->tm_mday < k) goto before;
10278         if (w->tm_mday > k) goto after;
10279     }
10280
10281     if (w->tm_hour < hour) goto before;
10282     if (w->tm_hour > hour) goto after;
10283     if (w->tm_min  < min)  goto before;
10284     if (w->tm_min  > min)  goto after;
10285     if (w->tm_sec  < sec)  goto before;
10286     goto after;
10287
10288 before:
10289     *past = 0;
10290     return s;
10291 after:
10292     *past = 1;
10293     return s;
10294 }
10295
10296
10297
10298
10299 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
10300
10301 static char *
10302 tz_parse_offset(char *s, int *offset)
10303 {
10304     int hour = 0, min = 0, sec = 0;
10305     int neg = 0;
10306     if (!s) return 0;
10307     if (!offset) return 0;
10308
10309     if (*s == '-') {neg++; s++;}
10310     if (*s == '+') s++;
10311     if (!isdigit(*s)) return 0;
10312     hour = *s++ - '0';
10313     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10314     if (hour > 24) return 0;
10315     if (*s == ':') {
10316         if (!isdigit(*++s)) return 0;
10317         min = *s++ - '0';
10318         if (isdigit(*s)) min = min*10 + (*s++ - '0');
10319         if (min > 59) return 0;
10320         if (*s == ':') {
10321             if (!isdigit(*++s)) return 0;
10322             sec = *s++ - '0';
10323             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10324             if (sec > 59) return 0;
10325         }
10326     }
10327
10328     *offset = (hour*60+min)*60 + sec;
10329     if (neg) *offset = -*offset;
10330     return s;
10331 }
10332
10333 /*
10334     input time is w, whatever type of time the CRTL localtime() uses.
10335     sets dst, the zone, and the gmtoff (seconds)
10336
10337     caches the value of TZ and UCX$TZ env variables; note that
10338     my_setenv looks for these and sets a flag if they're changed
10339     for efficiency.
10340
10341     We have to watch out for the "australian" case (dst starts in
10342     october, ends in april)...flagged by "reverse" and checked by
10343     scanning through the months of the previous year.
10344
10345 */
10346
10347 static int
10348 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10349 {
10350     time_t when;
10351     struct tm *w2;
10352     char *s,*s2;
10353     char *dstzone, *tz, *s_start, *s_end;
10354     int std_off, dst_off, isdst;
10355     int y, dststart, dstend;
10356     static char envtz[1025];  /* longer than any logical, symbol, ... */
10357     static char ucxtz[1025];
10358     static char reversed = 0;
10359
10360     if (!w) return 0;
10361
10362     if (tz_updated) {
10363         tz_updated = 0;
10364         reversed = -1;  /* flag need to check  */
10365         envtz[0] = ucxtz[0] = '\0';
10366         tz = my_getenv("TZ",0);
10367         if (tz) strcpy(envtz, tz);
10368         tz = my_getenv("UCX$TZ",0);
10369         if (tz) strcpy(ucxtz, tz);
10370         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
10371     }
10372     tz = envtz;
10373     if (!*tz) tz = ucxtz;
10374
10375     s = tz;
10376     while (isalpha(*s)) s++;
10377     s = tz_parse_offset(s, &std_off);
10378     if (!s) return 0;
10379     if (!*s) {                  /* no DST, hurray we're done! */
10380         isdst = 0;
10381         goto done;
10382     }
10383
10384     dstzone = s;
10385     while (isalpha(*s)) s++;
10386     s2 = tz_parse_offset(s, &dst_off);
10387     if (s2) {
10388         s = s2;
10389     } else {
10390         dst_off = std_off - 3600;
10391     }
10392
10393     if (!*s) {      /* default dst start/end?? */
10394         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
10395             s = strchr(ucxtz,',');
10396         }
10397         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
10398     }
10399     if (*s != ',') return 0;
10400
10401     when = *w;
10402     when = _toutc(when);      /* convert to utc */
10403     when = when - std_off;    /* convert to pseudolocal time*/
10404
10405     w2 = localtime(&when);
10406     y = w2->tm_year;
10407     s_start = s+1;
10408     s = tz_parse_startend(s_start,w2,&dststart);
10409     if (!s) return 0;
10410     if (*s != ',') return 0;
10411
10412     when = *w;
10413     when = _toutc(when);      /* convert to utc */
10414     when = when - dst_off;    /* convert to pseudolocal time*/
10415     w2 = localtime(&when);
10416     if (w2->tm_year != y) {   /* spans a year, just check one time */
10417         when += dst_off - std_off;
10418         w2 = localtime(&when);
10419     }
10420     s_end = s+1;
10421     s = tz_parse_startend(s_end,w2,&dstend);
10422     if (!s) return 0;
10423
10424     if (reversed == -1) {  /* need to check if start later than end */
10425         int j, ds, de;
10426
10427         when = *w;
10428         if (when < 2*365*86400) {
10429             when += 2*365*86400;
10430         } else {
10431             when -= 365*86400;
10432         }
10433         w2 =localtime(&when);
10434         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
10435
10436         for (j = 0; j < 12; j++) {
10437             w2 =localtime(&when);
10438             tz_parse_startend(s_start,w2,&ds);
10439             tz_parse_startend(s_end,w2,&de);
10440             if (ds != de) break;
10441             when += 30*86400;
10442         }
10443         reversed = 0;
10444         if (de && !ds) reversed = 1;
10445     }
10446
10447     isdst = dststart && !dstend;
10448     if (reversed) isdst = dststart  || !dstend;
10449
10450 done:
10451     if (dst)    *dst = isdst;
10452     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10453     if (isdst)  tz = dstzone;
10454     if (zone) {
10455         while(isalpha(*tz))  *zone++ = *tz++;
10456         *zone = '\0';
10457     }
10458     return 1;
10459 }
10460
10461 #endif /* !RTL_USES_UTC */
10462
10463 /* my_time(), my_localtime(), my_gmtime()
10464  * By default traffic in UTC time values, using CRTL gmtime() or
10465  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10466  * Note: We need to use these functions even when the CRTL has working
10467  * UTC support, since they also handle C<use vmsish qw(times);>
10468  *
10469  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
10470  * Modified by Charles Bailey <bailey@newman.upenn.edu>
10471  */
10472
10473 /*{{{time_t my_time(time_t *timep)*/
10474 time_t Perl_my_time(pTHX_ time_t *timep)
10475 {
10476   time_t when;
10477   struct tm *tm_p;
10478
10479   if (gmtime_emulation_type == 0) {
10480     int dstnow;
10481     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
10482                               /* results of calls to gmtime() and localtime() */
10483                               /* for same &base */
10484
10485     gmtime_emulation_type++;
10486     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10487       char off[LNM$C_NAMLENGTH+1];;
10488
10489       gmtime_emulation_type++;
10490       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10491         gmtime_emulation_type++;
10492         utc_offset_secs = 0;
10493         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10494       }
10495       else { utc_offset_secs = atol(off); }
10496     }
10497     else { /* We've got a working gmtime() */
10498       struct tm gmt, local;
10499
10500       gmt = *tm_p;
10501       tm_p = localtime(&base);
10502       local = *tm_p;
10503       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
10504       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10505       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
10506       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
10507     }
10508   }
10509
10510   when = time(NULL);
10511 # ifdef VMSISH_TIME
10512 # ifdef RTL_USES_UTC
10513   if (VMSISH_TIME) when = _toloc(when);
10514 # else
10515   if (!VMSISH_TIME) when = _toutc(when);
10516 # endif
10517 # endif
10518   if (timep != NULL) *timep = when;
10519   return when;
10520
10521 }  /* end of my_time() */
10522 /*}}}*/
10523
10524
10525 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10526 struct tm *
10527 Perl_my_gmtime(pTHX_ const time_t *timep)
10528 {
10529   char *p;
10530   time_t when;
10531   struct tm *rsltmp;
10532
10533   if (timep == NULL) {
10534     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10535     return NULL;
10536   }
10537   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10538
10539   when = *timep;
10540 # ifdef VMSISH_TIME
10541   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10542 #  endif
10543 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
10544   return gmtime(&when);
10545 # else
10546   /* CRTL localtime() wants local time as input, so does no tz correction */
10547   rsltmp = localtime(&when);
10548   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
10549   return rsltmp;
10550 #endif
10551 }  /* end of my_gmtime() */
10552 /*}}}*/
10553
10554
10555 /*{{{struct tm *my_localtime(const time_t *timep)*/
10556 struct tm *
10557 Perl_my_localtime(pTHX_ const time_t *timep)
10558 {
10559   time_t when, whenutc;
10560   struct tm *rsltmp;
10561   int dst, offset;
10562
10563   if (timep == NULL) {
10564     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10565     return NULL;
10566   }
10567   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10568   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10569
10570   when = *timep;
10571 # ifdef RTL_USES_UTC
10572 # ifdef VMSISH_TIME
10573   if (VMSISH_TIME) when = _toutc(when);
10574 # endif
10575   /* CRTL localtime() wants UTC as input, does tz correction itself */
10576   return localtime(&when);
10577
10578 # else /* !RTL_USES_UTC */
10579   whenutc = when;
10580 # ifdef VMSISH_TIME
10581   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
10582   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
10583 # endif
10584   dst = -1;
10585 #ifndef RTL_USES_UTC
10586   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
10587       when = whenutc - offset;                   /* pseudolocal time*/
10588   }
10589 # endif
10590   /* CRTL localtime() wants local time as input, so does no tz correction */
10591   rsltmp = localtime(&when);
10592   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10593   return rsltmp;
10594 # endif
10595
10596 } /*  end of my_localtime() */
10597 /*}}}*/
10598
10599 /* Reset definitions for later calls */
10600 #define gmtime(t)    my_gmtime(t)
10601 #define localtime(t) my_localtime(t)
10602 #define time(t)      my_time(t)
10603
10604
10605 /* my_utime - update modification/access time of a file
10606  *
10607  * VMS 7.3 and later implementation
10608  * Only the UTC translation is home-grown. The rest is handled by the
10609  * CRTL utime(), which will take into account the relevant feature
10610  * logicals and ODS-5 volume characteristics for true access times.
10611  *
10612  * pre VMS 7.3 implementation:
10613  * The calling sequence is identical to POSIX utime(), but under
10614  * VMS with ODS-2, only the modification time is changed; ODS-2 does
10615  * not maintain access times.  Restrictions differ from the POSIX
10616  * definition in that the time can be changed as long as the
10617  * caller has permission to execute the necessary IO$_MODIFY $QIO;
10618  * no separate checks are made to insure that the caller is the
10619  * owner of the file or has special privs enabled.
10620  * Code here is based on Joe Meadows' FILE utility.
10621  *
10622  */
10623
10624 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10625  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
10626  * in 100 ns intervals.
10627  */
10628 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10629
10630 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10631 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10632 {
10633 #if __CRTL_VER >= 70300000
10634   struct utimbuf utc_utimes, *utc_utimesp;
10635
10636   if (utimes != NULL) {
10637     utc_utimes.actime = utimes->actime;
10638     utc_utimes.modtime = utimes->modtime;
10639 # ifdef VMSISH_TIME
10640     /* If input was local; convert to UTC for sys svc */
10641     if (VMSISH_TIME) {
10642       utc_utimes.actime = _toutc(utimes->actime);
10643       utc_utimes.modtime = _toutc(utimes->modtime);
10644     }
10645 # endif
10646     utc_utimesp = &utc_utimes;
10647   }
10648   else {
10649     utc_utimesp = NULL;
10650   }
10651
10652   return utime(file, utc_utimesp);
10653
10654 #else /* __CRTL_VER < 70300000 */
10655
10656   register int i;
10657   int sts;
10658   long int bintime[2], len = 2, lowbit, unixtime,
10659            secscale = 10000000; /* seconds --> 100 ns intervals */
10660   unsigned long int chan, iosb[2], retsts;
10661   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10662   struct FAB myfab = cc$rms_fab;
10663   struct NAM mynam = cc$rms_nam;
10664 #if defined (__DECC) && defined (__VAX)
10665   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10666    * at least through VMS V6.1, which causes a type-conversion warning.
10667    */
10668 #  pragma message save
10669 #  pragma message disable cvtdiftypes
10670 #endif
10671   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10672   struct fibdef myfib;
10673 #if defined (__DECC) && defined (__VAX)
10674   /* This should be right after the declaration of myatr, but due
10675    * to a bug in VAX DEC C, this takes effect a statement early.
10676    */
10677 #  pragma message restore
10678 #endif
10679   /* cast ok for read only parameter */
10680   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10681                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10682                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10683
10684   if (file == NULL || *file == '\0') {
10685     SETERRNO(ENOENT, LIB$_INVARG);
10686     return -1;
10687   }
10688
10689   /* Convert to VMS format ensuring that it will fit in 255 characters */
10690   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10691       SETERRNO(ENOENT, LIB$_INVARG);
10692       return -1;
10693   }
10694   if (utimes != NULL) {
10695     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
10696      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10697      * Since time_t is unsigned long int, and lib$emul takes a signed long int
10698      * as input, we force the sign bit to be clear by shifting unixtime right
10699      * one bit, then multiplying by an extra factor of 2 in lib$emul().
10700      */
10701     lowbit = (utimes->modtime & 1) ? secscale : 0;
10702     unixtime = (long int) utimes->modtime;
10703 #   ifdef VMSISH_TIME
10704     /* If input was UTC; convert to local for sys svc */
10705     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10706 #   endif
10707     unixtime >>= 1;  secscale <<= 1;
10708     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10709     if (!(retsts & 1)) {
10710       SETERRNO(EVMSERR, retsts);
10711       return -1;
10712     }
10713     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10714     if (!(retsts & 1)) {
10715       SETERRNO(EVMSERR, retsts);
10716       return -1;
10717     }
10718   }
10719   else {
10720     /* Just get the current time in VMS format directly */
10721     retsts = sys$gettim(bintime);
10722     if (!(retsts & 1)) {
10723       SETERRNO(EVMSERR, retsts);
10724       return -1;
10725     }
10726   }
10727
10728   myfab.fab$l_fna = vmsspec;
10729   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10730   myfab.fab$l_nam = &mynam;
10731   mynam.nam$l_esa = esa;
10732   mynam.nam$b_ess = (unsigned char) sizeof esa;
10733   mynam.nam$l_rsa = rsa;
10734   mynam.nam$b_rss = (unsigned char) sizeof rsa;
10735   if (decc_efs_case_preserve)
10736       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10737
10738   /* Look for the file to be affected, letting RMS parse the file
10739    * specification for us as well.  I have set errno using only
10740    * values documented in the utime() man page for VMS POSIX.
10741    */
10742   retsts = sys$parse(&myfab,0,0);
10743   if (!(retsts & 1)) {
10744     set_vaxc_errno(retsts);
10745     if      (retsts == RMS$_PRV) set_errno(EACCES);
10746     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10747     else                         set_errno(EVMSERR);
10748     return -1;
10749   }
10750   retsts = sys$search(&myfab,0,0);
10751   if (!(retsts & 1)) {
10752     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10753     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10754     set_vaxc_errno(retsts);
10755     if      (retsts == RMS$_PRV) set_errno(EACCES);
10756     else if (retsts == RMS$_FNF) set_errno(ENOENT);
10757     else                         set_errno(EVMSERR);
10758     return -1;
10759   }
10760
10761   devdsc.dsc$w_length = mynam.nam$b_dev;
10762   /* cast ok for read only parameter */
10763   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10764
10765   retsts = sys$assign(&devdsc,&chan,0,0);
10766   if (!(retsts & 1)) {
10767     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10768     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10769     set_vaxc_errno(retsts);
10770     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
10771     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
10772     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
10773     else                               set_errno(EVMSERR);
10774     return -1;
10775   }
10776
10777   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10778   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10779
10780   memset((void *) &myfib, 0, sizeof myfib);
10781 #if defined(__DECC) || defined(__DECCXX)
10782   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10783   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10784   /* This prevents the revision time of the file being reset to the current
10785    * time as a result of our IO$_MODIFY $QIO. */
10786   myfib.fib$l_acctl = FIB$M_NORECORD;
10787 #else
10788   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10789   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10790   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10791 #endif
10792   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10793   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10794   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10795   _ckvmssts(sys$dassgn(chan));
10796   if (retsts & 1) retsts = iosb[0];
10797   if (!(retsts & 1)) {
10798     set_vaxc_errno(retsts);
10799     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10800     else                      set_errno(EVMSERR);
10801     return -1;
10802   }
10803
10804   return 0;
10805
10806 #endif /* #if __CRTL_VER >= 70300000 */
10807
10808 }  /* end of my_utime() */
10809 /*}}}*/
10810
10811 /*
10812  * flex_stat, flex_lstat, flex_fstat
10813  * basic stat, but gets it right when asked to stat
10814  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10815  */
10816
10817 #ifndef _USE_STD_STAT
10818 /* encode_dev packs a VMS device name string into an integer to allow
10819  * simple comparisons. This can be used, for example, to check whether two
10820  * files are located on the same device, by comparing their encoded device
10821  * names. Even a string comparison would not do, because stat() reuses the
10822  * device name buffer for each call; so without encode_dev, it would be
10823  * necessary to save the buffer and use strcmp (this would mean a number of
10824  * changes to the standard Perl code, to say nothing of what a Perl script
10825  * would have to do.
10826  *
10827  * The device lock id, if it exists, should be unique (unless perhaps compared
10828  * with lock ids transferred from other nodes). We have a lock id if the disk is
10829  * mounted cluster-wide, which is when we tend to get long (host-qualified)
10830  * device names. Thus we use the lock id in preference, and only if that isn't
10831  * available, do we try to pack the device name into an integer (flagged by
10832  * the sign bit (LOCKID_MASK) being set).
10833  *
10834  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10835  * name and its encoded form, but it seems very unlikely that we will find
10836  * two files on different disks that share the same encoded device names,
10837  * and even more remote that they will share the same file id (if the test
10838  * is to check for the same file).
10839  *
10840  * A better method might be to use sys$device_scan on the first call, and to
10841  * search for the device, returning an index into the cached array.
10842  * The number returned would be more intelligible.
10843  * This is probably not worth it, and anyway would take quite a bit longer
10844  * on the first call.
10845  */
10846 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
10847 static mydev_t encode_dev (pTHX_ const char *dev)
10848 {
10849   int i;
10850   unsigned long int f;
10851   mydev_t enc;
10852   char c;
10853   const char *q;
10854
10855   if (!dev || !dev[0]) return 0;
10856
10857 #if LOCKID_MASK
10858   {
10859     struct dsc$descriptor_s dev_desc;
10860     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10861
10862     /* For cluster-mounted disks, the disk lock identifier is unique, so we
10863        can try that first. */
10864     dev_desc.dsc$w_length =  strlen (dev);
10865     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
10866     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
10867     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
10868     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10869     if (!$VMS_STATUS_SUCCESS(status)) {
10870       switch (status) {
10871         case SS$_NOSUCHDEV:
10872           SETERRNO(ENODEV, status);
10873           return 0;
10874         default:
10875           _ckvmssts(status);
10876       }
10877     }
10878     if (lockid) return (lockid & ~LOCKID_MASK);
10879   }
10880 #endif
10881
10882   /* Otherwise we try to encode the device name */
10883   enc = 0;
10884   f = 1;
10885   i = 0;
10886   for (q = dev + strlen(dev); q--; q >= dev) {
10887     if (*q == ':')
10888         break;
10889     if (isdigit (*q))
10890       c= (*q) - '0';
10891     else if (isalpha (toupper (*q)))
10892       c= toupper (*q) - 'A' + (char)10;
10893     else
10894       continue; /* Skip '$'s */
10895     i++;
10896     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
10897     if (i>1) f *= 36;
10898     enc += f * (unsigned long int) c;
10899   }
10900   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
10901
10902 }  /* end of encode_dev() */
10903 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10904         device_no = encode_dev(aTHX_ devname)
10905 #else
10906 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10907         device_no = new_dev_no
10908 #endif
10909
10910 static int
10911 is_null_device(name)
10912     const char *name;
10913 {
10914   if (decc_bug_devnull != 0) {
10915     if (strncmp("/dev/null", name, 9) == 0)
10916       return 1;
10917   }
10918     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10919        The underscore prefix, controller letter, and unit number are
10920        independently optional; for our purposes, the colon punctuation
10921        is not.  The colon can be trailed by optional directory and/or
10922        filename, but two consecutive colons indicates a nodename rather
10923        than a device.  [pr]  */
10924   if (*name == '_') ++name;
10925   if (tolower(*name++) != 'n') return 0;
10926   if (tolower(*name++) != 'l') return 0;
10927   if (tolower(*name) == 'a') ++name;
10928   if (*name == '0') ++name;
10929   return (*name++ == ':') && (*name != ':');
10930 }
10931
10932
10933 static I32
10934 Perl_cando_by_name_int
10935    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10936 {
10937   char usrname[L_cuserid];
10938   struct dsc$descriptor_s usrdsc =
10939          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10940   char *vmsname = NULL, *fileified = NULL;
10941   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10942   unsigned short int retlen, trnlnm_iter_count;
10943   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10944   union prvdef curprv;
10945   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10946          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10947          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10948   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10949          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10950          {0,0,0,0}};
10951   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10952          {0,0,0,0}};
10953   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10954   Stat_t st;
10955   static int profile_context = -1;
10956
10957   if (!fname || !*fname) return FALSE;
10958
10959   /* Make sure we expand logical names, since sys$check_access doesn't */
10960   fileified = PerlMem_malloc(VMS_MAXRSS);
10961   if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
10962   if (!strpbrk(fname,"/]>:")) {
10963       strcpy(fileified,fname);
10964       trnlnm_iter_count = 0;
10965       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
10966         trnlnm_iter_count++;
10967         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10968       }
10969       fname = fileified;
10970   }
10971
10972   vmsname = PerlMem_malloc(VMS_MAXRSS);
10973   if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
10974   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
10975     /* Don't know if already in VMS format, so make sure */
10976     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10977       PerlMem_free(fileified);
10978       PerlMem_free(vmsname);
10979       return FALSE;
10980     }
10981   }
10982   else {
10983     strcpy(vmsname,fname);
10984   }
10985
10986   /* sys$check_access needs a file spec, not a directory spec.
10987    * Don't use flex_stat here, as that depends on thread context
10988    * having been initialized, and we may get here during startup.
10989    */
10990
10991   retlen = namdsc.dsc$w_length = strlen(vmsname);
10992   if (vmsname[retlen-1] == ']'
10993       || vmsname[retlen-1] == '>'
10994       || vmsname[retlen-1] == ':'
10995       || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
10996
10997       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
10998         PerlMem_free(fileified);
10999         PerlMem_free(vmsname);
11000         return FALSE;
11001       }
11002       fname = fileified;
11003   }
11004   else {
11005       fname = vmsname;
11006   }
11007
11008   retlen = namdsc.dsc$w_length = strlen(fname);
11009   namdsc.dsc$a_pointer = (char *)fname;
11010
11011   switch (bit) {
11012     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11013       access = ARM$M_EXECUTE;
11014       flags = CHP$M_READ;
11015       break;
11016     case S_IRUSR: case S_IRGRP: case S_IROTH:
11017       access = ARM$M_READ;
11018       flags = CHP$M_READ | CHP$M_USEREADALL;
11019       break;
11020     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11021       access = ARM$M_WRITE;
11022       flags = CHP$M_READ | CHP$M_WRITE;
11023       break;
11024     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11025       access = ARM$M_DELETE;
11026       flags = CHP$M_READ | CHP$M_WRITE;
11027       break;
11028     default:
11029       if (fileified != NULL)
11030         PerlMem_free(fileified);
11031       if (vmsname != NULL)
11032         PerlMem_free(vmsname);
11033       return FALSE;
11034   }
11035
11036   /* Before we call $check_access, create a user profile with the current
11037    * process privs since otherwise it just uses the default privs from the
11038    * UAF and might give false positives or negatives.  This only works on
11039    * VMS versions v6.0 and later since that's when sys$create_user_profile
11040    * became available.
11041    */
11042
11043   /* get current process privs and username */
11044   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11045   _ckvmssts(iosb[0]);
11046
11047 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11048
11049   /* find out the space required for the profile */
11050   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11051                                     &usrprodsc.dsc$w_length,&profile_context));
11052
11053   /* allocate space for the profile and get it filled in */
11054   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11055   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11056   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11057                                     &usrprodsc.dsc$w_length,&profile_context));
11058
11059   /* use the profile to check access to the file; free profile & analyze results */
11060   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11061   PerlMem_free(usrprodsc.dsc$a_pointer);
11062   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11063
11064 #else
11065
11066   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11067
11068 #endif
11069
11070   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11071       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11072       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11073     set_vaxc_errno(retsts);
11074     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11075     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11076     else set_errno(ENOENT);
11077     if (fileified != NULL)
11078       PerlMem_free(fileified);
11079     if (vmsname != NULL)
11080       PerlMem_free(vmsname);
11081     return FALSE;
11082   }
11083   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11084     if (fileified != NULL)
11085       PerlMem_free(fileified);
11086     if (vmsname != NULL)
11087       PerlMem_free(vmsname);
11088     return TRUE;
11089   }
11090   _ckvmssts(retsts);
11091
11092   if (fileified != NULL)
11093     PerlMem_free(fileified);
11094   if (vmsname != NULL)
11095     PerlMem_free(vmsname);
11096   return FALSE;  /* Should never get here */
11097
11098 }
11099
11100 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
11101 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11102  * subset of the applicable information.
11103  */
11104 bool
11105 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11106 {
11107   return cando_by_name_int
11108         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11109 }  /* end of cando() */
11110 /*}}}*/
11111
11112
11113 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11114 I32
11115 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11116 {
11117    return cando_by_name_int(bit, effective, fname, 0);
11118
11119 }  /* end of cando_by_name() */
11120 /*}}}*/
11121
11122
11123 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11124 int
11125 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11126 {
11127   if (!fstat(fd,(stat_t *) statbufp)) {
11128     char *cptr;
11129     char *vms_filename;
11130     vms_filename = PerlMem_malloc(VMS_MAXRSS);
11131     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11132
11133     /* Save name for cando by name in VMS format */
11134     cptr = getname(fd, vms_filename, 1);
11135
11136     /* This should not happen, but just in case */
11137     if (cptr == NULL) {
11138         statbufp->st_devnam[0] = 0;
11139     }
11140     else {
11141         /* Make sure that the saved name fits in 255 characters */
11142         cptr = do_rmsexpand
11143                        (vms_filename,
11144                         statbufp->st_devnam,
11145                         0,
11146                         NULL,
11147                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11148                         NULL,
11149                         NULL);
11150         if (cptr == NULL)
11151             statbufp->st_devnam[0] = 0;
11152     }
11153     PerlMem_free(vms_filename);
11154
11155     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11156     VMS_DEVICE_ENCODE
11157         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11158
11159 #   ifdef RTL_USES_UTC
11160 #   ifdef VMSISH_TIME
11161     if (VMSISH_TIME) {
11162       statbufp->st_mtime = _toloc(statbufp->st_mtime);
11163       statbufp->st_atime = _toloc(statbufp->st_atime);
11164       statbufp->st_ctime = _toloc(statbufp->st_ctime);
11165     }
11166 #   endif
11167 #   else
11168 #   ifdef VMSISH_TIME
11169     if (!VMSISH_TIME) { /* Return UTC instead of local time */
11170 #   else
11171     if (1) {
11172 #   endif
11173       statbufp->st_mtime = _toutc(statbufp->st_mtime);
11174       statbufp->st_atime = _toutc(statbufp->st_atime);
11175       statbufp->st_ctime = _toutc(statbufp->st_ctime);
11176     }
11177 #endif
11178     return 0;
11179   }
11180   return -1;
11181
11182 }  /* end of flex_fstat() */
11183 /*}}}*/
11184
11185 #if !defined(__VAX) && __CRTL_VER >= 80200000
11186 #ifdef lstat
11187 #undef lstat
11188 #endif
11189 #else
11190 #ifdef lstat
11191 #undef lstat
11192 #endif
11193 #define lstat(_x, _y) stat(_x, _y)
11194 #endif
11195
11196 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11197
11198 static int
11199 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11200 {
11201     char fileified[VMS_MAXRSS];
11202     char temp_fspec[VMS_MAXRSS];
11203     char *save_spec;
11204     int retval = -1;
11205     int saved_errno, saved_vaxc_errno;
11206
11207     if (!fspec) return retval;
11208     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11209     strcpy(temp_fspec, fspec);
11210
11211     if (decc_bug_devnull != 0) {
11212       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11213         memset(statbufp,0,sizeof *statbufp);
11214         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11215         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11216         statbufp->st_uid = 0x00010001;
11217         statbufp->st_gid = 0x0001;
11218         time((time_t *)&statbufp->st_mtime);
11219         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11220         return 0;
11221       }
11222     }
11223
11224     /* Try for a directory name first.  If fspec contains a filename without
11225      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11226      * and sea:[wine.dark]water. exist, we prefer the directory here.
11227      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11228      * not sea:[wine.dark]., if the latter exists.  If the intended target is
11229      * the file with null type, specify this by calling flex_stat() with
11230      * a '.' at the end of fspec.
11231      *
11232      * If we are in Posix filespec mode, accept the filename as is.
11233      */
11234
11235
11236 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11237   /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11238    * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11239    */
11240   if (!decc_efs_charset)
11241     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11242 #endif
11243
11244 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11245   if (decc_posix_compliant_pathnames == 0) {
11246 #endif
11247     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11248       if (lstat_flag == 0)
11249         retval = stat(fileified,(stat_t *) statbufp);
11250       else
11251         retval = lstat(fileified,(stat_t *) statbufp);
11252       save_spec = fileified;
11253     }
11254     if (retval) {
11255       if (lstat_flag == 0)
11256         retval = stat(temp_fspec,(stat_t *) statbufp);
11257       else
11258         retval = lstat(temp_fspec,(stat_t *) statbufp);
11259       save_spec = temp_fspec;
11260     }
11261 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11262   } else {
11263     if (lstat_flag == 0)
11264       retval = stat(temp_fspec,(stat_t *) statbufp);
11265     else
11266       retval = lstat(temp_fspec,(stat_t *) statbufp);
11267       save_spec = temp_fspec;
11268   }
11269 #endif
11270
11271 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11272   /* As you were... */
11273   if (!decc_efs_charset)
11274     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11275 #endif
11276
11277     if (!retval) {
11278     char * cptr;
11279       cptr = do_rmsexpand
11280        (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
11281       if (cptr == NULL)
11282         statbufp->st_devnam[0] = 0;
11283
11284       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11285       VMS_DEVICE_ENCODE
11286         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11287 #     ifdef RTL_USES_UTC
11288 #     ifdef VMSISH_TIME
11289       if (VMSISH_TIME) {
11290         statbufp->st_mtime = _toloc(statbufp->st_mtime);
11291         statbufp->st_atime = _toloc(statbufp->st_atime);
11292         statbufp->st_ctime = _toloc(statbufp->st_ctime);
11293       }
11294 #     endif
11295 #     else
11296 #     ifdef VMSISH_TIME
11297       if (!VMSISH_TIME) { /* Return UTC instead of local time */
11298 #     else
11299       if (1) {
11300 #     endif
11301         statbufp->st_mtime = _toutc(statbufp->st_mtime);
11302         statbufp->st_atime = _toutc(statbufp->st_atime);
11303         statbufp->st_ctime = _toutc(statbufp->st_ctime);
11304       }
11305 #     endif
11306     }
11307     /* If we were successful, leave errno where we found it */
11308     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
11309     return retval;
11310
11311 }  /* end of flex_stat_int() */
11312
11313
11314 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
11315 int
11316 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
11317 {
11318    return flex_stat_int(fspec, statbufp, 0);
11319 }
11320 /*}}}*/
11321
11322 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
11323 int
11324 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
11325 {
11326    return flex_stat_int(fspec, statbufp, 1);
11327 }
11328 /*}}}*/
11329
11330
11331 /*{{{char *my_getlogin()*/
11332 /* VMS cuserid == Unix getlogin, except calling sequence */
11333 char *
11334 my_getlogin(void)
11335 {
11336     static char user[L_cuserid];
11337     return cuserid(user);
11338 }
11339 /*}}}*/
11340
11341
11342 /*  rmscopy - copy a file using VMS RMS routines
11343  *
11344  *  Copies contents and attributes of spec_in to spec_out, except owner
11345  *  and protection information.  Name and type of spec_in are used as
11346  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
11347  *  should try to propagate timestamps from the input file to the output file.
11348  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
11349  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
11350  *  propagated to the output file at creation iff the output file specification
11351  *  did not contain an explicit name or type, and the revision date is always
11352  *  updated at the end of the copy operation.  If it is greater than 0, then
11353  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11354  *  other than the revision date should be propagated, and bit 1 indicates
11355  *  that the revision date should be propagated.
11356  *
11357  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11358  *
11359  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11360  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
11361  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
11362  * as part of the Perl standard distribution under the terms of the
11363  * GNU General Public License or the Perl Artistic License.  Copies
11364  * of each may be found in the Perl standard distribution.
11365  */ /* FIXME */
11366 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11367 int
11368 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11369 {
11370     char *vmsin, * vmsout, *esa, *esa_out,
11371          *rsa, *ubf;
11372     unsigned long int i, sts, sts2;
11373     int dna_len;
11374     struct FAB fab_in, fab_out;
11375     struct RAB rab_in, rab_out;
11376     rms_setup_nam(nam);
11377     rms_setup_nam(nam_out);
11378     struct XABDAT xabdat;
11379     struct XABFHC xabfhc;
11380     struct XABRDT xabrdt;
11381     struct XABSUM xabsum;
11382
11383     vmsin = PerlMem_malloc(VMS_MAXRSS);
11384     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11385     vmsout = PerlMem_malloc(VMS_MAXRSS);
11386     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11387     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11388         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11389       PerlMem_free(vmsin);
11390       PerlMem_free(vmsout);
11391       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11392       return 0;
11393     }
11394
11395     esa = PerlMem_malloc(VMS_MAXRSS);
11396     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11397     fab_in = cc$rms_fab;
11398     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11399     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11400     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11401     fab_in.fab$l_fop = FAB$M_SQO;
11402     rms_bind_fab_nam(fab_in, nam);
11403     fab_in.fab$l_xab = (void *) &xabdat;
11404
11405     rsa = PerlMem_malloc(VMS_MAXRSS);
11406     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11407     rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11408     rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11409     rms_nam_esl(nam) = 0;
11410     rms_nam_rsl(nam) = 0;
11411     rms_nam_esll(nam) = 0;
11412     rms_nam_rsll(nam) = 0;
11413 #ifdef NAM$M_NO_SHORT_UPCASE
11414     if (decc_efs_case_preserve)
11415         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11416 #endif
11417
11418     xabdat = cc$rms_xabdat;        /* To get creation date */
11419     xabdat.xab$l_nxt = (void *) &xabfhc;
11420
11421     xabfhc = cc$rms_xabfhc;        /* To get record length */
11422     xabfhc.xab$l_nxt = (void *) &xabsum;
11423
11424     xabsum = cc$rms_xabsum;        /* To get key and area information */
11425
11426     if (!((sts = sys$open(&fab_in)) & 1)) {
11427       PerlMem_free(vmsin);
11428       PerlMem_free(vmsout);
11429       PerlMem_free(esa);
11430       PerlMem_free(rsa);
11431       set_vaxc_errno(sts);
11432       switch (sts) {
11433         case RMS$_FNF: case RMS$_DNF:
11434           set_errno(ENOENT); break;
11435         case RMS$_DIR:
11436           set_errno(ENOTDIR); break;
11437         case RMS$_DEV:
11438           set_errno(ENODEV); break;
11439         case RMS$_SYN:
11440           set_errno(EINVAL); break;
11441         case RMS$_PRV:
11442           set_errno(EACCES); break;
11443         default:
11444           set_errno(EVMSERR);
11445       }
11446       return 0;
11447     }
11448
11449     nam_out = nam;
11450     fab_out = fab_in;
11451     fab_out.fab$w_ifi = 0;
11452     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11453     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11454     fab_out.fab$l_fop = FAB$M_SQO;
11455     rms_bind_fab_nam(fab_out, nam_out);
11456     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11457     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11458     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11459     esa_out = PerlMem_malloc(VMS_MAXRSS);
11460     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11461     rms_set_rsa(nam_out, NULL, 0);
11462     rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11463
11464     if (preserve_dates == 0) {  /* Act like DCL COPY */
11465       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11466       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
11467       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11468         PerlMem_free(vmsin);
11469         PerlMem_free(vmsout);
11470         PerlMem_free(esa);
11471         PerlMem_free(rsa);
11472         PerlMem_free(esa_out);
11473         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11474         set_vaxc_errno(sts);
11475         return 0;
11476       }
11477       fab_out.fab$l_xab = (void *) &xabdat;
11478       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11479         preserve_dates = 1;
11480     }
11481     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
11482       preserve_dates =0;      /* bitmask from this point forward   */
11483
11484     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11485     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11486       PerlMem_free(vmsin);
11487       PerlMem_free(vmsout);
11488       PerlMem_free(esa);
11489       PerlMem_free(rsa);
11490       PerlMem_free(esa_out);
11491       set_vaxc_errno(sts);
11492       switch (sts) {
11493         case RMS$_DNF:
11494           set_errno(ENOENT); break;
11495         case RMS$_DIR:
11496           set_errno(ENOTDIR); break;
11497         case RMS$_DEV:
11498           set_errno(ENODEV); break;
11499         case RMS$_SYN:
11500           set_errno(EINVAL); break;
11501         case RMS$_PRV:
11502           set_errno(EACCES); break;
11503         default:
11504           set_errno(EVMSERR);
11505       }
11506       return 0;
11507     }
11508     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
11509     if (preserve_dates & 2) {
11510       /* sys$close() will process xabrdt, not xabdat */
11511       xabrdt = cc$rms_xabrdt;
11512 #ifndef __GNUC__
11513       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11514 #else
11515       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11516        * is unsigned long[2], while DECC & VAXC use a struct */
11517       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11518 #endif
11519       fab_out.fab$l_xab = (void *) &xabrdt;
11520     }
11521
11522     ubf = PerlMem_malloc(32256);
11523     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11524     rab_in = cc$rms_rab;
11525     rab_in.rab$l_fab = &fab_in;
11526     rab_in.rab$l_rop = RAB$M_BIO;
11527     rab_in.rab$l_ubf = ubf;
11528     rab_in.rab$w_usz = 32256;
11529     if (!((sts = sys$connect(&rab_in)) & 1)) {
11530       sys$close(&fab_in); sys$close(&fab_out);
11531       PerlMem_free(vmsin);
11532       PerlMem_free(vmsout);
11533       PerlMem_free(esa);
11534       PerlMem_free(ubf);
11535       PerlMem_free(rsa);
11536       PerlMem_free(esa_out);
11537       set_errno(EVMSERR); set_vaxc_errno(sts);
11538       return 0;
11539     }
11540
11541     rab_out = cc$rms_rab;
11542     rab_out.rab$l_fab = &fab_out;
11543     rab_out.rab$l_rbf = ubf;
11544     if (!((sts = sys$connect(&rab_out)) & 1)) {
11545       sys$close(&fab_in); sys$close(&fab_out);
11546       PerlMem_free(vmsin);
11547       PerlMem_free(vmsout);
11548       PerlMem_free(esa);
11549       PerlMem_free(ubf);
11550       PerlMem_free(rsa);
11551       PerlMem_free(esa_out);
11552       set_errno(EVMSERR); set_vaxc_errno(sts);
11553       return 0;
11554     }
11555
11556     while ((sts = sys$read(&rab_in))) {  /* always true  */
11557       if (sts == RMS$_EOF) break;
11558       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11559       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11560         sys$close(&fab_in); sys$close(&fab_out);
11561         PerlMem_free(vmsin);
11562         PerlMem_free(vmsout);
11563         PerlMem_free(esa);
11564         PerlMem_free(ubf);
11565         PerlMem_free(rsa);
11566         PerlMem_free(esa_out);
11567         set_errno(EVMSERR); set_vaxc_errno(sts);
11568         return 0;
11569       }
11570     }
11571
11572
11573     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
11574     sys$close(&fab_in);  sys$close(&fab_out);
11575     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11576     if (!(sts & 1)) {
11577       PerlMem_free(vmsin);
11578       PerlMem_free(vmsout);
11579       PerlMem_free(esa);
11580       PerlMem_free(ubf);
11581       PerlMem_free(rsa);
11582       PerlMem_free(esa_out);
11583       set_errno(EVMSERR); set_vaxc_errno(sts);
11584       return 0;
11585     }
11586
11587     PerlMem_free(vmsin);
11588     PerlMem_free(vmsout);
11589     PerlMem_free(esa);
11590     PerlMem_free(ubf);
11591     PerlMem_free(rsa);
11592     PerlMem_free(esa_out);
11593     return 1;
11594
11595 }  /* end of rmscopy() */
11596 /*}}}*/
11597
11598
11599 /***  The following glue provides 'hooks' to make some of the routines
11600  * from this file available from Perl.  These routines are sufficiently
11601  * basic, and are required sufficiently early in the build process,
11602  * that's it's nice to have them available to miniperl as well as the
11603  * full Perl, so they're set up here instead of in an extension.  The
11604  * Perl code which handles importation of these names into a given
11605  * package lives in [.VMS]Filespec.pm in @INC.
11606  */
11607
11608 void
11609 rmsexpand_fromperl(pTHX_ CV *cv)
11610 {
11611   dXSARGS;
11612   char *fspec, *defspec = NULL, *rslt;
11613   STRLEN n_a;
11614   int fs_utf8, dfs_utf8;
11615
11616   fs_utf8 = 0;
11617   dfs_utf8 = 0;
11618   if (!items || items > 2)
11619     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11620   fspec = SvPV(ST(0),n_a);
11621   fs_utf8 = SvUTF8(ST(0));
11622   if (!fspec || !*fspec) XSRETURN_UNDEF;
11623   if (items == 2) {
11624     defspec = SvPV(ST(1),n_a);
11625     dfs_utf8 = SvUTF8(ST(1));
11626   }
11627   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11628   ST(0) = sv_newmortal();
11629   if (rslt != NULL) {
11630     sv_usepvn(ST(0),rslt,strlen(rslt));
11631     if (fs_utf8) {
11632         SvUTF8_on(ST(0));
11633     }
11634   }
11635   XSRETURN(1);
11636 }
11637
11638 void
11639 vmsify_fromperl(pTHX_ CV *cv)
11640 {
11641   dXSARGS;
11642   char *vmsified;
11643   STRLEN n_a;
11644   int utf8_fl;
11645
11646   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11647   utf8_fl = SvUTF8(ST(0));
11648   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11649   ST(0) = sv_newmortal();
11650   if (vmsified != NULL) {
11651     sv_usepvn(ST(0),vmsified,strlen(vmsified));
11652     if (utf8_fl) {
11653         SvUTF8_on(ST(0));
11654     }
11655   }
11656   XSRETURN(1);
11657 }
11658
11659 void
11660 unixify_fromperl(pTHX_ CV *cv)
11661 {
11662   dXSARGS;
11663   char *unixified;
11664   STRLEN n_a;
11665   int utf8_fl;
11666
11667   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11668   utf8_fl = SvUTF8(ST(0));
11669   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11670   ST(0) = sv_newmortal();
11671   if (unixified != NULL) {
11672     sv_usepvn(ST(0),unixified,strlen(unixified));
11673     if (utf8_fl) {
11674         SvUTF8_on(ST(0));
11675     }
11676   }
11677   XSRETURN(1);
11678 }
11679
11680 void
11681 fileify_fromperl(pTHX_ CV *cv)
11682 {
11683   dXSARGS;
11684   char *fileified;
11685   STRLEN n_a;
11686   int utf8_fl;
11687
11688   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11689   utf8_fl = SvUTF8(ST(0));
11690   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11691   ST(0) = sv_newmortal();
11692   if (fileified != NULL) {
11693     sv_usepvn(ST(0),fileified,strlen(fileified));
11694     if (utf8_fl) {
11695         SvUTF8_on(ST(0));
11696     }
11697   }
11698   XSRETURN(1);
11699 }
11700
11701 void
11702 pathify_fromperl(pTHX_ CV *cv)
11703 {
11704   dXSARGS;
11705   char *pathified;
11706   STRLEN n_a;
11707   int utf8_fl;
11708
11709   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11710   utf8_fl = SvUTF8(ST(0));
11711   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11712   ST(0) = sv_newmortal();
11713   if (pathified != NULL) {
11714     sv_usepvn(ST(0),pathified,strlen(pathified));
11715     if (utf8_fl) {
11716         SvUTF8_on(ST(0));
11717     }
11718   }
11719   XSRETURN(1);
11720 }
11721
11722 void
11723 vmspath_fromperl(pTHX_ CV *cv)
11724 {
11725   dXSARGS;
11726   char *vmspath;
11727   STRLEN n_a;
11728   int utf8_fl;
11729
11730   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11731   utf8_fl = SvUTF8(ST(0));
11732   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11733   ST(0) = sv_newmortal();
11734   if (vmspath != NULL) {
11735     sv_usepvn(ST(0),vmspath,strlen(vmspath));
11736     if (utf8_fl) {
11737         SvUTF8_on(ST(0));
11738     }
11739   }
11740   XSRETURN(1);
11741 }
11742
11743 void
11744 unixpath_fromperl(pTHX_ CV *cv)
11745 {
11746   dXSARGS;
11747   char *unixpath;
11748   STRLEN n_a;
11749   int utf8_fl;
11750
11751   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11752   utf8_fl = SvUTF8(ST(0));
11753   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11754   ST(0) = sv_newmortal();
11755   if (unixpath != NULL) {
11756     sv_usepvn(ST(0),unixpath,strlen(unixpath));
11757     if (utf8_fl) {
11758         SvUTF8_on(ST(0));
11759     }
11760   }
11761   XSRETURN(1);
11762 }
11763
11764 void
11765 candelete_fromperl(pTHX_ CV *cv)
11766 {
11767   dXSARGS;
11768   char *fspec, *fsp;
11769   SV *mysv;
11770   IO *io;
11771   STRLEN n_a;
11772
11773   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11774
11775   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11776   Newx(fspec, VMS_MAXRSS, char);
11777   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11778   if (SvTYPE(mysv) == SVt_PVGV) {
11779     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11780       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11781       ST(0) = &PL_sv_no;
11782       Safefree(fspec);
11783       XSRETURN(1);
11784     }
11785     fsp = fspec;
11786   }
11787   else {
11788     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11789       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11790       ST(0) = &PL_sv_no;
11791       Safefree(fspec);
11792       XSRETURN(1);
11793     }
11794   }
11795
11796   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11797   Safefree(fspec);
11798   XSRETURN(1);
11799 }
11800
11801 void
11802 rmscopy_fromperl(pTHX_ CV *cv)
11803 {
11804   dXSARGS;
11805   char *inspec, *outspec, *inp, *outp;
11806   int date_flag;
11807   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11808                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11809   unsigned long int sts;
11810   SV *mysv;
11811   IO *io;
11812   STRLEN n_a;
11813
11814   if (items < 2 || items > 3)
11815     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11816
11817   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11818   Newx(inspec, VMS_MAXRSS, char);
11819   if (SvTYPE(mysv) == SVt_PVGV) {
11820     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11821       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11822       ST(0) = &PL_sv_no;
11823       Safefree(inspec);
11824       XSRETURN(1);
11825     }
11826     inp = inspec;
11827   }
11828   else {
11829     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11830       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11831       ST(0) = &PL_sv_no;
11832       Safefree(inspec);
11833       XSRETURN(1);
11834     }
11835   }
11836   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11837   Newx(outspec, VMS_MAXRSS, char);
11838   if (SvTYPE(mysv) == SVt_PVGV) {
11839     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11840       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11841       ST(0) = &PL_sv_no;
11842       Safefree(inspec);
11843       Safefree(outspec);
11844       XSRETURN(1);
11845     }
11846     outp = outspec;
11847   }
11848   else {
11849     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11850       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11851       ST(0) = &PL_sv_no;
11852       Safefree(inspec);
11853       Safefree(outspec);
11854       XSRETURN(1);
11855     }
11856   }
11857   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11858
11859   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11860   Safefree(inspec);
11861   Safefree(outspec);
11862   XSRETURN(1);
11863 }
11864
11865 /* The mod2fname is limited to shorter filenames by design, so it should
11866  * not be modified to support longer EFS pathnames
11867  */
11868 void
11869 mod2fname(pTHX_ CV *cv)
11870 {
11871   dXSARGS;
11872   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11873        workbuff[NAM$C_MAXRSS*1 + 1];
11874   int total_namelen = 3, counter, num_entries;
11875   /* ODS-5 ups this, but we want to be consistent, so... */
11876   int max_name_len = 39;
11877   AV *in_array = (AV *)SvRV(ST(0));
11878
11879   num_entries = av_len(in_array);
11880
11881   /* All the names start with PL_. */
11882   strcpy(ultimate_name, "PL_");
11883
11884   /* Clean up our working buffer */
11885   Zero(work_name, sizeof(work_name), char);
11886
11887   /* Run through the entries and build up a working name */
11888   for(counter = 0; counter <= num_entries; counter++) {
11889     /* If it's not the first name then tack on a __ */
11890     if (counter) {
11891       strcat(work_name, "__");
11892     }
11893     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11894                            PL_na));
11895   }
11896
11897   /* Check to see if we actually have to bother...*/
11898   if (strlen(work_name) + 3 <= max_name_len) {
11899     strcat(ultimate_name, work_name);
11900   } else {
11901     /* It's too darned big, so we need to go strip. We use the same */
11902     /* algorithm as xsubpp does. First, strip out doubled __ */
11903     char *source, *dest, last;
11904     dest = workbuff;
11905     last = 0;
11906     for (source = work_name; *source; source++) {
11907       if (last == *source && last == '_') {
11908         continue;
11909       }
11910       *dest++ = *source;
11911       last = *source;
11912     }
11913     /* Go put it back */
11914     strcpy(work_name, workbuff);
11915     /* Is it still too big? */
11916     if (strlen(work_name) + 3 > max_name_len) {
11917       /* Strip duplicate letters */
11918       last = 0;
11919       dest = workbuff;
11920       for (source = work_name; *source; source++) {
11921         if (last == toupper(*source)) {
11922         continue;
11923         }
11924         *dest++ = *source;
11925         last = toupper(*source);
11926       }
11927       strcpy(work_name, workbuff);
11928     }
11929
11930     /* Is it *still* too big? */
11931     if (strlen(work_name) + 3 > max_name_len) {
11932       /* Too bad, we truncate */
11933       work_name[max_name_len - 2] = 0;
11934     }
11935     strcat(ultimate_name, work_name);
11936   }
11937
11938   /* Okay, return it */
11939   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11940   XSRETURN(1);
11941 }
11942
11943 void
11944 hushexit_fromperl(pTHX_ CV *cv)
11945 {
11946     dXSARGS;
11947
11948     if (items > 0) {
11949         VMSISH_HUSHED = SvTRUE(ST(0));
11950     }
11951     ST(0) = boolSV(VMSISH_HUSHED);
11952     XSRETURN(1);
11953 }
11954
11955
11956 PerlIO *
11957 Perl_vms_start_glob
11958    (pTHX_ SV *tmpglob,
11959     IO *io)
11960 {
11961     PerlIO *fp;
11962     struct vs_str_st *rslt;
11963     char *vmsspec;
11964     char *rstr;
11965     char *begin, *cp;
11966     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11967     PerlIO *tmpfp;
11968     STRLEN i;
11969     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11970     struct dsc$descriptor_vs rsdsc;
11971     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11972     unsigned long hasver = 0, isunix = 0;
11973     unsigned long int lff_flags = 0;
11974     int rms_sts;
11975
11976 #ifdef VMS_LONGNAME_SUPPORT
11977     lff_flags = LIB$M_FIL_LONG_NAMES;
11978 #endif
11979     /* The Newx macro will not allow me to assign a smaller array
11980      * to the rslt pointer, so we will assign it to the begin char pointer
11981      * and then copy the value into the rslt pointer.
11982      */
11983     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11984     rslt = (struct vs_str_st *)begin;
11985     rslt->length = 0;
11986     rstr = &rslt->str[0];
11987     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11988     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11989     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11990     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11991
11992     Newx(vmsspec, VMS_MAXRSS, char);
11993
11994         /* We could find out if there's an explicit dev/dir or version
11995            by peeking into lib$find_file's internal context at
11996            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11997            but that's unsupported, so I don't want to do it now and
11998            have it bite someone in the future. */
11999         /* Fix-me: vms_split_path() is the only way to do this, the
12000            existing method will fail with many legal EFS or UNIX specifications
12001          */
12002
12003     cp = SvPV(tmpglob,i);
12004
12005     for (; i; i--) {
12006         if (cp[i] == ';') hasver = 1;
12007         if (cp[i] == '.') {
12008             if (sts) hasver = 1;
12009             else sts = 1;
12010         }
12011         if (cp[i] == '/') {
12012             hasdir = isunix = 1;
12013             break;
12014         }
12015         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12016             hasdir = 1;
12017             break;
12018         }
12019     }
12020     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12021         int found = 0;
12022         Stat_t st;
12023         int stat_sts;
12024         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12025         if (!stat_sts && S_ISDIR(st.st_mode)) {
12026             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12027             ok = (wilddsc.dsc$a_pointer != NULL);
12028             /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12029             hasdir = 1;
12030         }
12031         else {
12032             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12033             ok = (wilddsc.dsc$a_pointer != NULL);
12034         }
12035         if (ok)
12036             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12037
12038         /* If not extended character set, replace ? with % */
12039         /* With extended character set, ? is a wildcard single character */
12040         if (!decc_efs_case_preserve) {
12041             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12042                 if (*cp == '?') *cp = '%';
12043         }
12044         sts = SS$_NORMAL;
12045         while (ok && $VMS_STATUS_SUCCESS(sts)) {
12046          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12047          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12048
12049             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12050                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
12051             if (!$VMS_STATUS_SUCCESS(sts))
12052                 break;
12053
12054             found++;
12055
12056             /* with varying string, 1st word of buffer contains result length */
12057             rstr[rslt->length] = '\0';
12058
12059              /* Find where all the components are */
12060              v_sts = vms_split_path
12061                        (rstr,
12062                         &v_spec,
12063                         &v_len,
12064                         &r_spec,
12065                         &r_len,
12066                         &d_spec,
12067                         &d_len,
12068                         &n_spec,
12069                         &n_len,
12070                         &e_spec,
12071                         &e_len,
12072                         &vs_spec,
12073                         &vs_len);
12074
12075             /* If no version on input, truncate the version on output */
12076             if (!hasver && (vs_len > 0)) {
12077                 *vs_spec = '\0';
12078                 vs_len = 0;
12079
12080                 /* No version & a null extension on UNIX handling */
12081                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12082                     e_len = 0;
12083                     *e_spec = '\0';
12084                 }
12085             }
12086
12087             if (!decc_efs_case_preserve) {
12088                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12089             }
12090
12091             if (hasdir) {
12092                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12093                 begin = rstr;
12094             }
12095             else {
12096                 /* Start with the name */
12097                 begin = n_spec;
12098             }
12099             strcat(begin,"\n");
12100             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12101         }
12102         if (cxt) (void)lib$find_file_end(&cxt);
12103
12104         if (!found) {
12105             /* Be POSIXish: return the input pattern when no matches */
12106             begin = SvPVX(tmpglob);
12107             strcat(begin,"\n");
12108             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12109         }
12110
12111         if (ok && sts != RMS$_NMF &&
12112             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12113         if (!ok) {
12114             if (!(sts & 1)) {
12115                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12116             }
12117             PerlIO_close(tmpfp);
12118             fp = NULL;
12119         }
12120         else {
12121             PerlIO_rewind(tmpfp);
12122             IoTYPE(io) = IoTYPE_RDONLY;
12123             IoIFP(io) = fp = tmpfp;
12124             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
12125         }
12126     }
12127     Safefree(vmsspec);
12128     Safefree(rslt);
12129     return fp;
12130 }
12131
12132
12133 #ifdef HAS_SYMLINK
12134 static char *
12135 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
12136
12137 void
12138 vms_realpath_fromperl(pTHX_ CV *cv)
12139 {
12140   dXSARGS;
12141   char *fspec, *rslt_spec, *rslt;
12142   STRLEN n_a;
12143
12144   if (!items || items != 1)
12145     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12146
12147   fspec = SvPV(ST(0),n_a);
12148   if (!fspec || !*fspec) XSRETURN_UNDEF;
12149
12150   Newx(rslt_spec, VMS_MAXRSS + 1, char);
12151   rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12152   ST(0) = sv_newmortal();
12153   if (rslt != NULL)
12154     sv_usepvn(ST(0),rslt,strlen(rslt));
12155   else
12156     Safefree(rslt_spec);
12157   XSRETURN(1);
12158 }
12159 #endif
12160
12161 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12162 int do_vms_case_tolerant(void);
12163
12164 void
12165 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12166 {
12167   dXSARGS;
12168   ST(0) = boolSV(do_vms_case_tolerant());
12169   XSRETURN(1);
12170 }
12171 #endif
12172
12173 void
12174 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12175                           struct interp_intern *dst)
12176 {
12177     memcpy(dst,src,sizeof(struct interp_intern));
12178 }
12179
12180 void
12181 Perl_sys_intern_clear(pTHX)
12182 {
12183 }
12184
12185 void
12186 Perl_sys_intern_init(pTHX)
12187 {
12188     unsigned int ix = RAND_MAX;
12189     double x;
12190
12191     VMSISH_HUSHED = 0;
12192
12193     /* fix me later to track running under GNV */
12194     /* this allows some limited testing */
12195     MY_POSIX_EXIT = decc_filename_unix_report;
12196
12197     x = (float)ix;
12198     MY_INV_RAND_MAX = 1./x;
12199 }
12200
12201 void
12202 init_os_extras(void)
12203 {
12204   dTHX;
12205   char* file = __FILE__;
12206   if (decc_disable_to_vms_logname_translation) {
12207     no_translate_barewords = TRUE;
12208   } else {
12209     no_translate_barewords = FALSE;
12210   }
12211
12212   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
12213   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
12214   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
12215   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
12216   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
12217   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
12218   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
12219   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
12220   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
12221   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
12222   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
12223 #ifdef HAS_SYMLINK
12224   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
12225 #endif
12226 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12227   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
12228 #endif
12229
12230   store_pipelocs(aTHX);         /* will redo any earlier attempts */
12231
12232   return;
12233 }
12234
12235 #ifdef HAS_SYMLINK
12236
12237 #if __CRTL_VER == 80200000
12238 /* This missed getting in to the DECC SDK for 8.2 */
12239 char *realpath(const char *file_name, char * resolved_name, ...);
12240 #endif
12241
12242 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
12243 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
12244  * The perl fallback routine to provide realpath() is not as efficient
12245  * on OpenVMS.
12246  */
12247 static char *
12248 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12249 {
12250     return realpath(filespec, outbuf);
12251 }
12252
12253 /*}}}*/
12254 /* External entry points */
12255 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12256 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
12257 #else
12258 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12259 { return NULL; }
12260 #endif
12261
12262
12263 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12264 /* case_tolerant */
12265
12266 /*{{{int do_vms_case_tolerant(void)*/
12267 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
12268  * controlled by a process setting.
12269  */
12270 int do_vms_case_tolerant(void)
12271 {
12272     return vms_process_case_tolerant;
12273 }
12274 /*}}}*/
12275 /* External entry points */
12276 int Perl_vms_case_tolerant(void)
12277 { return do_vms_case_tolerant(); }
12278 #else
12279 int Perl_vms_case_tolerant(void)
12280 { return vms_process_case_tolerant; }
12281 #endif
12282
12283
12284  /* Start of DECC RTL Feature handling */
12285
12286 static int sys_trnlnm
12287    (const char * logname,
12288     char * value,
12289     int value_len)
12290 {
12291     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
12292     const unsigned long attr = LNM$M_CASE_BLIND;
12293     struct dsc$descriptor_s name_dsc;
12294     int status;
12295     unsigned short result;
12296     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
12297                                 {0, 0, 0, 0}};
12298
12299     name_dsc.dsc$w_length = strlen(logname);
12300     name_dsc.dsc$a_pointer = (char *)logname;
12301     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12302     name_dsc.dsc$b_class = DSC$K_CLASS_S;
12303
12304     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
12305
12306     if ($VMS_STATUS_SUCCESS(status)) {
12307
12308          /* Null terminate and return the string */
12309         /*--------------------------------------*/
12310         value[result] = 0;
12311     }
12312
12313     return status;
12314 }
12315
12316 static int sys_crelnm
12317    (const char * logname,
12318     const char * value)
12319 {
12320     int ret_val;
12321     const char * proc_table = "LNM$PROCESS_TABLE";
12322     struct dsc$descriptor_s proc_table_dsc;
12323     struct dsc$descriptor_s logname_dsc;
12324     struct itmlst_3 item_list[2];
12325
12326     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
12327     proc_table_dsc.dsc$w_length = strlen(proc_table);
12328     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12329     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
12330
12331     logname_dsc.dsc$a_pointer = (char *) logname;
12332     logname_dsc.dsc$w_length = strlen(logname);
12333     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12334     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
12335
12336     item_list[0].buflen = strlen(value);
12337     item_list[0].itmcode = LNM$_STRING;
12338     item_list[0].bufadr = (char *)value;
12339     item_list[0].retlen = NULL;
12340
12341     item_list[1].buflen = 0;
12342     item_list[1].itmcode = 0;
12343
12344     ret_val = sys$crelnm
12345                        (NULL,
12346                         (const struct dsc$descriptor_s *)&proc_table_dsc,
12347                         (const struct dsc$descriptor_s *)&logname_dsc,
12348                         NULL,
12349                         (const struct item_list_3 *) item_list);
12350
12351     return ret_val;
12352 }
12353
12354 /* C RTL Feature settings */
12355
12356 static int set_features
12357    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
12358     int (* cli_routine)(void),  /* Not documented */
12359     void *image_info)           /* Not documented */
12360 {
12361     int status;
12362     int s;
12363     int dflt;
12364     char* str;
12365     char val_str[10];
12366 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12367     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12368     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12369     unsigned long case_perm;
12370     unsigned long case_image;
12371 #endif
12372
12373     /* Allow an exception to bring Perl into the VMS debugger */
12374     vms_debug_on_exception = 0;
12375     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12376     if ($VMS_STATUS_SUCCESS(status)) {
12377        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12378          vms_debug_on_exception = 1;
12379        else
12380          vms_debug_on_exception = 0;
12381     }
12382
12383     /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
12384     vms_vtf7_filenames = 0;
12385     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12386     if ($VMS_STATUS_SUCCESS(status)) {
12387        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12388          vms_vtf7_filenames = 1;
12389        else
12390          vms_vtf7_filenames = 0;
12391     }
12392
12393     /* Dectect running under GNV Bash or other UNIX like shell */
12394 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12395     gnv_unix_shell = 0;
12396     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12397     if ($VMS_STATUS_SUCCESS(status)) {
12398        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12399          gnv_unix_shell = 1;
12400          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12401          set_feature_default("DECC$EFS_CHARSET", 1);
12402          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12403          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12404          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12405          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12406        }
12407        else
12408          gnv_unix_shell = 0;
12409     }
12410 #endif
12411
12412     /* hacks to see if known bugs are still present for testing */
12413
12414     /* Readdir is returning filenames in VMS syntax always */
12415     decc_bug_readdir_efs1 = 1;
12416     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12417     if ($VMS_STATUS_SUCCESS(status)) {
12418        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12419          decc_bug_readdir_efs1 = 1;
12420        else
12421          decc_bug_readdir_efs1 = 0;
12422     }
12423
12424     /* PCP mode requires creating /dev/null special device file */
12425     decc_bug_devnull = 0;
12426     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12427     if ($VMS_STATUS_SUCCESS(status)) {
12428        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12429           decc_bug_devnull = 1;
12430        else
12431           decc_bug_devnull = 0;
12432     }
12433
12434     /* fgetname returning a VMS name in UNIX mode */
12435     decc_bug_fgetname = 1;
12436     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12437     if ($VMS_STATUS_SUCCESS(status)) {
12438       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12439         decc_bug_fgetname = 1;
12440       else
12441         decc_bug_fgetname = 0;
12442     }
12443
12444     /* UNIX directory names with no paths are broken in a lot of places */
12445     decc_dir_barename = 1;
12446     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12447     if ($VMS_STATUS_SUCCESS(status)) {
12448       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12449         decc_dir_barename = 1;
12450       else
12451         decc_dir_barename = 0;
12452     }
12453
12454 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12455     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12456     if (s >= 0) {
12457         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12458         if (decc_disable_to_vms_logname_translation < 0)
12459             decc_disable_to_vms_logname_translation = 0;
12460     }
12461
12462     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12463     if (s >= 0) {
12464         decc_efs_case_preserve = decc$feature_get_value(s, 1);
12465         if (decc_efs_case_preserve < 0)
12466             decc_efs_case_preserve = 0;
12467     }
12468
12469     s = decc$feature_get_index("DECC$EFS_CHARSET");
12470     if (s >= 0) {
12471         decc_efs_charset = decc$feature_get_value(s, 1);
12472         if (decc_efs_charset < 0)
12473             decc_efs_charset = 0;
12474     }
12475
12476     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12477     if (s >= 0) {
12478         decc_filename_unix_report = decc$feature_get_value(s, 1);
12479         if (decc_filename_unix_report > 0)
12480             decc_filename_unix_report = 1;
12481         else
12482             decc_filename_unix_report = 0;
12483     }
12484
12485     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12486     if (s >= 0) {
12487         decc_filename_unix_only = decc$feature_get_value(s, 1);
12488         if (decc_filename_unix_only > 0) {
12489             decc_filename_unix_only = 1;
12490         }
12491         else {
12492             decc_filename_unix_only = 0;
12493         }
12494     }
12495
12496     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12497     if (s >= 0) {
12498         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12499         if (decc_filename_unix_no_version < 0)
12500             decc_filename_unix_no_version = 0;
12501     }
12502
12503     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12504     if (s >= 0) {
12505         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12506         if (decc_readdir_dropdotnotype < 0)
12507             decc_readdir_dropdotnotype = 0;
12508     }
12509
12510     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12511     if ($VMS_STATUS_SUCCESS(status)) {
12512         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12513         if (s >= 0) {
12514             dflt = decc$feature_get_value(s, 4);
12515             if (dflt > 0) {
12516                 decc_disable_posix_root = decc$feature_get_value(s, 1);
12517                 if (decc_disable_posix_root <= 0) {
12518                     decc$feature_set_value(s, 1, 1);
12519                     decc_disable_posix_root = 1;
12520                 }
12521             }
12522             else {
12523                 /* Traditionally Perl assumes this is off */
12524                 decc_disable_posix_root = 1;
12525                 decc$feature_set_value(s, 1, 1);
12526             }
12527         }
12528     }
12529
12530 #if __CRTL_VER >= 80200000
12531     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12532     if (s >= 0) {
12533         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12534         if (decc_posix_compliant_pathnames < 0)
12535             decc_posix_compliant_pathnames = 0;
12536         if (decc_posix_compliant_pathnames > 4)
12537             decc_posix_compliant_pathnames = 0;
12538     }
12539
12540 #endif
12541 #else
12542     status = sys_trnlnm
12543         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12544     if ($VMS_STATUS_SUCCESS(status)) {
12545         val_str[0] = _toupper(val_str[0]);
12546         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12547            decc_disable_to_vms_logname_translation = 1;
12548         }
12549     }
12550
12551 #ifndef __VAX
12552     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12553     if ($VMS_STATUS_SUCCESS(status)) {
12554         val_str[0] = _toupper(val_str[0]);
12555         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12556            decc_efs_case_preserve = 1;
12557         }
12558     }
12559 #endif
12560
12561     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12562     if ($VMS_STATUS_SUCCESS(status)) {
12563         val_str[0] = _toupper(val_str[0]);
12564         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12565            decc_filename_unix_report = 1;
12566         }
12567     }
12568     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12569     if ($VMS_STATUS_SUCCESS(status)) {
12570         val_str[0] = _toupper(val_str[0]);
12571         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12572            decc_filename_unix_only = 1;
12573            decc_filename_unix_report = 1;
12574         }
12575     }
12576     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12577     if ($VMS_STATUS_SUCCESS(status)) {
12578         val_str[0] = _toupper(val_str[0]);
12579         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12580            decc_filename_unix_no_version = 1;
12581         }
12582     }
12583     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12584     if ($VMS_STATUS_SUCCESS(status)) {
12585         val_str[0] = _toupper(val_str[0]);
12586         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12587            decc_readdir_dropdotnotype = 1;
12588         }
12589     }
12590 #endif
12591
12592 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12593
12594      /* Report true case tolerance */
12595     /*----------------------------*/
12596     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12597     if (!$VMS_STATUS_SUCCESS(status))
12598         case_perm = PPROP$K_CASE_BLIND;
12599     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12600     if (!$VMS_STATUS_SUCCESS(status))
12601         case_image = PPROP$K_CASE_BLIND;
12602     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12603         (case_image == PPROP$K_CASE_SENSITIVE))
12604         vms_process_case_tolerant = 0;
12605
12606 #endif
12607
12608
12609     /* CRTL can be initialized past this point, but not before. */
12610 /*    DECC$CRTL_INIT(); */
12611
12612     return SS$_NORMAL;
12613 }
12614
12615 #ifdef __DECC
12616 #pragma nostandard
12617 #pragma extern_model save
12618 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12619         const __align (LONGWORD) int spare[8] = {0};
12620
12621 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
12622 #if __DECC_VER >= 60560002
12623 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
12624 #else
12625 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
12626 #endif
12627 #endif /* __DECC */
12628
12629 const long vms_cc_features = (const long)set_features;
12630
12631 /*
12632 ** Force a reference to LIB$INITIALIZE to ensure it
12633 ** exists in the image.
12634 */
12635 int lib$initialize(void);
12636 #ifdef __DECC
12637 #pragma extern_model strict_refdef
12638 #endif
12639     int lib_init_ref = (int) lib$initialize;
12640
12641 #ifdef __DECC
12642 #pragma extern_model restore
12643 #pragma standard
12644 #endif
12645
12646 /*  End of vms.c */