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