vms/vms.c

   1 /* vms.c
   2  *
   3  * VMS-specific routines for perl5
   4  * Version: 5.7.0
   5  *
   6  * August 2005 Convert VMS status code to UNIX status codes
   7  * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
   8  *             and Perl_cando by Craig Berry
   9  * 29-Aug-2000 Charles Lane's piping improvements rolled in
  10  * 20-Aug-1999 revisions by Charles Bailey  bailey@newman.upenn.edu
  11  */
  12
  13 #include <acedef.h>
  14 #include <acldef.h>
  15 #include <armdef.h>
  16 #include <atrdef.h>
  17 #include <chpdef.h>
  18 #include <clidef.h>
  19 #include <climsgdef.h>
  20 #include <dcdef.h>
  21 #include <descrip.h>
  22 #include <devdef.h>
  23 #include <dvidef.h>
  24 #include <fibdef.h>
  25 #include <float.h>
  26 #include <fscndef.h>
  27 #include <iodef.h>
  28 #include <jpidef.h>
  29 #include <kgbdef.h>
  30 #include <libclidef.h>
  31 #include <libdef.h>
  32 #include <lib$routines.h>
  33 #include <lnmdef.h>
  34 #include <msgdef.h>
  35 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  36 #include <ppropdef.h>
  37 #endif
  38 #include <prvdef.h>
  39 #include <psldef.h>
  40 #include <rms.h>
  41 #include <shrdef.h>
  42 #include <ssdef.h>
  43 #include <starlet.h>
  44 #include <strdef.h>
  45 #include <str$routines.h>
  46 #include <syidef.h>
  47 #include <uaidef.h>
  48 #include <uicdef.h>
  49 #include <stsdef.h>
  50 #include <rmsdef.h>
  51 #include <smgdef.h>
  52 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
  53 #include <efndef.h>
  54 #define NO_EFN EFN$C_ENF
  55 #else
  56 #define NO_EFN 0;
  57 #endif
  58
  59 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  60 int   decc$feature_get_index(const char *name);
  61 char* decc$feature_get_name(int index);
  62 int   decc$feature_get_value(int index, int mode);
  63 int   decc$feature_set_value(int index, int mode, int value);
  64 #else
  65 #include <unixlib.h>
  66 #endif
  67
  68 #pragma member_alignment save
  69 #pragma nomember_alignment longword
  70 struct item_list_3 {
  71         unsigned short len;
  72         unsigned short code;
  73         void * bufadr;
  74         unsigned short * retadr;
  75 };
  76 #pragma member_alignment restore
  77
  78 /* More specific prototype than in starlet_c.h makes programming errors
  79    more visible.
  80  */
  81 #ifdef sys$getdviw
  82 #undef sys$getdviw
  83 int sys$getdviw
  84        (unsigned long efn,
  85         unsigned short chan,
  86         const struct dsc$descriptor_s * devnam,
  87         const struct item_list_3 * itmlst,
  88         void * iosb,
  89         void * (astadr)(unsigned long),
  90         void * astprm,
  91         void * nullarg);
  92 #endif
  93
  94 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  95
  96 static int set_feature_default(const char *name, int value)
  97 {
  98     int status;
  99     int index;
 100
 101     index = decc$feature_get_index(name);
 102
 103     status = decc$feature_set_value(index, 1, value);
 104     if (index == -1 || (status == -1)) {
 105       return -1;
 106     }
 107
 108     status = decc$feature_get_value(index, 1);
 109     if (status != value) {
 110       return -1;
 111     }
 112
 113 return 0;
 114 }
 115 #endif
 116
 117 /* Older versions of ssdef.h don't have these */
 118 #ifndef SS$_INVFILFOROP
 119 #  define SS$_INVFILFOROP 3930
 120 #endif
 121 #ifndef SS$_NOSUCHOBJECT
 122 #  define SS$_NOSUCHOBJECT 2696
 123 #endif
 124
 125 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 126 #define PERLIO_NOT_STDIO 0
 127
 128 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 129  * code below needs to get to the underlying CRTL routines. */
 130 #define DONT_MASK_RTL_CALLS
 131 #include "EXTERN.h"
 132 #include "perl.h"
 133 #include "XSUB.h"
 134 /* Anticipating future expansion in lexical warnings . . . */
 135 #ifndef WARN_INTERNAL
 136 #  define WARN_INTERNAL WARN_MISC
 137 #endif
 138
 139 #ifdef VMS_LONGNAME_SUPPORT
 140 #include <libfildef.h>
 141 #endif
 142
 143 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 144 #  define RTL_USES_UTC 1
 145 #endif
 146
 147 #ifdef USE_VMS_DECTERM
 148
 149 /* Routine to create a decterm for use with the Perl debugger */
 150 /* No headers, this information was found in the Programming Concepts Manual */
 151
 152 int decw$term_port
 153    (const struct dsc$descriptor_s * display,
 154     const struct dsc$descriptor_s * setup_file,
 155     const struct dsc$descriptor_s * customization,
 156     struct dsc$descriptor_s * result_device_name,
 157     unsigned short * result_device_name_length,
 158     void * controller,
 159     void * char_buffer,
 160     void * char_change_buffer);
 161 #endif
 162
 163 /* gcc's header files don't #define direct access macros
 164  * corresponding to VAXC's variant structs */
 165 #ifdef __GNUC__
 166 #  define uic$v_format uic$r_uic_form.uic$v_format
 167 #  define uic$v_group uic$r_uic_form.uic$v_group
 168 #  define uic$v_member uic$r_uic_form.uic$v_member
 169 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 170 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 171 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 172 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 173 #endif
 174
 175 #if defined(NEED_AN_H_ERRNO)
 176 dEXT int h_errno;
 177 #endif
 178
 179 #ifdef __DECC
 180 #pragma message disable pragma
 181 #pragma member_alignment save
 182 #pragma nomember_alignment longword
 183 #pragma message save
 184 #pragma message disable misalgndmem
 185 #endif
 186 struct itmlst_3 {
 187   unsigned short int buflen;
 188   unsigned short int itmcode;
 189   void *bufadr;
 190   unsigned short int *retlen;
 191 };
 192
 193 struct filescan_itmlst_2 {
 194     unsigned short length;
 195     unsigned short itmcode;
 196     char * component;
 197 };
 198
 199 struct vs_str_st {
 200     unsigned short length;
 201     char str[65536];
 202 };
 203
 204 #ifdef __DECC
 205 #pragma message restore
 206 #pragma member_alignment restore
 207 #endif
 208
 209 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 210 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 211 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 212 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 213 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 214 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 215 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 216 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 217 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 218 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 219 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 220
 221 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 222 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 223 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 224 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 225
 226 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 227 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 228
 229 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 230  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 231  * the Perl facility.
 232  */
 233 #define PERL_LNM_MAX_ITER 10
 234
 235   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 236 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 237 #define MAX_DCL_SYMBOL          (8192)
 238 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 239 #else
 240 #define MAX_DCL_SYMBOL          (1024)
 241 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 242 #endif
 243
 244 static char *__mystrtolower(char *str)
 245 {
 246   if (str) for (; *str; ++str) *str= tolower(*str);
 247   return str;
 248 }
 249
 250 static struct dsc$descriptor_s fildevdsc =
 251   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 252 static struct dsc$descriptor_s crtlenvdsc =
 253   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 254 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 255 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 256 static struct dsc$descriptor_s **env_tables = defenv;
 257 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 258
 259 /* True if we shouldn't treat barewords as logicals during directory */
 260 /* munching */
 261 static int no_translate_barewords;
 262
 263 #ifndef RTL_USES_UTC
 264 static int tz_updated = 1;
 265 #endif
 266
 267 /* DECC Features that may need to affect how Perl interprets
 268  * displays filename information
 269  */
 270 static int decc_disable_to_vms_logname_translation = 1;
 271 static int decc_disable_posix_root = 1;
 272 int decc_efs_case_preserve = 0;
 273 static int decc_efs_charset = 0;
 274 static int decc_filename_unix_no_version = 0;
 275 static int decc_filename_unix_only = 0;
 276 int decc_filename_unix_report = 0;
 277 int decc_posix_compliant_pathnames = 0;
 278 int decc_readdir_dropdotnotype = 0;
 279 static int vms_process_case_tolerant = 1;
 280 int vms_vtf7_filenames = 0;
 281 int gnv_unix_shell = 0;
 282
 283 /* bug workarounds if needed */
 284 int decc_bug_readdir_efs1 = 0;
 285 int decc_bug_devnull = 1;
 286 int decc_bug_fgetname = 0;
 287 int decc_dir_barename = 0;
 288
 289 static int vms_debug_on_exception = 0;
 290
 291 /* Is this a UNIX file specification?
 292  *   No longer a simple check with EFS file specs
 293  *   For now, not a full check, but need to
 294  *   handle POSIX ^UP^ specifications
 295  *   Fixing to handle ^/ cases would require
 296  *   changes to many other conversion routines.
 297  */
 298
 299 static int is_unix_filespec(const char *path)
 300 {
 301 int ret_val;
 302 const char * pch1;
 303
 304     ret_val = 0;
 305     if (strncmp(path,"\"^UP^",5) != 0) {
 306         pch1 = strchr(path, '/');
 307         if (pch1 != NULL)
 308             ret_val = 1;
 309         else {
 310
 311             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 312             if (decc_filename_unix_report || decc_filename_unix_only) {
 313             if (strcmp(path,".") == 0)
 314                 ret_val = 1;
 315             }
 316         }
 317     }
 318     return ret_val;
 319 }
 320
 321 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 322  */
 323
 324 static void ucs2_to_vtf7
 325    (char *outspec,
 326     unsigned long ucs2_char,
 327     int * output_cnt)
 328 {
 329 unsigned char * ucs_ptr;
 330 int hex;
 331
 332     ucs_ptr = (unsigned char *)&ucs2_char;
 333
 334     outspec[0] = '^';
 335     outspec[1] = 'U';
 336     hex = (ucs_ptr[1] >> 4) & 0xf;
 337     if (hex < 0xA)
 338         outspec[2] = hex + '0';
 339     else
 340         outspec[2] = (hex - 9) + 'A';
 341     hex = ucs_ptr[1] & 0xF;
 342     if (hex < 0xA)
 343         outspec[3] = hex + '0';
 344     else {
 345         outspec[3] = (hex - 9) + 'A';
 346     }
 347     hex = (ucs_ptr[0] >> 4) & 0xf;
 348     if (hex < 0xA)
 349         outspec[4] = hex + '0';
 350     else
 351         outspec[4] = (hex - 9) + 'A';
 352     hex = ucs_ptr[1] & 0xF;
 353     if (hex < 0xA)
 354         outspec[5] = hex + '0';
 355     else {
 356         outspec[5] = (hex - 9) + 'A';
 357     }
 358     *output_cnt = 6;
 359 }
 360
 361
 362 /* This handles the conversion of a UNIX extended character set to a ^
 363  * escaped VMS character.
 364  * in a UNIX file specification.
 365  *
 366  * The output count variable contains the number of characters added
 367  * to the output string.
 368  *
 369  * The return value is the number of characters read from the input string
 370  */
 371 static int copy_expand_unix_filename_escape
 372   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 373 {
 374 int count;
 375 int scnt;
 376 int utf8_flag;
 377
 378     utf8_flag = 0;
 379     if (utf8_fl)
 380       utf8_flag = *utf8_fl;
 381
 382     count = 0;
 383     *output_cnt = 0;
 384     if (*inspec >= 0x80) {
 385         if (utf8_fl && vms_vtf7_filenames) {
 386         unsigned long ucs_char;
 387
 388             ucs_char = 0;
 389
 390             if ((*inspec & 0xE0) == 0xC0) {
 391                 /* 2 byte Unicode */
 392                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 393                 if (ucs_char >= 0x80) {
 394                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 395                     return 2;
 396                 }
 397             } else if ((*inspec & 0xF0) == 0xE0) {
 398                 /* 3 byte Unicode */
 399                 ucs_char = ((inspec[0] & 0xF) << 12) +
 400                    ((inspec[1] & 0x3f) << 6) +
 401                    (inspec[2] & 0x3f);
 402                 if (ucs_char >= 0x800) {
 403                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 404                     return 3;
 405                 }
 406
 407 #if 0 /* I do not see longer sequences supported by OpenVMS */
 408       /* Maybe some one can fix this later */
 409             } else if ((*inspec & 0xF8) == 0xF0) {
 410                 /* 4 byte Unicode */
 411                 /* UCS-4 to UCS-2 */
 412             } else if ((*inspec & 0xFC) == 0xF8) {
 413                 /* 5 byte Unicode */
 414                 /* UCS-4 to UCS-2 */
 415             } else if ((*inspec & 0xFE) == 0xFC) {
 416                 /* 6 byte Unicode */
 417                 /* UCS-4 to UCS-2 */
 418 #endif
 419             }
 420         }
 421
 422         /* High bit set, but not a unicode character! */
 423
 424         /* Non printing DECMCS or ISO Latin-1 character? */
 425         if (*inspec <= 0x9F) {
 426         int hex;
 427             outspec[0] = '^';
 428             outspec++;
 429             hex = (*inspec >> 4) & 0xF;
 430             if (hex < 0xA)
 431                 outspec[1] = hex + '0';
 432             else {
 433                 outspec[1] = (hex - 9) + 'A';
 434             }
 435             hex = *inspec & 0xF;
 436             if (hex < 0xA)
 437                 outspec[2] = hex + '0';
 438             else {
 439                 outspec[2] = (hex - 9) + 'A';
 440             }
 441             *output_cnt = 3;
 442             return 1;
 443         } else if (*inspec == 0xA0) {
 444             outspec[0] = '^';
 445             outspec[1] = 'A';
 446             outspec[2] = '0';
 447             *output_cnt = 3;
 448             return 1;
 449         } else if (*inspec == 0xFF) {
 450             outspec[0] = '^';
 451             outspec[1] = 'F';
 452             outspec[2] = 'F';
 453             *output_cnt = 3;
 454             return 1;
 455         }
 456         *outspec = *inspec;
 457         *output_cnt = 1;
 458         return 1;
 459     }
 460
 461     /* Is this a macro that needs to be passed through?
 462      * Macros start with $( and an alpha character, followed
 463      * by a string of alpha numeric characters ending with a )
 464      * If this does not match, then encode it as ODS-5.
 465      */
 466     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 467     int tcnt;
 468
 469         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 470             tcnt = 3;
 471             outspec[0] = inspec[0];
 472             outspec[1] = inspec[1];
 473             outspec[2] = inspec[2];
 474
 475             while(isalnum(inspec[tcnt]) ||
 476                   (inspec[2] == '.') || (inspec[2] == '_')) {
 477                 outspec[tcnt] = inspec[tcnt];
 478                 tcnt++;
 479             }
 480             if (inspec[tcnt] == ')') {
 481                 outspec[tcnt] = inspec[tcnt];
 482                 tcnt++;
 483                 *output_cnt = tcnt;
 484                 return tcnt;
 485             }
 486         }
 487     }
 488
 489     switch (*inspec) {
 490     case 0x7f:
 491         outspec[0] = '^';
 492         outspec[1] = '7';
 493         outspec[2] = 'F';
 494         *output_cnt = 3;
 495         return 1;
 496         break;
 497     case '?':
 498         if (decc_efs_charset == 0)
 499           outspec[0] = '%';
 500         else
 501           outspec[0] = '?';
 502         *output_cnt = 1;
 503         return 1;
 504         break;
 505     case '.':
 506     case '~':
 507     case '!':
 508     case '#':
 509     case '&':
 510     case '\'':
 511     case '`':
 512     case '(':
 513     case ')':
 514     case '+':
 515     case '@':
 516     case '{':
 517     case '}':
 518     case ',':
 519     case ';':
 520     case '[':
 521     case ']':
 522     case '%':
 523     case '^':
 524     case '=':
 525         /* Assume that this is to be escaped */
 526         outspec[0] = '^';
 527         outspec[1] = *inspec;
 528         *output_cnt = 2;
 529         return 1;
 530         break;
 531     case ' ': /* space */
 532         /* Assume that this is to be escaped */
 533         outspec[0] = '^';
 534         outspec[1] = '_';
 535         *output_cnt = 2;
 536         return 1;
 537         break;
 538     default:
 539         *outspec = *inspec;
 540         *output_cnt = 1;
 541         return 1;
 542         break;
 543     }
 544 }
 545
 546
 547 /* This handles the expansion of a '^' prefix to the proper character
 548  * in a UNIX file specification.
 549  *
 550  * The output count variable contains the number of characters added
 551  * to the output string.
 552  *
 553  * The return value is the number of characters read from the input
 554  * string
 555  */
 556 static int copy_expand_vms_filename_escape
 557   (char *outspec, const char *inspec, int *output_cnt)
 558 {
 559 int count;
 560 int scnt;
 561
 562     count = 0;
 563     *output_cnt = 0;
 564     if (*inspec == '^') {
 565         inspec++;
 566         switch (*inspec) {
 567         case '.':
 568             /* Non trailing dots should just be passed through, but eat the escape */
 569             *outspec = *inspec;
 570             count++;
 571             break;
 572         case '_': /* space */
 573             *outspec = ' ';
 574             inspec++;
 575             count++;
 576             (*output_cnt)++;
 577             break;
 578         case 'U': /* Unicode - FIX-ME this is wrong. */
 579             inspec++;
 580             count++;
 581             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 582             if (scnt == 4) {
 583                 unsigned int c1, c2;
 584                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 585                 outspec[0] == c1 & 0xff;
 586                 outspec[1] == c2 & 0xff;
 587                 if (scnt > 1) {
 588                     (*output_cnt) += 2;
 589                     count += 4;
 590                 }
 591             }
 592             else {
 593                 /* Error - do best we can to continue */
 594                 *outspec = 'U';
 595                 outspec++;
 596                 (*output_cnt++);
 597                 *outspec = *inspec;
 598                 count++;
 599                 (*output_cnt++);
 600             }
 601             break;
 602         default:
 603             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 604             if (scnt == 2) {
 605                 /* Hex encoded */
 606                 unsigned int c1;
 607                 scnt = sscanf(inspec, "%2x", &c1);
 608                 outspec[0] = c1 & 0xff;
 609                 if (scnt > 0) {
 610                     (*output_cnt++);
 611                     count += 2;
 612                 }
 613             }
 614             else {
 615                 *outspec = *inspec;
 616                 count++;
 617                 (*output_cnt++);
 618             }
 619         }
 620     }
 621     else {
 622         *outspec = *inspec;
 623         count++;
 624         (*output_cnt)++;
 625     }
 626     return count;
 627 }
 628
 629 #ifdef sys$filescan
 630 #undef sys$filescan
 631 int sys$filescan
 632    (const struct dsc$descriptor_s * srcstr,
 633     struct filescan_itmlst_2 * valuelist,
 634     unsigned long * fldflags,
 635     struct dsc$descriptor_s *auxout,
 636     unsigned short * retlen);
 637 #endif
 638
 639 /* vms_split_path - Verify that the input file specification is a
 640  * VMS format file specification, and provide pointers to the components of
 641  * it.  With EFS format filenames, this is virtually the only way to
 642  * parse a VMS path specification into components.
 643  *
 644  * If the sum of the components do not add up to the length of the
 645  * string, then the passed file specification is probably a UNIX style
 646  * path.
 647  */
 648 static int vms_split_path
 649    (const char * path,
 650     char * * volume,
 651     int * vol_len,
 652     char * * root,
 653     int * root_len,
 654     char * * dir,
 655     int * dir_len,
 656     char * * name,
 657     int * name_len,
 658     char * * ext,
 659     int * ext_len,
 660     char * * version,
 661     int * ver_len)
 662 {
 663 struct dsc$descriptor path_desc;
 664 int status;
 665 unsigned long flags;
 666 int ret_stat;
 667 struct filescan_itmlst_2 item_list[9];
 668 const int filespec = 0;
 669 const int nodespec = 1;
 670 const int devspec = 2;
 671 const int rootspec = 3;
 672 const int dirspec = 4;
 673 const int namespec = 5;
 674 const int typespec = 6;
 675 const int verspec = 7;
 676
 677     /* Assume the worst for an easy exit */
 678     ret_stat = -1;
 679     *volume = NULL;
 680     *vol_len = 0;
 681     *root = NULL;
 682     *root_len = 0;
 683     *dir = NULL;
 684     *dir_len;
 685     *name = NULL;
 686     *name_len = 0;
 687     *ext = NULL;
 688     *ext_len = 0;
 689     *version = NULL;
 690     *ver_len = 0;
 691
 692     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 693     path_desc.dsc$w_length = strlen(path);
 694     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 695     path_desc.dsc$b_class = DSC$K_CLASS_S;
 696
 697     /* Get the total length, if it is shorter than the string passed
 698      * then this was probably not a VMS formatted file specification
 699      */
 700     item_list[filespec].itmcode = FSCN$_FILESPEC;
 701     item_list[filespec].length = 0;
 702     item_list[filespec].component = NULL;
 703
 704     /* If the node is present, then it gets considered as part of the
 705      * volume name to hopefully make things simple.
 706      */
 707     item_list[nodespec].itmcode = FSCN$_NODE;
 708     item_list[nodespec].length = 0;
 709     item_list[nodespec].component = NULL;
 710
 711     item_list[devspec].itmcode = FSCN$_DEVICE;
 712     item_list[devspec].length = 0;
 713     item_list[devspec].component = NULL;
 714
 715     /* root is a special case,  adding it to either the directory or
 716      * the device components will probalby complicate things for the
 717      * callers of this routine, so leave it separate.
 718      */
 719     item_list[rootspec].itmcode = FSCN$_ROOT;
 720     item_list[rootspec].length = 0;
 721     item_list[rootspec].component = NULL;
 722
 723     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 724     item_list[dirspec].length = 0;
 725     item_list[dirspec].component = NULL;
 726
 727     item_list[namespec].itmcode = FSCN$_NAME;
 728     item_list[namespec].length = 0;
 729     item_list[namespec].component = NULL;
 730
 731     item_list[typespec].itmcode = FSCN$_TYPE;
 732     item_list[typespec].length = 0;
 733     item_list[typespec].component = NULL;
 734
 735     item_list[verspec].itmcode = FSCN$_VERSION;
 736     item_list[verspec].length = 0;
 737     item_list[verspec].component = NULL;
 738
 739     item_list[8].itmcode = 0;
 740     item_list[8].length = 0;
 741     item_list[8].component = NULL;
 742
 743     status = sys$filescan
 744        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 745         &flags, NULL, NULL);
 746     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 747
 748     /* If we parsed it successfully these two lengths should be the same */
 749     if (path_desc.dsc$w_length != item_list[filespec].length)
 750         return ret_stat;
 751
 752     /* If we got here, then it is a VMS file specification */
 753     ret_stat = 0;
 754
 755     /* set the volume name */
 756     if (item_list[nodespec].length > 0) {
 757         *volume = item_list[nodespec].component;
 758         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 759     }
 760     else {
 761         *volume = item_list[devspec].component;
 762         *vol_len = item_list[devspec].length;
 763     }
 764
 765     *root = item_list[rootspec].component;
 766     *root_len = item_list[rootspec].length;
 767
 768     *dir = item_list[dirspec].component;
 769     *dir_len = item_list[dirspec].length;
 770
 771     /* Now fun with versions and EFS file specifications
 772      * The parser can not tell the difference when a "." is a version
 773      * delimiter or a part of the file specification.
 774      */
 775     if ((decc_efs_charset) &&
 776         (item_list[verspec].length > 0) &&
 777         (item_list[verspec].component[0] == '.')) {
 778         *name = item_list[namespec].component;
 779         *name_len = item_list[namespec].length + item_list[typespec].length;
 780         *ext = item_list[verspec].component;
 781         *ext_len = item_list[verspec].length;
 782         *version = NULL;
 783         *ver_len = 0;
 784     }
 785     else {
 786         *name = item_list[namespec].component;
 787         *name_len = item_list[namespec].length;
 788         *ext = item_list[typespec].component;
 789         *ext_len = item_list[typespec].length;
 790         *version = item_list[verspec].component;
 791         *ver_len = item_list[verspec].length;
 792     }
 793     return ret_stat;
 794 }
 795
 796
 797 /* my_maxidx
 798  * Routine to retrieve the maximum equivalence index for an input
 799  * logical name.  Some calls to this routine have no knowledge if
 800  * the variable is a logical or not.  So on error we return a max
 801  * index of zero.
 802  */
 803 /*{{{int my_maxidx(const char *lnm) */
 804 static int
 805 my_maxidx(const char *lnm)
 806 {
 807     int status;
 808     int midx;
 809     int attr = LNM$M_CASE_BLIND;
 810     struct dsc$descriptor lnmdsc;
 811     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 812                                 {0, 0, 0, 0}};
 813
 814     lnmdsc.dsc$w_length = strlen(lnm);
 815     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 816     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 817     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 818
 819     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 820     if ((status & 1) == 0)
 821        midx = 0;
 822
 823     return (midx);
 824 }
 825 /*}}}*/
 826
 827 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 828 int
 829 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 830   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 831 {
 832     const char *cp1;
 833     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 834     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 835     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 836     int midx;
 837     unsigned char acmode;
 838     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 839                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 840     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 841                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 842                                  {0, 0, 0, 0}};
 843     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 844 #if defined(PERL_IMPLICIT_CONTEXT)
 845     pTHX = NULL;
 846     if (PL_curinterp) {
 847       aTHX = PERL_GET_INTERP;
 848     } else {
 849       aTHX = NULL;
 850     }
 851 #endif
 852
 853     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 854       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 855     }
 856     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 857       *cp2 = _toupper(*cp1);
 858       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 859         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 860         return 0;
 861       }
 862     }
 863     lnmdsc.dsc$w_length = cp1 - lnm;
 864     lnmdsc.dsc$a_pointer = uplnm;
 865     uplnm[lnmdsc.dsc$w_length] = '\0';
 866     secure = flags & PERL__TRNENV_SECURE;
 867     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 868     if (!tabvec || !*tabvec) tabvec = env_tables;
 869
 870     for (curtab = 0; tabvec[curtab]; curtab++) {
 871       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 872         if (!ivenv && !secure) {
 873           char *eq, *end;
 874           int i;
 875           if (!environ) {
 876             ivenv = 1;
 877             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 878             continue;
 879           }
 880           retsts = SS$_NOLOGNAM;
 881           for (i = 0; environ[i]; i++) {
 882             if ((eq = strchr(environ[i],'=')) &&
 883                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 884                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 885               eq++;
 886               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 887               if (!eqvlen) continue;
 888               retsts = SS$_NORMAL;
 889               break;
 890             }
 891           }
 892           if (retsts != SS$_NOLOGNAM) break;
 893         }
 894       }
 895       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 896                !str$case_blind_compare(&tmpdsc,&clisym)) {
 897         if (!ivsym && !secure) {
 898           unsigned short int deflen = LNM$C_NAMLENGTH;
 899           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 900           /* dynamic dsc to accomodate possible long value */
 901           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 902           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 903           if (retsts & 1) {
 904             if (eqvlen > MAX_DCL_SYMBOL) {
 905               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 906               eqvlen = MAX_DCL_SYMBOL;
 907               /* Special hack--we might be called before the interpreter's */
 908               /* fully initialized, in which case either thr or PL_curcop */
 909               /* might be bogus. We have to check, since ckWARN needs them */
 910               /* both to be valid if running threaded */
 911                 if (ckWARN(WARN_MISC)) {
 912                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 913                 }
 914             }
 915             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 916           }
 917           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 918           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 919           if (retsts == LIB$_NOSUCHSYM) continue;
 920           break;
 921         }
 922       }
 923       else if (!ivlnm) {
 924         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 925           midx = my_maxidx(lnm);
 926           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 927             lnmlst[1].bufadr = cp2;
 928             eqvlen = 0;
 929             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 930             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 931             if (retsts == SS$_NOLOGNAM) break;
 932             /* PPFs have a prefix */
 933             if (
 934 #if INTSIZE == 4
 935                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 936 #endif
 937                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 938                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 939                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 940                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 941                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 942               memmove(eqv,eqv+4,eqvlen-4);
 943               eqvlen -= 4;
 944             }
 945             cp2 += eqvlen;
 946             *cp2 = '\0';
 947           }
 948           if ((retsts == SS$_IVLOGNAM) ||
 949               (retsts == SS$_NOLOGNAM)) { continue; }
 950         }
 951         else {
 952           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 953           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 954           if (retsts == SS$_NOLOGNAM) continue;
 955           eqv[eqvlen] = '\0';
 956         }
 957         eqvlen = strlen(eqv);
 958         break;
 959       }
 960     }
 961     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 962     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 963              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 964              retsts == SS$_NOLOGNAM) {
 965       set_errno(EINVAL);  set_vaxc_errno(retsts);
 966     }
 967     else _ckvmssts(retsts);
 968     return 0;
 969 }  /* end of vmstrnenv */
 970 /*}}}*/
 971
 972 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 973 /* Define as a function so we can access statics. */
 974 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 975 {
 976   return vmstrnenv(lnm,eqv,idx,fildev,
 977 #ifdef SECURE_INTERNAL_GETENV
 978                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 979 #else
 980                    0
 981 #endif
 982                                                                               );
 983 }
 984 /*}}}*/
 985
 986 /* my_getenv
 987  * Note: Uses Perl temp to store result so char * can be returned to
 988  * caller; this pointer will be invalidated at next Perl statement
 989  * transition.
 990  * We define this as a function rather than a macro in terms of my_getenv_len()
 991  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 992  * allocate SVs).
 993  */
 994 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 995 char *
 996 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 997 {
 998     const char *cp1;
 999     static char *__my_getenv_eqv = NULL;
1000     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1001     unsigned long int idx = 0;
1002     int trnsuccess, success, secure, saverr, savvmserr;
1003     int midx, flags;
1004     SV *tmpsv;
1005
1006     midx = my_maxidx(lnm) + 1;
1007
1008     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1009       /* Set up a temporary buffer for the return value; Perl will
1010        * clean it up at the next statement transition */
1011       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1012       if (!tmpsv) return NULL;
1013       eqv = SvPVX(tmpsv);
1014     }
1015     else {
1016       /* Assume no interpreter ==> single thread */
1017       if (__my_getenv_eqv != NULL) {
1018         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1019       }
1020       else {
1021         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1022       }
1023       eqv = __my_getenv_eqv;
1024     }
1025
1026     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1027     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1028       int len;
1029       getcwd(eqv,LNM$C_NAMLENGTH);
1030
1031       len = strlen(eqv);
1032
1033       /* Get rid of "000000/ in rooted filespecs */
1034       if (len > 7) {
1035         char * zeros;
1036         zeros = strstr(eqv, "/000000/");
1037         if (zeros != NULL) {
1038           int mlen;
1039           mlen = len - (zeros - eqv) - 7;
1040           memmove(zeros, &zeros[7], mlen);
1041           len = len - 7;
1042           eqv[len] = '\0';
1043         }
1044       }
1045       return eqv;
1046     }
1047     else {
1048       /* Impose security constraints only if tainting */
1049       if (sys) {
1050         /* Impose security constraints only if tainting */
1051         secure = PL_curinterp ? PL_tainting : will_taint;
1052         saverr = errno;  savvmserr = vaxc$errno;
1053       }
1054       else {
1055         secure = 0;
1056       }
1057
1058       flags =
1059 #ifdef SECURE_INTERNAL_GETENV
1060               secure ? PERL__TRNENV_SECURE : 0
1061 #else
1062               0
1063 #endif
1064       ;
1065
1066       /* For the getenv interface we combine all the equivalence names
1067        * of a search list logical into one value to acquire a maximum
1068        * value length of 255*128 (assuming %ENV is using logicals).
1069        */
1070       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1071
1072       /* If the name contains a semicolon-delimited index, parse it
1073        * off and make sure we only retrieve the equivalence name for
1074        * that index.  */
1075       if ((cp2 = strchr(lnm,';')) != NULL) {
1076         strcpy(uplnm,lnm);
1077         uplnm[cp2-lnm] = '\0';
1078         idx = strtoul(cp2+1,NULL,0);
1079         lnm = uplnm;
1080         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1081       }
1082
1083       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1084
1085       /* Discard NOLOGNAM on internal calls since we're often looking
1086        * for an optional name, and this "error" often shows up as the
1087        * (bogus) exit status for a die() call later on.  */
1088       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1089       return success ? eqv : Nullch;
1090     }
1091
1092 }  /* end of my_getenv() */
1093 /*}}}*/
1094
1095
1096 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1097 char *
1098 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1099 {
1100     const char *cp1;
1101     char *buf, *cp2;
1102     unsigned long idx = 0;
1103     int midx, flags;
1104     static char *__my_getenv_len_eqv = NULL;
1105     int secure, saverr, savvmserr;
1106     SV *tmpsv;
1107
1108     midx = my_maxidx(lnm) + 1;
1109
1110     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1111       /* Set up a temporary buffer for the return value; Perl will
1112        * clean it up at the next statement transition */
1113       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1114       if (!tmpsv) return NULL;
1115       buf = SvPVX(tmpsv);
1116     }
1117     else {
1118       /* Assume no interpreter ==> single thread */
1119       if (__my_getenv_len_eqv != NULL) {
1120         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1121       }
1122       else {
1123         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1124       }
1125       buf = __my_getenv_len_eqv;
1126     }
1127
1128     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1129     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1130     char * zeros;
1131
1132       getcwd(buf,LNM$C_NAMLENGTH);
1133       *len = strlen(buf);
1134
1135       /* Get rid of "000000/ in rooted filespecs */
1136       if (*len > 7) {
1137       zeros = strstr(buf, "/000000/");
1138       if (zeros != NULL) {
1139         int mlen;
1140         mlen = *len - (zeros - buf) - 7;
1141         memmove(zeros, &zeros[7], mlen);
1142         *len = *len - 7;
1143         buf[*len] = '\0';
1144         }
1145       }
1146       return buf;
1147     }
1148     else {
1149       if (sys) {
1150         /* Impose security constraints only if tainting */
1151         secure = PL_curinterp ? PL_tainting : will_taint;
1152         saverr = errno;  savvmserr = vaxc$errno;
1153       }
1154       else {
1155         secure = 0;
1156       }
1157
1158       flags =
1159 #ifdef SECURE_INTERNAL_GETENV
1160               secure ? PERL__TRNENV_SECURE : 0
1161 #else
1162               0
1163 #endif
1164       ;
1165
1166       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1167
1168       if ((cp2 = strchr(lnm,';')) != NULL) {
1169         strcpy(buf,lnm);
1170         buf[cp2-lnm] = '\0';
1171         idx = strtoul(cp2+1,NULL,0);
1172         lnm = buf;
1173         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1174       }
1175
1176       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1177
1178       /* Get rid of "000000/ in rooted filespecs */
1179       if (*len > 7) {
1180       char * zeros;
1181         zeros = strstr(buf, "/000000/");
1182         if (zeros != NULL) {
1183           int mlen;
1184           mlen = *len - (zeros - buf) - 7;
1185           memmove(zeros, &zeros[7], mlen);
1186           *len = *len - 7;
1187           buf[*len] = '\0';
1188         }
1189       }
1190
1191       /* Discard NOLOGNAM on internal calls since we're often looking
1192        * for an optional name, and this "error" often shows up as the
1193        * (bogus) exit status for a die() call later on.  */
1194       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1195       return *len ? buf : Nullch;
1196     }
1197
1198 }  /* end of my_getenv_len() */
1199 /*}}}*/
1200
1201 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1202
1203 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1204
1205 /*{{{ void prime_env_iter() */
1206 void
1207 prime_env_iter(void)
1208 /* Fill the %ENV associative array with all logical names we can
1209  * find, in preparation for iterating over it.
1210  */
1211 {
1212   static int primed = 0;
1213   HV *seenhv = NULL, *envhv;
1214   SV *sv = NULL;
1215   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1216   unsigned short int chan;
1217 #ifndef CLI$M_TRUSTED
1218 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1219 #endif
1220   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1221   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1222   long int i;
1223   bool have_sym = FALSE, have_lnm = FALSE;
1224   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1225   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1226   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1227   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1228   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1229 #if defined(PERL_IMPLICIT_CONTEXT)
1230   pTHX;
1231 #endif
1232 #if defined(USE_ITHREADS)
1233   static perl_mutex primenv_mutex;
1234   MUTEX_INIT(&primenv_mutex);
1235 #endif
1236
1237 #if defined(PERL_IMPLICIT_CONTEXT)
1238     /* We jump through these hoops because we can be called at */
1239     /* platform-specific initialization time, which is before anything is */
1240     /* set up--we can't even do a plain dTHX since that relies on the */
1241     /* interpreter structure to be initialized */
1242     if (PL_curinterp) {
1243       aTHX = PERL_GET_INTERP;
1244     } else {
1245       aTHX = NULL;
1246     }
1247 #endif
1248
1249   if (primed || !PL_envgv) return;
1250   MUTEX_LOCK(&primenv_mutex);
1251   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1252   envhv = GvHVn(PL_envgv);
1253   /* Perform a dummy fetch as an lval to insure that the hash table is
1254    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1255   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1256
1257   for (i = 0; env_tables[i]; i++) {
1258      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1259          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1260      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1261   }
1262   if (have_sym || have_lnm) {
1263     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1264     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1265     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1266     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1267   }
1268
1269   for (i--; i >= 0; i--) {
1270     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1271       char *start;
1272       int j;
1273       for (j = 0; environ[j]; j++) {
1274         if (!(start = strchr(environ[j],'='))) {
1275           if (ckWARN(WARN_INTERNAL))
1276             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1277         }
1278         else {
1279           start++;
1280           sv = newSVpv(start,0);
1281           SvTAINTED_on(sv);
1282           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1283         }
1284       }
1285       continue;
1286     }
1287     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1288              !str$case_blind_compare(&tmpdsc,&clisym)) {
1289       strcpy(cmd,"Show Symbol/Global *");
1290       cmddsc.dsc$w_length = 20;
1291       if (env_tables[i]->dsc$w_length == 12 &&
1292           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1293           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1294       flags = defflags | CLI$M_NOLOGNAM;
1295     }
1296     else {
1297       strcpy(cmd,"Show Logical *");
1298       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1299         strcat(cmd," /Table=");
1300         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1301         cmddsc.dsc$w_length = strlen(cmd);
1302       }
1303       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1304       flags = defflags | CLI$M_NOCLISYM;
1305     }
1306
1307     /* Create a new subprocess to execute each command, to exclude the
1308      * remote possibility that someone could subvert a mbx or file used
1309      * to write multiple commands to a single subprocess.
1310      */
1311     do {
1312       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1313                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1314       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1315       defflags &= ~CLI$M_TRUSTED;
1316     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1317     _ckvmssts(retsts);
1318     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1319     if (seenhv) SvREFCNT_dec(seenhv);
1320     seenhv = newHV();
1321     while (1) {
1322       char *cp1, *cp2, *key;
1323       unsigned long int sts, iosb[2], retlen, keylen;
1324       register U32 hash;
1325
1326       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1327       if (sts & 1) sts = iosb[0] & 0xffff;
1328       if (sts == SS$_ENDOFFILE) {
1329         int wakect = 0;
1330         while (substs == 0) { sys$hiber(); wakect++;}
1331         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1332         _ckvmssts(substs);
1333         break;
1334       }
1335       _ckvmssts(sts);
1336       retlen = iosb[0] >> 16;
1337       if (!retlen) continue;  /* blank line */
1338       buf[retlen] = '\0';
1339       if (iosb[1] != subpid) {
1340         if (iosb[1]) {
1341           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1342         }
1343         continue;
1344       }
1345       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1346         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1347
1348       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1349       if (*cp1 == '(' || /* Logical name table name */
1350           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1351       if (*cp1 == '"') cp1++;
1352       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1353       key = cp1;  keylen = cp2 - cp1;
1354       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1355       while (*cp2 && *cp2 != '=') cp2++;
1356       while (*cp2 && *cp2 == '=') cp2++;
1357       while (*cp2 && *cp2 == ' ') cp2++;
1358       if (*cp2 == '"') {  /* String translation; may embed "" */
1359         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1360         cp2++;  cp1--; /* Skip "" surrounding translation */
1361       }
1362       else {  /* Numeric translation */
1363         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1364         cp1--;  /* stop on last non-space char */
1365       }
1366       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1367         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1368         continue;
1369       }
1370       PERL_HASH(hash,key,keylen);
1371
1372       if (cp1 == cp2 && *cp2 == '.') {
1373         /* A single dot usually means an unprintable character, such as a null
1374          * to indicate a zero-length value.  Get the actual value to make sure.
1375          */
1376         char lnm[LNM$C_NAMLENGTH+1];
1377         char eqv[MAX_DCL_SYMBOL+1];
1378         int trnlen;
1379         strncpy(lnm, key, keylen);
1380         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1381         sv = newSVpvn(eqv, strlen(eqv));
1382       }
1383       else {
1384         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1385       }
1386
1387       SvTAINTED_on(sv);
1388       hv_store(envhv,key,keylen,sv,hash);
1389       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1390     }
1391     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1392       /* get the PPFs for this process, not the subprocess */
1393       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1394       char eqv[LNM$C_NAMLENGTH+1];
1395       int trnlen, i;
1396       for (i = 0; ppfs[i]; i++) {
1397         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1398         sv = newSVpv(eqv,trnlen);
1399         SvTAINTED_on(sv);
1400         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1401       }
1402     }
1403   }
1404   primed = 1;
1405   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1406   if (buf) Safefree(buf);
1407   if (seenhv) SvREFCNT_dec(seenhv);
1408   MUTEX_UNLOCK(&primenv_mutex);
1409   return;
1410
1411 }  /* end of prime_env_iter */
1412 /*}}}*/
1413
1414
1415 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1416 /* Define or delete an element in the same "environment" as
1417  * vmstrnenv().  If an element is to be deleted, it's removed from
1418  * the first place it's found.  If it's to be set, it's set in the
1419  * place designated by the first element of the table vector.
1420  * Like setenv() returns 0 for success, non-zero on error.
1421  */
1422 int
1423 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1424 {
1425     const char *cp1;
1426     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1427     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1428     int nseg = 0, j;
1429     unsigned long int retsts, usermode = PSL$C_USER;
1430     struct itmlst_3 *ile, *ilist;
1431     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1432                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1433                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1434     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1435     $DESCRIPTOR(local,"_LOCAL");
1436
1437     if (!lnm) {
1438         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1439         return SS$_IVLOGNAM;
1440     }
1441
1442     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1443       *cp2 = _toupper(*cp1);
1444       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1445         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1446         return SS$_IVLOGNAM;
1447       }
1448     }
1449     lnmdsc.dsc$w_length = cp1 - lnm;
1450     if (!tabvec || !*tabvec) tabvec = env_tables;
1451
1452     if (!eqv) {  /* we're deleting n element */
1453       for (curtab = 0; tabvec[curtab]; curtab++) {
1454         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1455         int i;
1456           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1457             if ((cp1 = strchr(environ[i],'=')) &&
1458                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1459                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1460 #ifdef HAS_SETENV
1461               return setenv(lnm,"",1) ? vaxc$errno : 0;
1462             }
1463           }
1464           ivenv = 1; retsts = SS$_NOLOGNAM;
1465 #else
1466               if (ckWARN(WARN_INTERNAL))
1467                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1468               ivenv = 1; retsts = SS$_NOSUCHPGM;
1469               break;
1470             }
1471           }
1472 #endif
1473         }
1474         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1475                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1476           unsigned int symtype;
1477           if (tabvec[curtab]->dsc$w_length == 12 &&
1478               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1479               !str$case_blind_compare(&tmpdsc,&local))
1480             symtype = LIB$K_CLI_LOCAL_SYM;
1481           else symtype = LIB$K_CLI_GLOBAL_SYM;
1482           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1483           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1484           if (retsts == LIB$_NOSUCHSYM) continue;
1485           break;
1486         }
1487         else if (!ivlnm) {
1488           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1489           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1490           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1491           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1492           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1493         }
1494       }
1495     }
1496     else {  /* we're defining a value */
1497       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1498 #ifdef HAS_SETENV
1499         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1500 #else
1501         if (ckWARN(WARN_INTERNAL))
1502           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1503         retsts = SS$_NOSUCHPGM;
1504 #endif
1505       }
1506       else {
1507         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1508         eqvdsc.dsc$w_length  = strlen(eqv);
1509         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1510             !str$case_blind_compare(&tmpdsc,&clisym)) {
1511           unsigned int symtype;
1512           if (tabvec[0]->dsc$w_length == 12 &&
1513               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1514                !str$case_blind_compare(&tmpdsc,&local))
1515             symtype = LIB$K_CLI_LOCAL_SYM;
1516           else symtype = LIB$K_CLI_GLOBAL_SYM;
1517           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1518         }
1519         else {
1520           if (!*eqv) eqvdsc.dsc$w_length = 1;
1521           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1522
1523             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1524             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1525               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1526                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1527               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1528               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1529             }
1530
1531             Newx(ilist,nseg+1,struct itmlst_3);
1532             ile = ilist;
1533             if (!ile) {
1534               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1535               return SS$_INSFMEM;
1536             }
1537             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1538
1539             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1540               ile->itmcode = LNM$_STRING;
1541               ile->bufadr = c;
1542               if ((j+1) == nseg) {
1543                 ile->buflen = strlen(c);
1544                 /* in case we are truncating one that's too long */
1545                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1546               }
1547               else {
1548                 ile->buflen = LNM$C_NAMLENGTH;
1549               }
1550             }
1551
1552             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1553             Safefree (ilist);
1554           }
1555           else {
1556             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1557           }
1558         }
1559       }
1560     }
1561     if (!(retsts & 1)) {
1562       switch (retsts) {
1563         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1564         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1565           set_errno(EVMSERR); break;
1566         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1567         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1568           set_errno(EINVAL); break;
1569         case SS$_NOPRIV:
1570           set_errno(EACCES); break;
1571         default:
1572           _ckvmssts(retsts);
1573           set_errno(EVMSERR);
1574        }
1575        set_vaxc_errno(retsts);
1576        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1577     }
1578     else {
1579       /* We reset error values on success because Perl does an hv_fetch()
1580        * before each hv_store(), and if the thing we're setting didn't
1581        * previously exist, we've got a leftover error message.  (Of course,
1582        * this fails in the face of
1583        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1584        * in that the error reported in $! isn't spurious,
1585        * but it's right more often than not.)
1586        */
1587       set_errno(0); set_vaxc_errno(retsts);
1588       return 0;
1589     }
1590
1591 }  /* end of vmssetenv() */
1592 /*}}}*/
1593
1594 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1595 /* This has to be a function since there's a prototype for it in proto.h */
1596 void
1597 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1598 {
1599     if (lnm && *lnm) {
1600       int len = strlen(lnm);
1601       if  (len == 7) {
1602         char uplnm[8];
1603         int i;
1604         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1605         if (!strcmp(uplnm,"DEFAULT")) {
1606           if (eqv && *eqv) my_chdir(eqv);
1607           return;
1608         }
1609     }
1610 #ifndef RTL_USES_UTC
1611     if (len == 6 || len == 2) {
1612       char uplnm[7];
1613       int i;
1614       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1615       uplnm[len] = '\0';
1616       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1617       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1618     }
1619 #endif
1620   }
1621   (void) vmssetenv(lnm,eqv,NULL);
1622 }
1623 /*}}}*/
1624
1625 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1626 /*  vmssetuserlnm
1627  *  sets a user-mode logical in the process logical name table
1628  *  used for redirection of sys$error
1629  */
1630 void
1631 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1632 {
1633     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1634     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1635     unsigned long int iss, attr = LNM$M_CONFINE;
1636     unsigned char acmode = PSL$C_USER;
1637     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1638                                  {0, 0, 0, 0}};
1639     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1640     d_name.dsc$w_length = strlen(name);
1641
1642     lnmlst[0].buflen = strlen(eqv);
1643     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1644
1645     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1646     if (!(iss&1)) lib$signal(iss);
1647 }
1648 /*}}}*/
1649
1650
1651 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1652 /* my_crypt - VMS password hashing
1653  * my_crypt() provides an interface compatible with the Unix crypt()
1654  * C library function, and uses sys$hash_password() to perform VMS
1655  * password hashing.  The quadword hashed password value is returned
1656  * as a NUL-terminated 8 character string.  my_crypt() does not change
1657  * the case of its string arguments; in order to match the behavior
1658  * of LOGINOUT et al., alphabetic characters in both arguments must
1659  *  be upcased by the caller.
1660  *
1661  * - fix me to call ACM services when available
1662  */
1663 char *
1664 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1665 {
1666 #   ifndef UAI$C_PREFERRED_ALGORITHM
1667 #     define UAI$C_PREFERRED_ALGORITHM 127
1668 #   endif
1669     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1670     unsigned short int salt = 0;
1671     unsigned long int sts;
1672     struct const_dsc {
1673         unsigned short int dsc$w_length;
1674         unsigned char      dsc$b_type;
1675         unsigned char      dsc$b_class;
1676         const char *       dsc$a_pointer;
1677     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1678        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1679     struct itmlst_3 uailst[3] = {
1680         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1681         { sizeof salt, UAI$_SALT,    &salt, 0},
1682         { 0,           0,            NULL,  NULL}};
1683     static char hash[9];
1684
1685     usrdsc.dsc$w_length = strlen(usrname);
1686     usrdsc.dsc$a_pointer = usrname;
1687     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1688       switch (sts) {
1689         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1690           set_errno(EACCES);
1691           break;
1692         case RMS$_RNF:
1693           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1694           break;
1695         default:
1696           set_errno(EVMSERR);
1697       }
1698       set_vaxc_errno(sts);
1699       if (sts != RMS$_RNF) return NULL;
1700     }
1701
1702     txtdsc.dsc$w_length = strlen(textpasswd);
1703     txtdsc.dsc$a_pointer = textpasswd;
1704     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1705       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1706     }
1707
1708     return (char *) hash;
1709
1710 }  /* end of my_crypt() */
1711 /*}}}*/
1712
1713
1714 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1715 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1716 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1717
1718 /* fixup barenames that are directories for internal use.
1719  * There have been problems with the consistent handling of UNIX
1720  * style directory names when routines are presented with a name that
1721  * has no directory delimitors at all.  So this routine will eventually
1722  * fix the issue.
1723  */
1724 static char * fixup_bare_dirnames(const char * name)
1725 {
1726   if (decc_disable_to_vms_logname_translation) {
1727 /* fix me */
1728   }
1729   return NULL;
1730 }
1731
1732 /* mp_do_kill_file
1733  * A little hack to get around a bug in some implemenation of remove()
1734  * that do not know how to delete a directory
1735  *
1736  * Delete any file to which user has control access, regardless of whether
1737  * delete access is explicitly allowed.
1738  * Limitations: User must have write access to parent directory.
1739  *              Does not block signals or ASTs; if interrupted in midstream
1740  *              may leave file with an altered ACL.
1741  * HANDLE WITH CARE!
1742  */
1743 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1744 static int
1745 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1746 {
1747     char *vmsname, *rspec;
1748     char *remove_name;
1749     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1750     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1751     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1752     struct myacedef {
1753       unsigned char myace$b_length;
1754       unsigned char myace$b_type;
1755       unsigned short int myace$w_flags;
1756       unsigned long int myace$l_access;
1757       unsigned long int myace$l_ident;
1758     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1759                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1760       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1761      struct itmlst_3
1762        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1763                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1764        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1765        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1766        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1767        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1768
1769     /* Expand the input spec using RMS, since the CRTL remove() and
1770      * system services won't do this by themselves, so we may miss
1771      * a file "hiding" behind a logical name or search list. */
1772     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1773     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1774
1775     if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1776       PerlMem_free(vmsname);
1777       return -1;
1778     }
1779
1780     if (decc_posix_compliant_pathnames) {
1781       /* In POSIX mode, we prefer to remove the UNIX name */
1782       rspec = vmsname;
1783       remove_name = (char *)name;
1784     }
1785     else {
1786       rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1787       if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1788       if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1789         PerlMem_free(rspec);
1790         PerlMem_free(vmsname);
1791         return -1;
1792       }
1793       PerlMem_free(vmsname);
1794       remove_name = rspec;
1795     }
1796
1797 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1798     if (dirflag != 0) {
1799         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1800           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1801           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1802
1803           do_pathify_dirspec(name, remove_name, 0, NULL);
1804           if (!rmdir(remove_name)) {
1805
1806             PerlMem_free(remove_name);
1807             PerlMem_free(rspec);
1808             return 0;   /* Can we just get rid of it? */
1809           }
1810         }
1811         else {
1812           if (!rmdir(remove_name)) {
1813             PerlMem_free(rspec);
1814             return 0;   /* Can we just get rid of it? */
1815           }
1816         }
1817     }
1818     else
1819 #endif
1820       if (!remove(remove_name)) {
1821         PerlMem_free(rspec);
1822         return 0;   /* Can we just get rid of it? */
1823       }
1824
1825     /* If not, can changing protections help? */
1826     if (vaxc$errno != RMS$_PRV) {
1827       PerlMem_free(rspec);
1828       return -1;
1829     }
1830
1831     /* No, so we get our own UIC to use as a rights identifier,
1832      * and the insert an ACE at the head of the ACL which allows us
1833      * to delete the file.
1834      */
1835     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1836     fildsc.dsc$w_length = strlen(rspec);
1837     fildsc.dsc$a_pointer = rspec;
1838     cxt = 0;
1839     newace.myace$l_ident = oldace.myace$l_ident;
1840     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1841       switch (aclsts) {
1842         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1843           set_errno(ENOENT); break;
1844         case RMS$_DIR:
1845           set_errno(ENOTDIR); break;
1846         case RMS$_DEV:
1847           set_errno(ENODEV); break;
1848         case RMS$_SYN: case SS$_INVFILFOROP:
1849           set_errno(EINVAL); break;
1850         case RMS$_PRV:
1851           set_errno(EACCES); break;
1852         default:
1853           _ckvmssts(aclsts);
1854       }
1855       set_vaxc_errno(aclsts);
1856       PerlMem_free(rspec);
1857       return -1;
1858     }
1859     /* Grab any existing ACEs with this identifier in case we fail */
1860     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1861     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1862                     || fndsts == SS$_NOMOREACE ) {
1863       /* Add the new ACE . . . */
1864       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1865         goto yourroom;
1866
1867 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1868       if (dirflag != 0)
1869         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1870           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1871           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1872
1873           do_pathify_dirspec(name, remove_name, 0, NULL);
1874           rmsts = rmdir(remove_name);
1875           PerlMem_free(remove_name);
1876         }
1877         else {
1878         rmsts = rmdir(remove_name);
1879         }
1880       else
1881 #endif
1882         rmsts = remove(remove_name);
1883       if (rmsts) {
1884         /* We blew it - dir with files in it, no write priv for
1885          * parent directory, etc.  Put things back the way they were. */
1886         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1887           goto yourroom;
1888         if (fndsts & 1) {
1889           addlst[0].bufadr = &oldace;
1890           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1891             goto yourroom;
1892         }
1893       }
1894     }
1895
1896     yourroom:
1897     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1898     /* We just deleted it, so of course it's not there.  Some versions of
1899      * VMS seem to return success on the unlock operation anyhow (after all
1900      * the unlock is successful), but others don't.
1901      */
1902     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1903     if (aclsts & 1) aclsts = fndsts;
1904     if (!(aclsts & 1)) {
1905       set_errno(EVMSERR);
1906       set_vaxc_errno(aclsts);
1907       PerlMem_free(rspec);
1908       return -1;
1909     }
1910
1911     PerlMem_free(rspec);
1912     return rmsts;
1913
1914 }  /* end of kill_file() */
1915 /*}}}*/
1916
1917
1918 /*{{{int do_rmdir(char *name)*/
1919 int
1920 Perl_do_rmdir(pTHX_ const char *name)
1921 {
1922     char dirfile[NAM$C_MAXRSS+1];
1923     int retval;
1924     Stat_t st;
1925
1926     if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1927     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1928     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1929     return retval;
1930
1931 }  /* end of do_rmdir */
1932 /*}}}*/
1933
1934 /* kill_file
1935  * Delete any file to which user has control access, regardless of whether
1936  * delete access is explicitly allowed.
1937  * Limitations: User must have write access to parent directory.
1938  *              Does not block signals or ASTs; if interrupted in midstream
1939  *              may leave file with an altered ACL.
1940  * HANDLE WITH CARE!
1941  */
1942 /*{{{int kill_file(char *name)*/
1943 int
1944 Perl_kill_file(pTHX_ const char *name)
1945 {
1946     char rspec[NAM$C_MAXRSS+1];
1947     char *tspec;
1948     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1949     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1950     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1951     struct myacedef {
1952       unsigned char myace$b_length;
1953       unsigned char myace$b_type;
1954       unsigned short int myace$w_flags;
1955       unsigned long int myace$l_access;
1956       unsigned long int myace$l_ident;
1957     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1958                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1959       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1960      struct itmlst_3
1961        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1962                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1963        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1964        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1965        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1966        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1967
1968     /* Expand the input spec using RMS, since the CRTL remove() and
1969      * system services won't do this by themselves, so we may miss
1970      * a file "hiding" behind a logical name or search list. */
1971     tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1972     if (tspec == NULL) return -1;
1973     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1974     /* If not, can changing protections help? */
1975     if (vaxc$errno != RMS$_PRV) return -1;
1976
1977     /* No, so we get our own UIC to use as a rights identifier,
1978      * and the insert an ACE at the head of the ACL which allows us
1979      * to delete the file.
1980      */
1981     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1982     fildsc.dsc$w_length = strlen(rspec);
1983     fildsc.dsc$a_pointer = rspec;
1984     cxt = 0;
1985     newace.myace$l_ident = oldace.myace$l_ident;
1986     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1987       switch (aclsts) {
1988         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1989           set_errno(ENOENT); break;
1990         case RMS$_DIR:
1991           set_errno(ENOTDIR); break;
1992         case RMS$_DEV:
1993           set_errno(ENODEV); break;
1994         case RMS$_SYN: case SS$_INVFILFOROP:
1995           set_errno(EINVAL); break;
1996         case RMS$_PRV:
1997           set_errno(EACCES); break;
1998         default:
1999           _ckvmssts(aclsts);
2000       }
2001       set_vaxc_errno(aclsts);
2002       return -1;
2003     }
2004     /* Grab any existing ACEs with this identifier in case we fail */
2005     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2006     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2007                     || fndsts == SS$_NOMOREACE ) {
2008       /* Add the new ACE . . . */
2009       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2010         goto yourroom;
2011       if ((rmsts = remove(name))) {
2012         /* We blew it - dir with files in it, no write priv for
2013          * parent directory, etc.  Put things back the way they were. */
2014         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2015           goto yourroom;
2016         if (fndsts & 1) {
2017           addlst[0].bufadr = &oldace;
2018           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2019             goto yourroom;
2020         }
2021       }
2022     }
2023
2024     yourroom:
2025     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2026     /* We just deleted it, so of course it's not there.  Some versions of
2027      * VMS seem to return success on the unlock operation anyhow (after all
2028      * the unlock is successful), but others don't.
2029      */
2030     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2031     if (aclsts & 1) aclsts = fndsts;
2032     if (!(aclsts & 1)) {
2033       set_errno(EVMSERR);
2034       set_vaxc_errno(aclsts);
2035       return -1;
2036     }
2037
2038     return rmsts;
2039
2040 }  /* end of kill_file() */
2041 /*}}}*/
2042
2043
2044 /*{{{int my_mkdir(char *,Mode_t)*/
2045 int
2046 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2047 {
2048   STRLEN dirlen = strlen(dir);
2049
2050   /* zero length string sometimes gives ACCVIO */
2051   if (dirlen == 0) return -1;
2052
2053   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2054    * null file name/type.  However, it's commonplace under Unix,
2055    * so we'll allow it for a gain in portability.
2056    */
2057   if (dir[dirlen-1] == '/') {
2058     char *newdir = savepvn(dir,dirlen-1);
2059     int ret = mkdir(newdir,mode);
2060     Safefree(newdir);
2061     return ret;
2062   }
2063   else return mkdir(dir,mode);
2064 }  /* end of my_mkdir */
2065 /*}}}*/
2066
2067 /*{{{int my_chdir(char *)*/
2068 int
2069 Perl_my_chdir(pTHX_ const char *dir)
2070 {
2071   STRLEN dirlen = strlen(dir);
2072
2073   /* zero length string sometimes gives ACCVIO */
2074   if (dirlen == 0) return -1;
2075   const char *dir1;
2076
2077   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2078    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2079    * so that existing scripts do not need to be changed.
2080    */
2081   dir1 = dir;
2082   while ((dirlen > 0) && (*dir1 == ' ')) {
2083     dir1++;
2084     dirlen--;
2085   }
2086
2087   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2088    * that implies
2089    * null file name/type.  However, it's commonplace under Unix,
2090    * so we'll allow it for a gain in portability.
2091    *
2092    * - Preview- '/' will be valid soon on VMS
2093    */
2094   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2095     char *newdir = savepvn(dir1,dirlen-1);
2096     int ret = chdir(newdir);
2097     Safefree(newdir);
2098     return ret;
2099   }
2100   else return chdir(dir1);
2101 }  /* end of my_chdir */
2102 /*}}}*/
2103
2104
2105 /*{{{FILE *my_tmpfile()*/
2106 FILE *
2107 my_tmpfile(void)
2108 {
2109   FILE *fp;
2110   char *cp;
2111
2112   if ((fp = tmpfile())) return fp;
2113
2114   cp = PerlMem_malloc(L_tmpnam+24);
2115   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2116
2117   if (decc_filename_unix_only == 0)
2118     strcpy(cp,"Sys$Scratch:");
2119   else
2120     strcpy(cp,"/tmp/");
2121   tmpnam(cp+strlen(cp));
2122   strcat(cp,".Perltmp");
2123   fp = fopen(cp,"w+","fop=dlt");
2124   PerlMem_free(cp);
2125   return fp;
2126 }
2127 /*}}}*/
2128
2129
2130 #ifndef HOMEGROWN_POSIX_SIGNALS
2131 /*
2132  * The C RTL's sigaction fails to check for invalid signal numbers so we
2133  * help it out a bit.  The docs are correct, but the actual routine doesn't
2134  * do what the docs say it will.
2135  */
2136 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2137 int
2138 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2139                    struct sigaction* oact)
2140 {
2141   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2142         SETERRNO(EINVAL, SS$_INVARG);
2143         return -1;
2144   }
2145   return sigaction(sig, act, oact);
2146 }
2147 /*}}}*/
2148 #endif
2149
2150 #ifdef KILL_BY_SIGPRC
2151 #include <errnodef.h>
2152
2153 /* We implement our own kill() using the undocumented system service
2154    sys$sigprc for one of two reasons:
2155
2156    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2157    target process to do a sys$exit, which usually can't be handled
2158    gracefully...certainly not by Perl and the %SIG{} mechanism.
2159
2160    2.) If the kill() in the CRTL can't be called from a signal
2161    handler without disappearing into the ether, i.e., the signal
2162    it purportedly sends is never trapped. Still true as of VMS 7.3.
2163
2164    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2165    in the target process rather than calling sys$exit.
2166
2167    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2168    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2169    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2170    with condition codes C$_SIG0+nsig*8, catching the exception on the
2171    target process and resignaling with appropriate arguments.
2172
2173    But we don't have that VMS 7.0+ exception handler, so if you
2174    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2175
2176    Also note that SIGTERM is listed in the docs as being "unimplemented",
2177    yet always seems to be signaled with a VMS condition code of 4 (and
2178    correctly handled for that code).  So we hardwire it in.
2179
2180    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2181    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2182    than signalling with an unrecognized (and unhandled by CRTL) code.
2183 */
2184
2185 #define _MY_SIG_MAX 28
2186
2187 static unsigned int
2188 Perl_sig_to_vmscondition_int(int sig)
2189 {
2190     static unsigned int sig_code[_MY_SIG_MAX+1] =
2191     {
2192         0,                  /*  0 ZERO     */
2193         SS$_HANGUP,         /*  1 SIGHUP   */
2194         SS$_CONTROLC,       /*  2 SIGINT   */
2195         SS$_CONTROLY,       /*  3 SIGQUIT  */
2196         SS$_RADRMOD,        /*  4 SIGILL   */
2197         SS$_BREAK,          /*  5 SIGTRAP  */
2198         SS$_OPCCUS,         /*  6 SIGABRT  */
2199         SS$_COMPAT,         /*  7 SIGEMT   */
2200 #ifdef __VAX
2201         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2202 #else
2203         SS$_HPARITH,        /*  8 SIGFPE AXP */
2204 #endif
2205         SS$_ABORT,          /*  9 SIGKILL  */
2206         SS$_ACCVIO,         /* 10 SIGBUS   */
2207         SS$_ACCVIO,         /* 11 SIGSEGV  */
2208         SS$_BADPARAM,       /* 12 SIGSYS   */
2209         SS$_NOMBX,          /* 13 SIGPIPE  */
2210         SS$_ASTFLT,         /* 14 SIGALRM  */
2211         4,                  /* 15 SIGTERM  */
2212         0,                  /* 16 SIGUSR1  */
2213         0,                  /* 17 SIGUSR2  */
2214         0,                  /* 18 */
2215         0,                  /* 19 */
2216         0,                  /* 20 SIGCHLD  */
2217         0,                  /* 21 SIGCONT  */
2218         0,                  /* 22 SIGSTOP  */
2219         0,                  /* 23 SIGTSTP  */
2220         0,                  /* 24 SIGTTIN  */
2221         0,                  /* 25 SIGTTOU  */
2222         0,                  /* 26 */
2223         0,                  /* 27 */
2224         0                   /* 28 SIGWINCH  */
2225     };
2226
2227 #if __VMS_VER >= 60200000
2228     static int initted = 0;
2229     if (!initted) {
2230         initted = 1;
2231         sig_code[16] = C$_SIGUSR1;
2232         sig_code[17] = C$_SIGUSR2;
2233 #if __CRTL_VER >= 70000000
2234         sig_code[20] = C$_SIGCHLD;
2235 #endif
2236 #if __CRTL_VER >= 70300000
2237         sig_code[28] = C$_SIGWINCH;
2238 #endif
2239     }
2240 #endif
2241
2242     if (sig < _SIG_MIN) return 0;
2243     if (sig > _MY_SIG_MAX) return 0;
2244     return sig_code[sig];
2245 }
2246
2247 unsigned int
2248 Perl_sig_to_vmscondition(int sig)
2249 {
2250 #ifdef SS$_DEBUG
2251     if (vms_debug_on_exception != 0)
2252         lib$signal(SS$_DEBUG);
2253 #endif
2254     return Perl_sig_to_vmscondition_int(sig);
2255 }
2256
2257
2258 int
2259 Perl_my_kill(int pid, int sig)
2260 {
2261     dTHX;
2262     int iss;
2263     unsigned int code;
2264     int sys$sigprc(unsigned int *pidadr,
2265                      struct dsc$descriptor_s *prcname,
2266                      unsigned int code);
2267
2268      /* sig 0 means validate the PID */
2269     /*------------------------------*/
2270     if (sig == 0) {
2271         const unsigned long int jpicode = JPI$_PID;
2272         pid_t ret_pid;
2273         int status;
2274         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2275         if ($VMS_STATUS_SUCCESS(status))
2276            return 0;
2277         switch (status) {
2278         case SS$_NOSUCHNODE:
2279         case SS$_UNREACHABLE:
2280         case SS$_NONEXPR:
2281            errno = ESRCH;
2282            break;
2283         case SS$_NOPRIV:
2284            errno = EPERM;
2285            break;
2286         default:
2287            errno = EVMSERR;
2288         }
2289         vaxc$errno=status;
2290         return -1;
2291     }
2292
2293     code = Perl_sig_to_vmscondition_int(sig);
2294
2295     if (!code) {
2296         SETERRNO(EINVAL, SS$_BADPARAM);
2297         return -1;
2298     }
2299
2300     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2301      * signals are to be sent to multiple processes.
2302      *  pid = 0 - all processes in group except ones that the system exempts
2303      *  pid = -1 - all processes except ones that the system exempts
2304      *  pid = -n - all processes in group (abs(n)) except ...
2305      * For now, just report as not supported.
2306      */
2307
2308     if (pid <= 0) {
2309         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2310         return -1;
2311     }
2312
2313     iss = sys$sigprc((unsigned int *)&pid,0,code);
2314     if (iss&1) return 0;
2315
2316     switch (iss) {
2317       case SS$_NOPRIV:
2318         set_errno(EPERM);  break;
2319       case SS$_NONEXPR:
2320       case SS$_NOSUCHNODE:
2321       case SS$_UNREACHABLE:
2322         set_errno(ESRCH);  break;
2323       case SS$_INSFMEM:
2324         set_errno(ENOMEM); break;
2325       default:
2326         _ckvmssts(iss);
2327         set_errno(EVMSERR);
2328     }
2329     set_vaxc_errno(iss);
2330
2331     return -1;
2332 }
2333 #endif
2334
2335 /* Routine to convert a VMS status code to a UNIX status code.
2336 ** More tricky than it appears because of conflicting conventions with
2337 ** existing code.
2338 **
2339 ** VMS status codes are a bit mask, with the least significant bit set for
2340 ** success.
2341 **
2342 ** Special UNIX status of EVMSERR indicates that no translation is currently
2343 ** available, and programs should check the VMS status code.
2344 **
2345 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2346 ** decoding.
2347 */
2348
2349 #ifndef C_FACILITY_NO
2350 #define C_FACILITY_NO 0x350000
2351 #endif
2352 #ifndef DCL_IVVERB
2353 #define DCL_IVVERB 0x38090
2354 #endif
2355
2356 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2357 {
2358 int facility;
2359 int fac_sp;
2360 int msg_no;
2361 int msg_status;
2362 int unix_status;
2363
2364   /* Assume the best or the worst */
2365   if (vms_status & STS$M_SUCCESS)
2366     unix_status = 0;
2367   else
2368     unix_status = EVMSERR;
2369
2370   msg_status = vms_status & ~STS$M_CONTROL;
2371
2372   facility = vms_status & STS$M_FAC_NO;
2373   fac_sp = vms_status & STS$M_FAC_SP;
2374   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2375
2376   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2377     switch(msg_no) {
2378     case SS$_NORMAL:
2379         unix_status = 0;
2380         break;
2381     case SS$_ACCVIO:
2382         unix_status = EFAULT;
2383         break;
2384     case SS$_DEVOFFLINE:
2385         unix_status = EBUSY;
2386         break;
2387     case SS$_CLEARED:
2388         unix_status = ENOTCONN;
2389         break;
2390     case SS$_IVCHAN:
2391     case SS$_IVLOGNAM:
2392     case SS$_BADPARAM:
2393     case SS$_IVLOGTAB:
2394     case SS$_NOLOGNAM:
2395     case SS$_NOLOGTAB:
2396     case SS$_INVFILFOROP:
2397     case SS$_INVARG:
2398     case SS$_NOSUCHID:
2399     case SS$_IVIDENT:
2400         unix_status = EINVAL;
2401         break;
2402     case SS$_UNSUPPORTED:
2403         unix_status = ENOTSUP;
2404         break;
2405     case SS$_FILACCERR:
2406     case SS$_NOGRPPRV:
2407     case SS$_NOSYSPRV:
2408         unix_status = EACCES;
2409         break;
2410     case SS$_DEVICEFULL:
2411         unix_status = ENOSPC;
2412         break;
2413     case SS$_NOSUCHDEV:
2414         unix_status = ENODEV;
2415         break;
2416     case SS$_NOSUCHFILE:
2417     case SS$_NOSUCHOBJECT:
2418         unix_status = ENOENT;
2419         break;
2420     case SS$_ABORT:                                 /* Fatal case */
2421     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2422     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2423         unix_status = EINTR;
2424         break;
2425     case SS$_BUFFEROVF:
2426         unix_status = E2BIG;
2427         break;
2428     case SS$_INSFMEM:
2429         unix_status = ENOMEM;
2430         break;
2431     case SS$_NOPRIV:
2432         unix_status = EPERM;
2433         break;
2434     case SS$_NOSUCHNODE:
2435     case SS$_UNREACHABLE:
2436         unix_status = ESRCH;
2437         break;
2438     case SS$_NONEXPR:
2439         unix_status = ECHILD;
2440         break;
2441     default:
2442         if ((facility == 0) && (msg_no < 8)) {
2443           /* These are not real VMS status codes so assume that they are
2444           ** already UNIX status codes
2445           */
2446           unix_status = msg_no;
2447           break;
2448         }
2449     }
2450   }
2451   else {
2452     /* Translate a POSIX exit code to a UNIX exit code */
2453     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2454         unix_status = (msg_no & 0x07F8) >> 3;
2455     }
2456     else {
2457
2458          /* Documented traditional behavior for handling VMS child exits */
2459         /*--------------------------------------------------------------*/
2460         if (child_flag != 0) {
2461
2462              /* Success / Informational return 0 */
2463             /*----------------------------------*/
2464             if (msg_no & STS$K_SUCCESS)
2465                 return 0;
2466
2467              /* Warning returns 1 */
2468             /*-------------------*/
2469             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2470                 return 1;
2471
2472              /* Everything else pass through the severity bits */
2473             /*------------------------------------------------*/
2474             return (msg_no & STS$M_SEVERITY);
2475         }
2476
2477          /* Normal VMS status to ERRNO mapping attempt */
2478         /*--------------------------------------------*/
2479         switch(msg_status) {
2480         /* case RMS$_EOF: */ /* End of File */
2481         case RMS$_FNF:  /* File Not Found */
2482         case RMS$_DNF:  /* Dir Not Found */
2483                 unix_status = ENOENT;
2484                 break;
2485         case RMS$_RNF:  /* Record Not Found */
2486                 unix_status = ESRCH;
2487                 break;
2488         case RMS$_DIR:
2489                 unix_status = ENOTDIR;
2490                 break;
2491         case RMS$_DEV:
2492                 unix_status = ENODEV;
2493                 break;
2494         case RMS$_IFI:
2495         case RMS$_FAC:
2496         case RMS$_ISI:
2497                 unix_status = EBADF;
2498                 break;
2499         case RMS$_FEX:
2500                 unix_status = EEXIST;
2501                 break;
2502         case RMS$_SYN:
2503         case RMS$_FNM:
2504         case LIB$_INVSTRDES:
2505         case LIB$_INVARG:
2506         case LIB$_NOSUCHSYM:
2507         case LIB$_INVSYMNAM:
2508         case DCL_IVVERB:
2509                 unix_status = EINVAL;
2510                 break;
2511         case CLI$_BUFOVF:
2512         case RMS$_RTB:
2513         case CLI$_TKNOVF:
2514         case CLI$_RSLOVF:
2515                 unix_status = E2BIG;
2516                 break;
2517         case RMS$_PRV:  /* No privilege */
2518         case RMS$_ACC:  /* ACP file access failed */
2519         case RMS$_WLK:  /* Device write locked */
2520                 unix_status = EACCES;
2521                 break;
2522         /* case RMS$_NMF: */  /* No more files */
2523         }
2524     }
2525   }
2526
2527   return unix_status;
2528 }
2529
2530 /* Try to guess at what VMS error status should go with a UNIX errno
2531  * value.  This is hard to do as there could be many possible VMS
2532  * error statuses that caused the errno value to be set.
2533  */
2534
2535 int Perl_unix_status_to_vms(int unix_status)
2536 {
2537 int test_unix_status;
2538
2539      /* Trivial cases first */
2540     /*---------------------*/
2541     if (unix_status == EVMSERR)
2542         return vaxc$errno;
2543
2544      /* Is vaxc$errno sane? */
2545     /*---------------------*/
2546     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2547     if (test_unix_status == unix_status)
2548         return vaxc$errno;
2549
2550      /* If way out of range, must be VMS code already */
2551     /*-----------------------------------------------*/
2552     if (unix_status > EVMSERR)
2553         return unix_status;
2554
2555      /* If out of range, punt */
2556     /*-----------------------*/
2557     if (unix_status > __ERRNO_MAX)
2558         return SS$_ABORT;
2559
2560
2561      /* Ok, now we have to do it the hard way. */
2562     /*----------------------------------------*/
2563     switch(unix_status) {
2564     case 0:     return SS$_NORMAL;
2565     case EPERM: return SS$_NOPRIV;
2566     case ENOENT: return SS$_NOSUCHOBJECT;
2567     case ESRCH: return SS$_UNREACHABLE;
2568     case EINTR: return SS$_ABORT;
2569     /* case EIO: */
2570     /* case ENXIO:  */
2571     case E2BIG: return SS$_BUFFEROVF;
2572     /* case ENOEXEC */
2573     case EBADF: return RMS$_IFI;
2574     case ECHILD: return SS$_NONEXPR;
2575     /* case EAGAIN */
2576     case ENOMEM: return SS$_INSFMEM;
2577     case EACCES: return SS$_FILACCERR;
2578     case EFAULT: return SS$_ACCVIO;
2579     /* case ENOTBLK */
2580     case EBUSY: return SS$_DEVOFFLINE;
2581     case EEXIST: return RMS$_FEX;
2582     /* case EXDEV */
2583     case ENODEV: return SS$_NOSUCHDEV;
2584     case ENOTDIR: return RMS$_DIR;
2585     /* case EISDIR */
2586     case EINVAL: return SS$_INVARG;
2587     /* case ENFILE */
2588     /* case EMFILE */
2589     /* case ENOTTY */
2590     /* case ETXTBSY */
2591     /* case EFBIG */
2592     case ENOSPC: return SS$_DEVICEFULL;
2593     case ESPIPE: return LIB$_INVARG;
2594     /* case EROFS: */
2595     /* case EMLINK: */
2596     /* case EPIPE: */
2597     /* case EDOM */
2598     case ERANGE: return LIB$_INVARG;
2599     /* case EWOULDBLOCK */
2600     /* case EINPROGRESS */
2601     /* case EALREADY */
2602     /* case ENOTSOCK */
2603     /* case EDESTADDRREQ */
2604     /* case EMSGSIZE */
2605     /* case EPROTOTYPE */
2606     /* case ENOPROTOOPT */
2607     /* case EPROTONOSUPPORT */
2608     /* case ESOCKTNOSUPPORT */
2609     /* case EOPNOTSUPP */
2610     /* case EPFNOSUPPORT */
2611     /* case EAFNOSUPPORT */
2612     /* case EADDRINUSE */
2613     /* case EADDRNOTAVAIL */
2614     /* case ENETDOWN */
2615     /* case ENETUNREACH */
2616     /* case ENETRESET */
2617     /* case ECONNABORTED */
2618     /* case ECONNRESET */
2619     /* case ENOBUFS */
2620     /* case EISCONN */
2621     case ENOTCONN: return SS$_CLEARED;
2622     /* case ESHUTDOWN */
2623     /* case ETOOMANYREFS */
2624     /* case ETIMEDOUT */
2625     /* case ECONNREFUSED */
2626     /* case ELOOP */
2627     /* case ENAMETOOLONG */
2628     /* case EHOSTDOWN */
2629     /* case EHOSTUNREACH */
2630     /* case ENOTEMPTY */
2631     /* case EPROCLIM */
2632     /* case EUSERS  */
2633     /* case EDQUOT  */
2634     /* case ENOMSG  */
2635     /* case EIDRM */
2636     /* case EALIGN */
2637     /* case ESTALE */
2638     /* case EREMOTE */
2639     /* case ENOLCK */
2640     /* case ENOSYS */
2641     /* case EFTYPE */
2642     /* case ECANCELED */
2643     /* case EFAIL */
2644     /* case EINPROG */
2645     case ENOTSUP:
2646         return SS$_UNSUPPORTED;
2647     /* case EDEADLK */
2648     /* case ENWAIT */
2649     /* case EILSEQ */
2650     /* case EBADCAT */
2651     /* case EBADMSG */
2652     /* case EABANDONED */
2653     default:
2654         return SS$_ABORT; /* punt */
2655     }
2656
2657   return SS$_ABORT; /* Should not get here */
2658 }
2659
2660
2661 /* default piping mailbox size */
2662 #define PERL_BUFSIZ        512
2663
2664
2665 static void
2666 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2667 {
2668   unsigned long int mbxbufsiz;
2669   static unsigned long int syssize = 0;
2670   unsigned long int dviitm = DVI$_DEVNAM;
2671   char csize[LNM$C_NAMLENGTH+1];
2672   int sts;
2673
2674   if (!syssize) {
2675     unsigned long syiitm = SYI$_MAXBUF;
2676     /*
2677      * Get the SYSGEN parameter MAXBUF
2678      *
2679      * If the logical 'PERL_MBX_SIZE' is defined
2680      * use the value of the logical instead of PERL_BUFSIZ, but
2681      * keep the size between 128 and MAXBUF.
2682      *
2683      */
2684     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2685   }
2686
2687   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2688       mbxbufsiz = atoi(csize);
2689   } else {
2690       mbxbufsiz = PERL_BUFSIZ;
2691   }
2692   if (mbxbufsiz < 128) mbxbufsiz = 128;
2693   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2694
2695   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2696
2697   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2698   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2699
2700 }  /* end of create_mbx() */
2701
2702
2703 /*{{{  my_popen and my_pclose*/
2704
2705 typedef struct _iosb           IOSB;
2706 typedef struct _iosb*         pIOSB;
2707 typedef struct _pipe           Pipe;
2708 typedef struct _pipe*         pPipe;
2709 typedef struct pipe_details    Info;
2710 typedef struct pipe_details*  pInfo;
2711 typedef struct _srqp            RQE;
2712 typedef struct _srqp*          pRQE;
2713 typedef struct _tochildbuf      CBuf;
2714 typedef struct _tochildbuf*    pCBuf;
2715
2716 struct _iosb {
2717     unsigned short status;
2718     unsigned short count;
2719     unsigned long  dvispec;
2720 };
2721
2722 #pragma member_alignment save
2723 #pragma nomember_alignment quadword
2724 struct _srqp {          /* VMS self-relative queue entry */
2725     unsigned long qptr[2];
2726 };
2727 #pragma member_alignment restore
2728 static RQE  RQE_ZERO = {0,0};
2729
2730 struct _tochildbuf {
2731     RQE             q;
2732     int             eof;
2733     unsigned short  size;
2734     char            *buf;
2735 };
2736
2737 struct _pipe {
2738     RQE            free;
2739     RQE            wait;
2740     int            fd_out;
2741     unsigned short chan_in;
2742     unsigned short chan_out;
2743     char          *buf;
2744     unsigned int   bufsize;
2745     IOSB           iosb;
2746     IOSB           iosb2;
2747     int           *pipe_done;
2748     int            retry;
2749     int            type;
2750     int            shut_on_empty;
2751     int            need_wake;
2752     pPipe         *home;
2753     pInfo          info;
2754     pCBuf          curr;
2755     pCBuf          curr2;
2756 #if defined(PERL_IMPLICIT_CONTEXT)
2757     void            *thx;           /* Either a thread or an interpreter */
2758                                     /* pointer, depending on how we're built */
2759 #endif
2760 };
2761
2762
2763 struct pipe_details
2764 {
2765     pInfo           next;
2766     PerlIO *fp;  /* file pointer to pipe mailbox */
2767     int useFILE; /* using stdio, not perlio */
2768     int pid;   /* PID of subprocess */
2769     int mode;  /* == 'r' if pipe open for reading */
2770     int done;  /* subprocess has completed */
2771     int waiting; /* waiting for completion/closure */
2772     int             closing;        /* my_pclose is closing this pipe */
2773     unsigned long   completion;     /* termination status of subprocess */
2774     pPipe           in;             /* pipe in to sub */
2775     pPipe           out;            /* pipe out of sub */
2776     pPipe           err;            /* pipe of sub's sys$error */
2777     int             in_done;        /* true when in pipe finished */
2778     int             out_done;
2779     int             err_done;
2780     unsigned short  xchan;          /* channel to debug xterm */
2781     unsigned short  xchan_valid;    /* channel is assigned */
2782 };
2783
2784 struct exit_control_block
2785 {
2786     struct exit_control_block *flink;
2787     unsigned long int   (*exit_routine)();
2788     unsigned long int arg_count;
2789     unsigned long int *status_address;
2790     unsigned long int exit_status;
2791 };
2792
2793 typedef struct _closed_pipes    Xpipe;
2794 typedef struct _closed_pipes*  pXpipe;
2795
2796 struct _closed_pipes {
2797     int             pid;            /* PID of subprocess */
2798     unsigned long   completion;     /* termination status of subprocess */
2799 };
2800 #define NKEEPCLOSED 50
2801 static Xpipe closed_list[NKEEPCLOSED];
2802 static int   closed_index = 0;
2803 static int   closed_num = 0;
2804
2805 #define RETRY_DELAY     "0 ::0.20"
2806 #define MAX_RETRY              50
2807
2808 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2809 static unsigned long mypid;
2810 static unsigned long delaytime[2];
2811
2812 static pInfo open_pipes = NULL;
2813 static $DESCRIPTOR(nl_desc, "NL:");
2814
2815 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2816
2817
2818
2819 static unsigned long int
2820 pipe_exit_routine(pTHX)
2821 {
2822     pInfo info;
2823     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2824     int sts, did_stuff, need_eof, j;
2825
2826    /*
2827     * Flush any pending i/o, but since we are in process run-down, be
2828     * careful about referencing PerlIO structures that may already have
2829     * been deallocated.  We may not even have an interpreter anymore.
2830     */
2831     info = open_pipes;
2832     while (info) {
2833         if (info->fp) {
2834            if (!info->useFILE
2835 #if defined(USE_ITHREADS)
2836              && my_perl
2837 #endif
2838              && PL_perlio_fd_refcnt)
2839                PerlIO_flush(info->fp);
2840            else
2841                fflush((FILE *)info->fp);
2842         }
2843         info = info->next;
2844     }
2845
2846     /*
2847      next we try sending an EOF...ignore if doesn't work, make sure we
2848      don't hang
2849     */
2850     did_stuff = 0;
2851     info = open_pipes;
2852
2853     while (info) {
2854       int need_eof;
2855       _ckvmssts_noperl(sys$setast(0));
2856       if (info->in && !info->in->shut_on_empty) {
2857         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2858                           0, 0, 0, 0, 0, 0));
2859         info->waiting = 1;
2860         did_stuff = 1;
2861       }
2862       _ckvmssts_noperl(sys$setast(1));
2863       info = info->next;
2864     }
2865
2866     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2867
2868     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2869         int nwait = 0;
2870
2871         info = open_pipes;
2872         while (info) {
2873           _ckvmssts_noperl(sys$setast(0));
2874           if (info->waiting && info->done)
2875                 info->waiting = 0;
2876           nwait += info->waiting;
2877           _ckvmssts_noperl(sys$setast(1));
2878           info = info->next;
2879         }
2880         if (!nwait) break;
2881         sleep(1);
2882     }
2883
2884     did_stuff = 0;
2885     info = open_pipes;
2886     while (info) {
2887       _ckvmssts_noperl(sys$setast(0));
2888       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2889         sts = sys$forcex(&info->pid,0,&abort);
2890         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2891         did_stuff = 1;
2892       }
2893       _ckvmssts_noperl(sys$setast(1));
2894       info = info->next;
2895     }
2896
2897     /* again, wait for effect */
2898
2899     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2900         int nwait = 0;
2901
2902         info = open_pipes;
2903         while (info) {
2904           _ckvmssts_noperl(sys$setast(0));
2905           if (info->waiting && info->done)
2906                 info->waiting = 0;
2907           nwait += info->waiting;
2908           _ckvmssts_noperl(sys$setast(1));
2909           info = info->next;
2910         }
2911         if (!nwait) break;
2912         sleep(1);
2913     }
2914
2915     info = open_pipes;
2916     while (info) {
2917       _ckvmssts_noperl(sys$setast(0));
2918       if (!info->done) {  /* We tried to be nice . . . */
2919         sts = sys$delprc(&info->pid,0);
2920         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2921         info->done = 1;  /* sys$delprc is as done as we're going to get. */
2922       }
2923       _ckvmssts_noperl(sys$setast(1));
2924       info = info->next;
2925     }
2926
2927     while(open_pipes) {
2928       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2929       else if (!(sts & 1)) retsts = sts;
2930     }
2931     return retsts;
2932 }
2933
2934 static struct exit_control_block pipe_exitblock =
2935        {(struct exit_control_block *) 0,
2936         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2937
2938 static void pipe_mbxtofd_ast(pPipe p);
2939 static void pipe_tochild1_ast(pPipe p);
2940 static void pipe_tochild2_ast(pPipe p);
2941
2942 static void
2943 popen_completion_ast(pInfo info)
2944 {
2945   pInfo i = open_pipes;
2946   int iss;
2947   int sts;
2948   pXpipe x;
2949
2950   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2951   closed_list[closed_index].pid = info->pid;
2952   closed_list[closed_index].completion = info->completion;
2953   closed_index++;
2954   if (closed_index == NKEEPCLOSED)
2955     closed_index = 0;
2956   closed_num++;
2957
2958   while (i) {
2959     if (i == info) break;
2960     i = i->next;
2961   }
2962   if (!i) return;       /* unlinked, probably freed too */
2963
2964   info->done = TRUE;
2965
2966 /*
2967     Writing to subprocess ...
2968             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2969
2970             chan_out may be waiting for "done" flag, or hung waiting
2971             for i/o completion to child...cancel the i/o.  This will
2972             put it into "snarf mode" (done but no EOF yet) that discards
2973             input.
2974
2975     Output from subprocess (stdout, stderr) needs to be flushed and
2976     shut down.   We try sending an EOF, but if the mbx is full the pipe
2977     routine should still catch the "shut_on_empty" flag, telling it to
2978     use immediate-style reads so that "mbx empty" -> EOF.
2979
2980
2981 */
2982   if (info->in && !info->in_done) {               /* only for mode=w */
2983         if (info->in->shut_on_empty && info->in->need_wake) {
2984             info->in->need_wake = FALSE;
2985             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2986         } else {
2987             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2988         }
2989   }
2990
2991   if (info->out && !info->out_done) {             /* were we also piping output? */
2992       info->out->shut_on_empty = TRUE;
2993       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2994       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2995       _ckvmssts_noperl(iss);
2996   }
2997
2998   if (info->err && !info->err_done) {        /* we were piping stderr */
2999         info->err->shut_on_empty = TRUE;
3000         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3001         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3002         _ckvmssts_noperl(iss);
3003   }
3004   _ckvmssts_noperl(sys$setef(pipe_ef));
3005
3006 }
3007
3008 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3009 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3010
3011 /*
3012     we actually differ from vmstrnenv since we use this to
3013     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3014     are pointing to the same thing
3015 */
3016
3017 static unsigned short
3018 popen_translate(pTHX_ char *logical, char *result)
3019 {
3020     int iss;
3021     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3022     $DESCRIPTOR(d_log,"");
3023     struct _il3 {
3024         unsigned short length;
3025         unsigned short code;
3026         char *         buffer_addr;
3027         unsigned short *retlenaddr;
3028     } itmlst[2];
3029     unsigned short l, ifi;
3030
3031     d_log.dsc$a_pointer = logical;
3032     d_log.dsc$w_length  = strlen(logical);
3033
3034     itmlst[0].code = LNM$_STRING;
3035     itmlst[0].length = 255;
3036     itmlst[0].buffer_addr = result;
3037     itmlst[0].retlenaddr = &l;
3038
3039     itmlst[1].code = 0;
3040     itmlst[1].length = 0;
3041     itmlst[1].buffer_addr = 0;
3042     itmlst[1].retlenaddr = 0;
3043
3044     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3045     if (iss == SS$_NOLOGNAM) {
3046         iss = SS$_NORMAL;
3047         l = 0;
3048     }
3049     if (!(iss&1)) lib$signal(iss);
3050     result[l] = '\0';
3051 /*
3052     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3053     strip it off and return the ifi, if any
3054 */
3055     ifi  = 0;
3056     if (result[0] == 0x1b && result[1] == 0x00) {
3057         memmove(&ifi,result+2,2);
3058         strcpy(result,result+4);
3059     }
3060     return ifi;     /* this is the RMS internal file id */
3061 }
3062
3063 static void pipe_infromchild_ast(pPipe p);
3064
3065 /*
3066     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3067     inside an AST routine without worrying about reentrancy and which Perl
3068     memory allocator is being used.
3069
3070     We read data and queue up the buffers, then spit them out one at a
3071     time to the output mailbox when the output mailbox is ready for one.
3072
3073 */
3074 #define INITIAL_TOCHILDQUEUE  2
3075
3076 static pPipe
3077 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3078 {
3079     pPipe p;
3080     pCBuf b;
3081     char mbx1[64], mbx2[64];
3082     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3083                                       DSC$K_CLASS_S, mbx1},
3084                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3085                                       DSC$K_CLASS_S, mbx2};
3086     unsigned int dviitm = DVI$_DEVBUFSIZ;
3087     int j, n;
3088
3089     n = sizeof(Pipe);
3090     _ckvmssts(lib$get_vm(&n, &p));
3091
3092     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3093     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3094     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3095
3096     p->buf           = 0;
3097     p->shut_on_empty = FALSE;
3098     p->need_wake     = FALSE;
3099     p->type          = 0;
3100     p->retry         = 0;
3101     p->iosb.status   = SS$_NORMAL;
3102     p->iosb2.status  = SS$_NORMAL;
3103     p->free          = RQE_ZERO;
3104     p->wait          = RQE_ZERO;
3105     p->curr          = 0;
3106     p->curr2         = 0;
3107     p->info          = 0;
3108 #ifdef PERL_IMPLICIT_CONTEXT
3109     p->thx           = aTHX;
3110 #endif
3111
3112     n = sizeof(CBuf) + p->bufsize;
3113
3114     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3115         _ckvmssts(lib$get_vm(&n, &b));
3116         b->buf = (char *) b + sizeof(CBuf);
3117         _ckvmssts(lib$insqhi(b, &p->free));
3118     }
3119
3120     pipe_tochild2_ast(p);
3121     pipe_tochild1_ast(p);
3122     strcpy(wmbx, mbx1);
3123     strcpy(rmbx, mbx2);
3124     return p;
3125 }
3126
3127 /*  reads the MBX Perl is writing, and queues */
3128
3129 static void
3130 pipe_tochild1_ast(pPipe p)
3131 {
3132     pCBuf b = p->curr;
3133     int iss = p->iosb.status;
3134     int eof = (iss == SS$_ENDOFFILE);
3135     int sts;
3136 #ifdef PERL_IMPLICIT_CONTEXT
3137     pTHX = p->thx;
3138 #endif
3139
3140     if (p->retry) {
3141         if (eof) {
3142             p->shut_on_empty = TRUE;
3143             b->eof     = TRUE;
3144             _ckvmssts(sys$dassgn(p->chan_in));
3145         } else  {
3146             _ckvmssts(iss);
3147         }
3148
3149         b->eof  = eof;
3150         b->size = p->iosb.count;
3151         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3152         if (p->need_wake) {
3153             p->need_wake = FALSE;
3154             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3155         }
3156     } else {
3157         p->retry = 1;   /* initial call */
3158     }
3159
3160     if (eof) {                  /* flush the free queue, return when done */
3161         int n = sizeof(CBuf) + p->bufsize;
3162         while (1) {
3163             iss = lib$remqti(&p->free, &b);
3164             if (iss == LIB$_QUEWASEMP) return;
3165             _ckvmssts(iss);
3166             _ckvmssts(lib$free_vm(&n, &b));
3167         }
3168     }
3169
3170     iss = lib$remqti(&p->free, &b);
3171     if (iss == LIB$_QUEWASEMP) {
3172         int n = sizeof(CBuf) + p->bufsize;
3173         _ckvmssts(lib$get_vm(&n, &b));
3174         b->buf = (char *) b + sizeof(CBuf);
3175     } else {
3176        _ckvmssts(iss);
3177     }
3178
3179     p->curr = b;
3180     iss = sys$qio(0,p->chan_in,
3181              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3182              &p->iosb,
3183              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3184     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3185     _ckvmssts(iss);
3186 }
3187
3188
3189 /* writes queued buffers to output, waits for each to complete before
3190    doing the next */
3191
3192 static void
3193 pipe_tochild2_ast(pPipe p)
3194 {
3195     pCBuf b = p->curr2;
3196     int iss = p->iosb2.status;
3197     int n = sizeof(CBuf) + p->bufsize;
3198     int done = (p->info && p->info->done) ||
3199               iss == SS$_CANCEL || iss == SS$_ABORT;
3200 #if defined(PERL_IMPLICIT_CONTEXT)
3201     pTHX = p->thx;
3202 #endif
3203
3204     do {
3205         if (p->type) {         /* type=1 has old buffer, dispose */
3206             if (p->shut_on_empty) {
3207                 _ckvmssts(lib$free_vm(&n, &b));
3208             } else {
3209                 _ckvmssts(lib$insqhi(b, &p->free));
3210             }
3211             p->type = 0;
3212         }
3213
3214         iss = lib$remqti(&p->wait, &b);
3215         if (iss == LIB$_QUEWASEMP) {
3216             if (p->shut_on_empty) {
3217                 if (done) {
3218                     _ckvmssts(sys$dassgn(p->chan_out));
3219                     *p->pipe_done = TRUE;
3220                     _ckvmssts(sys$setef(pipe_ef));
3221                 } else {
3222                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3223                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3224                 }
3225                 return;
3226             }
3227             p->need_wake = TRUE;
3228             return;
3229         }
3230         _ckvmssts(iss);
3231         p->type = 1;
3232     } while (done);
3233
3234
3235     p->curr2 = b;
3236     if (b->eof) {
3237         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3238             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3239     } else {
3240         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3241             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3242     }
3243
3244     return;
3245
3246 }
3247
3248
3249 static pPipe
3250 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3251 {
3252     pPipe p;
3253     char mbx1[64], mbx2[64];
3254     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3255                                       DSC$K_CLASS_S, mbx1},
3256                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3257                                       DSC$K_CLASS_S, mbx2};
3258     unsigned int dviitm = DVI$_DEVBUFSIZ;
3259
3260     int n = sizeof(Pipe);
3261     _ckvmssts(lib$get_vm(&n, &p));
3262     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3263     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3264
3265     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3266     n = p->bufsize * sizeof(char);
3267     _ckvmssts(lib$get_vm(&n, &p->buf));
3268     p->shut_on_empty = FALSE;
3269     p->info   = 0;
3270     p->type   = 0;
3271     p->iosb.status = SS$_NORMAL;
3272 #if defined(PERL_IMPLICIT_CONTEXT)
3273     p->thx = aTHX;
3274 #endif
3275     pipe_infromchild_ast(p);
3276
3277     strcpy(wmbx, mbx1);
3278     strcpy(rmbx, mbx2);
3279     return p;
3280 }
3281
3282 static void
3283 pipe_infromchild_ast(pPipe p)
3284 {
3285     int iss = p->iosb.status;
3286     int eof = (iss == SS$_ENDOFFILE);
3287     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3288     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3289 #if defined(PERL_IMPLICIT_CONTEXT)
3290     pTHX = p->thx;
3291 #endif
3292
3293     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3294         _ckvmssts(sys$dassgn(p->chan_out));
3295         p->chan_out = 0;
3296     }
3297
3298     /* read completed:
3299             input shutdown if EOF from self (done or shut_on_empty)
3300             output shutdown if closing flag set (my_pclose)
3301             send data/eof from child or eof from self
3302             otherwise, re-read (snarf of data from child)
3303     */
3304
3305     if (p->type == 1) {
3306         p->type = 0;
3307         if (myeof && p->chan_in) {                  /* input shutdown */
3308             _ckvmssts(sys$dassgn(p->chan_in));
3309             p->chan_in = 0;
3310         }
3311
3312         if (p->chan_out) {
3313             if (myeof || kideof) {      /* pass EOF to parent */
3314                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3315                               pipe_infromchild_ast, p,
3316                               0, 0, 0, 0, 0, 0));
3317                 return;
3318             } else if (eof) {       /* eat EOF --- fall through to read*/
3319
3320             } else {                /* transmit data */
3321                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3322                               pipe_infromchild_ast,p,
3323                               p->buf, p->iosb.count, 0, 0, 0, 0));
3324                 return;
3325             }
3326         }
3327     }
3328
3329     /*  everything shut? flag as done */
3330
3331     if (!p->chan_in && !p->chan_out) {
3332         *p->pipe_done = TRUE;
3333         _ckvmssts(sys$setef(pipe_ef));
3334         return;
3335     }
3336
3337     /* write completed (or read, if snarfing from child)
3338             if still have input active,
3339                queue read...immediate mode if shut_on_empty so we get EOF if empty
3340             otherwise,
3341                check if Perl reading, generate EOFs as needed
3342     */
3343
3344     if (p->type == 0) {
3345         p->type = 1;
3346         if (p->chan_in) {
3347             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3348                           pipe_infromchild_ast,p,
3349                           p->buf, p->bufsize, 0, 0, 0, 0);
3350             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3351             _ckvmssts(iss);
3352         } else {           /* send EOFs for extra reads */
3353             p->iosb.status = SS$_ENDOFFILE;
3354             p->iosb.dvispec = 0;
3355             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3356                       0, 0, 0,
3357                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3358         }
3359     }
3360 }
3361
3362 static pPipe
3363 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3364 {
3365     pPipe p;
3366     char mbx[64];
3367     unsigned long dviitm = DVI$_DEVBUFSIZ;
3368     struct stat s;
3369     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3370                                       DSC$K_CLASS_S, mbx};
3371     int n = sizeof(Pipe);
3372
3373     /* things like terminals and mbx's don't need this filter */
3374     if (fd && fstat(fd,&s) == 0) {
3375         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3376         char device[65];
3377         unsigned short dev_len;
3378         struct dsc$descriptor_s d_dev;
3379         char * cptr;
3380         struct item_list_3 items[3];
3381         int status;
3382         unsigned short dvi_iosb[4];
3383
3384         cptr = getname(fd, out, 1);
3385         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3386         d_dev.dsc$a_pointer = out;
3387         d_dev.dsc$w_length = strlen(out);
3388         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3389         d_dev.dsc$b_class = DSC$K_CLASS_S;
3390
3391         items[0].len = 4;
3392         items[0].code = DVI$_DEVCHAR;
3393         items[0].bufadr = &devchar;
3394         items[0].retadr = NULL;
3395         items[1].len = 64;
3396         items[1].code = DVI$_FULLDEVNAM;
3397         items[1].bufadr = device;
3398         items[1].retadr = &dev_len;
3399         items[2].len = 0;
3400         items[2].code = 0;
3401
3402         status = sys$getdviw
3403                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3404         _ckvmssts(status);
3405         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3406             device[dev_len] = 0;
3407
3408             if (!(devchar & DEV$M_DIR)) {
3409                 strcpy(out, device);
3410                 return 0;
3411             }
3412         }
3413     }
3414
3415     _ckvmssts(lib$get_vm(&n, &p));
3416     p->fd_out = dup(fd);
3417     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3418     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3419     n = (p->bufsize+1) * sizeof(char);
3420     _ckvmssts(lib$get_vm(&n, &p->buf));
3421     p->shut_on_empty = FALSE;
3422     p->retry = 0;
3423     p->info  = 0;
3424     strcpy(out, mbx);
3425
3426     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3427                   pipe_mbxtofd_ast, p,
3428                   p->buf, p->bufsize, 0, 0, 0, 0));
3429
3430     return p;
3431 }
3432
3433 static void
3434 pipe_mbxtofd_ast(pPipe p)
3435 {
3436     int iss = p->iosb.status;
3437     int done = p->info->done;
3438     int iss2;
3439     int eof = (iss == SS$_ENDOFFILE);
3440     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3441     int err = !(iss&1) && !eof;
3442 #if defined(PERL_IMPLICIT_CONTEXT)
3443     pTHX = p->thx;
3444 #endif
3445
3446     if (done && myeof) {               /* end piping */
3447         close(p->fd_out);
3448         sys$dassgn(p->chan_in);
3449         *p->pipe_done = TRUE;
3450         _ckvmssts(sys$setef(pipe_ef));
3451         return;
3452     }
3453
3454     if (!err && !eof) {             /* good data to send to file */
3455         p->buf[p->iosb.count] = '\n';
3456         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3457         if (iss2 < 0) {
3458             p->retry++;
3459             if (p->retry < MAX_RETRY) {
3460                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3461                 return;
3462             }
3463         }
3464         p->retry = 0;
3465     } else if (err) {
3466         _ckvmssts(iss);
3467     }
3468
3469
3470     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3471           pipe_mbxtofd_ast, p,
3472           p->buf, p->bufsize, 0, 0, 0, 0);
3473     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3474     _ckvmssts(iss);
3475 }
3476
3477
3478 typedef struct _pipeloc     PLOC;
3479 typedef struct _pipeloc*   pPLOC;
3480
3481 struct _pipeloc {
3482     pPLOC   next;
3483     char    dir[NAM$C_MAXRSS+1];
3484 };
3485 static pPLOC  head_PLOC = 0;
3486
3487 void
3488 free_pipelocs(pTHX_ void *head)
3489 {
3490     pPLOC p, pnext;
3491     pPLOC *pHead = (pPLOC *)head;
3492
3493     p = *pHead;
3494     while (p) {
3495         pnext = p->next;
3496         PerlMem_free(p);
3497         p = pnext;
3498     }
3499     *pHead = 0;
3500 }
3501
3502 static void
3503 store_pipelocs(pTHX)
3504 {
3505     int    i;
3506     pPLOC  p;
3507     AV    *av = 0;
3508     SV    *dirsv;
3509     GV    *gv;
3510     char  *dir, *x;
3511     char  *unixdir;
3512     char  temp[NAM$C_MAXRSS+1];
3513     STRLEN n_a;
3514
3515     if (head_PLOC)
3516         free_pipelocs(aTHX_ &head_PLOC);
3517
3518 /*  the . directory from @INC comes last */
3519
3520     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3521     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3522     p->next = head_PLOC;
3523     head_PLOC = p;
3524     strcpy(p->dir,"./");
3525
3526 /*  get the directory from $^X */
3527
3528     unixdir = PerlMem_malloc(VMS_MAXRSS);
3529     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3530
3531 #ifdef PERL_IMPLICIT_CONTEXT
3532     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3533 #else
3534     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3535 #endif
3536         strcpy(temp, PL_origargv[0]);
3537         x = strrchr(temp,']');
3538         if (x == NULL) {
3539         x = strrchr(temp,'>');
3540           if (x == NULL) {
3541             /* It could be a UNIX path */
3542             x = strrchr(temp,'/');
3543           }
3544         }
3545         if (x)
3546           x[1] = '\0';
3547         else {
3548           /* Got a bare name, so use default directory */
3549           temp[0] = '.';
3550           temp[1] = '\0';
3551         }
3552
3553         if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3554             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3555             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3556             p->next = head_PLOC;
3557             head_PLOC = p;
3558             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3559             p->dir[NAM$C_MAXRSS] = '\0';
3560         }
3561     }
3562
3563 /*  reverse order of @INC entries, skip "." since entered above */
3564
3565 #ifdef PERL_IMPLICIT_CONTEXT
3566     if (aTHX)
3567 #endif
3568     if (PL_incgv) av = GvAVn(PL_incgv);
3569
3570     for (i = 0; av && i <= AvFILL(av); i++) {
3571         dirsv = *av_fetch(av,i,TRUE);
3572
3573         if (SvROK(dirsv)) continue;
3574         dir = SvPVx(dirsv,n_a);
3575         if (strcmp(dir,".") == 0) continue;
3576         if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3577             continue;
3578
3579         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3580         p->next = head_PLOC;
3581         head_PLOC = p;
3582         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3583         p->dir[NAM$C_MAXRSS] = '\0';
3584     }
3585
3586 /* most likely spot (ARCHLIB) put first in the list */
3587
3588 #ifdef ARCHLIB_EXP
3589     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3590         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3591         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3592         p->next = head_PLOC;
3593         head_PLOC = p;
3594         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3595         p->dir[NAM$C_MAXRSS] = '\0';
3596     }
3597 #endif
3598     PerlMem_free(unixdir);
3599 }
3600
3601 static I32
3602 Perl_cando_by_name_int
3603    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3604 #if !defined(PERL_IMPLICIT_CONTEXT)
3605 #define cando_by_name_int               Perl_cando_by_name_int
3606 #else
3607 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3608 #endif
3609
3610 static char *
3611 find_vmspipe(pTHX)
3612 {
3613     static int   vmspipe_file_status = 0;
3614     static char  vmspipe_file[NAM$C_MAXRSS+1];
3615
3616     /* already found? Check and use ... need read+execute permission */
3617
3618     if (vmspipe_file_status == 1) {
3619         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3620          && cando_by_name_int
3621            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3622             return vmspipe_file;
3623         }
3624         vmspipe_file_status = 0;
3625     }
3626
3627     /* scan through stored @INC, $^X */
3628
3629     if (vmspipe_file_status == 0) {
3630         char file[NAM$C_MAXRSS+1];
3631         pPLOC  p = head_PLOC;
3632
3633         while (p) {
3634             char * exp_res;
3635             int dirlen;
3636             strcpy(file, p->dir);
3637             dirlen = strlen(file);
3638             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3639             file[NAM$C_MAXRSS] = '\0';
3640             p = p->next;
3641
3642             exp_res = do_rmsexpand
3643                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3644             if (!exp_res) continue;
3645
3646             if (cando_by_name_int
3647                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3648              && cando_by_name_int
3649                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3650                 vmspipe_file_status = 1;
3651                 return vmspipe_file;
3652             }
3653         }
3654         vmspipe_file_status = -1;   /* failed, use tempfiles */
3655     }
3656
3657     return 0;
3658 }
3659
3660 static FILE *
3661 vmspipe_tempfile(pTHX)
3662 {
3663     char file[NAM$C_MAXRSS+1];
3664     FILE *fp;
3665     static int index = 0;
3666     Stat_t s0, s1;
3667     int cmp_result;
3668
3669     /* create a tempfile */
3670
3671     /* we can't go from   W, shr=get to  R, shr=get without
3672        an intermediate vulnerable state, so don't bother trying...
3673
3674        and lib$spawn doesn't shr=put, so have to close the write
3675
3676        So... match up the creation date/time and the FID to
3677        make sure we're dealing with the same file
3678
3679     */
3680
3681     index++;
3682     if (!decc_filename_unix_only) {
3683       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3684       fp = fopen(file,"w");
3685       if (!fp) {
3686         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3687         fp = fopen(file,"w");
3688         if (!fp) {
3689             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3690             fp = fopen(file,"w");
3691         }
3692       }
3693      }
3694      else {
3695       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3696       fp = fopen(file,"w");
3697       if (!fp) {
3698         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3699         fp = fopen(file,"w");
3700         if (!fp) {
3701           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3702           fp = fopen(file,"w");
3703         }
3704       }
3705     }
3706     if (!fp) return 0;  /* we're hosed */
3707
3708     fprintf(fp,"$! 'f$verify(0)'\n");
3709     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3710     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3711     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3712     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3713     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3714     fprintf(fp,"$ perl_del    = \"delete\"\n");
3715     fprintf(fp,"$ pif         = \"if\"\n");
3716     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3717     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3718     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3719     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3720     fprintf(fp,"$!  --- build command line to get max possible length\n");
3721     fprintf(fp,"$c=perl_popen_cmd0\n");
3722     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3723     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3724     fprintf(fp,"$x=perl_popen_cmd3\n");
3725     fprintf(fp,"$c=c+x\n");
3726     fprintf(fp,"$ perl_on\n");
3727     fprintf(fp,"$ 'c'\n");
3728     fprintf(fp,"$ perl_status = $STATUS\n");
3729     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3730     fprintf(fp,"$ perl_exit 'perl_status'\n");
3731     fsync(fileno(fp));
3732
3733     fgetname(fp, file, 1);
3734     fstat(fileno(fp), (struct stat *)&s0);
3735     fclose(fp);
3736
3737     if (decc_filename_unix_only)
3738         do_tounixspec(file, file, 0, NULL);
3739     fp = fopen(file,"r","shr=get");
3740     if (!fp) return 0;
3741     fstat(fileno(fp), (struct stat *)&s1);
3742
3743     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3744     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3745         fclose(fp);
3746         return 0;
3747     }
3748
3749     return fp;
3750 }
3751
3752
3753 #ifdef USE_VMS_DECTERM
3754
3755 static int vms_is_syscommand_xterm(void)
3756 {
3757     const static struct dsc$descriptor_s syscommand_dsc =
3758       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3759
3760     const static struct dsc$descriptor_s decwdisplay_dsc =
3761       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3762
3763     struct item_list_3 items[2];
3764     unsigned short dvi_iosb[4];
3765     unsigned long devchar;
3766     unsigned long devclass;
3767     int status;
3768
3769     /* Very simple check to guess if sys$command is a decterm? */
3770     /* First see if the DECW$DISPLAY: device exists */
3771     items[0].len = 4;
3772     items[0].code = DVI$_DEVCHAR;
3773     items[0].bufadr = &devchar;
3774     items[0].retadr = NULL;
3775     items[1].len = 0;
3776     items[1].code = 0;
3777
3778     status = sys$getdviw
3779         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3780
3781     if ($VMS_STATUS_SUCCESS(status)) {
3782         status = dvi_iosb[0];
3783     }
3784
3785     if (!$VMS_STATUS_SUCCESS(status)) {
3786         SETERRNO(EVMSERR, status);
3787         return -1;
3788     }
3789
3790     /* If it does, then for now assume that we are on a workstation */
3791     /* Now verify that SYS$COMMAND is a terminal */
3792     /* for creating the debugger DECTerm */
3793
3794     items[0].len = 4;
3795     items[0].code = DVI$_DEVCLASS;
3796     items[0].bufadr = &devclass;
3797     items[0].retadr = NULL;
3798     items[1].len = 0;
3799     items[1].code = 0;
3800
3801     status = sys$getdviw
3802         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3803
3804     if ($VMS_STATUS_SUCCESS(status)) {
3805         status = dvi_iosb[0];
3806     }
3807
3808     if (!$VMS_STATUS_SUCCESS(status)) {
3809         SETERRNO(EVMSERR, status);
3810         return -1;
3811     }
3812     else {
3813         if (devclass == DC$_TERM) {
3814             return 0;
3815         }
3816     }
3817     return -1;
3818 }
3819
3820 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3821 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3822 {
3823     int status;
3824     int ret_stat;
3825     char * ret_char;
3826     char device_name[65];
3827     unsigned short device_name_len;
3828     struct dsc$descriptor_s customization_dsc;
3829     struct dsc$descriptor_s device_name_dsc;
3830     const char * cptr;
3831     char * tptr;
3832     char customization[200];
3833     char title[40];
3834     pInfo info = NULL;
3835     char mbx1[64];
3836     unsigned short p_chan;
3837     int n;
3838     unsigned short iosb[4];
3839     struct item_list_3 items[2];
3840     const char * cust_str =
3841         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3842     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3843                                           DSC$K_CLASS_S, mbx1};
3844
3845     ret_char = strstr(cmd," xterm ");
3846     if (ret_char == NULL)
3847         return NULL;
3848     cptr = ret_char + 7;
3849     ret_char = strstr(cmd,"tty");
3850     if (ret_char == NULL)
3851         return NULL;
3852     ret_char = strstr(cmd,"sleep");
3853     if (ret_char == NULL)
3854         return NULL;
3855
3856     /* Are we on a workstation? */
3857     /* to do: capture the rows / columns and pass their properties */
3858     ret_stat = vms_is_syscommand_xterm();
3859     if (ret_stat < 0)
3860         return NULL;
3861
3862     /* Make the title: */
3863     ret_char = strstr(cptr,"-title");
3864     if (ret_char != NULL) {
3865         while ((*cptr != 0) && (*cptr != '\"')) {
3866             cptr++;
3867         }
3868         if (*cptr == '\"')
3869             cptr++;
3870         n = 0;
3871         while ((*cptr != 0) && (*cptr != '\"')) {
3872             title[n] = *cptr;
3873             n++;
3874             if (n == 39) {
3875                 title[39] == 0;
3876                 break;
3877             }
3878             cptr++;
3879         }
3880         title[n] = 0;
3881     }
3882     else {
3883             /* Default title */
3884             strcpy(title,"Perl Debug DECTerm");
3885     }
3886     sprintf(customization, cust_str, title);
3887
3888     customization_dsc.dsc$a_pointer = customization;
3889     customization_dsc.dsc$w_length = strlen(customization);
3890     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3891     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3892
3893     device_name_dsc.dsc$a_pointer = device_name;
3894     device_name_dsc.dsc$w_length = sizeof device_name -1;
3895     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3896     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3897
3898     device_name_len = 0;
3899
3900     /* Try to create the window */
3901      status = decw$term_port
3902        (NULL,
3903         NULL,
3904         &customization_dsc,
3905         &device_name_dsc,
3906         &device_name_len,
3907         NULL,
3908         NULL,
3909         NULL);
3910     if (!$VMS_STATUS_SUCCESS(status)) {
3911         SETERRNO(EVMSERR, status);
3912         return NULL;
3913     }
3914
3915     device_name[device_name_len] = '\0';
3916
3917     /* Need to set this up to look like a pipe for cleanup */
3918     n = sizeof(Info);
3919     status = lib$get_vm(&n, &info);
3920     if (!$VMS_STATUS_SUCCESS(status)) {
3921         SETERRNO(ENOMEM, status);
3922         return NULL;
3923     }
3924
3925     info->mode = *mode;
3926     info->done = FALSE;
3927     info->completion = 0;
3928     info->closing    = FALSE;
3929     info->in         = 0;
3930     info->out        = 0;
3931     info->err        = 0;
3932     info->fp         = Nullfp;
3933     info->useFILE    = 0;
3934     info->waiting    = 0;
3935     info->in_done    = TRUE;
3936     info->out_done   = TRUE;
3937     info->err_done   = TRUE;
3938
3939     /* Assign a channel on this so that it will persist, and not login */
3940     /* We stash this channel in the info structure for reference. */
3941     /* The created xterm self destructs when the last channel is removed */
3942     /* and it appears that perl5db.pl (perl debugger) does this routinely */
3943     /* So leave this assigned. */
3944     device_name_dsc.dsc$w_length = device_name_len;
3945     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
3946     if (!$VMS_STATUS_SUCCESS(status)) {
3947         SETERRNO(EVMSERR, status);
3948         return NULL;
3949     }
3950     info->xchan_valid = 1;
3951
3952     /* Now create a mailbox to be read by the application */
3953
3954     create_mbx(aTHX_ &p_chan, &d_mbx1);
3955
3956     /* write the name of the created terminal to the mailbox */
3957     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
3958             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
3959
3960     if (!$VMS_STATUS_SUCCESS(status)) {
3961         SETERRNO(EVMSERR, status);
3962         return NULL;
3963     }
3964
3965     info->fp  = PerlIO_open(mbx1, mode);
3966
3967     /* Done with this channel */
3968     sys$dassgn(p_chan);
3969
3970     /* If any errors, then clean up */
3971     if (!info->fp) {
3972         n = sizeof(Info);
3973         _ckvmssts(lib$free_vm(&n, &info));
3974         return NULL;
3975         }
3976
3977     /* All done */
3978     return info->fp;
3979 }
3980 #endif
3981
3982 static PerlIO *
3983 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3984 {
3985     static int handler_set_up = FALSE;
3986     unsigned long int sts, flags = CLI$M_NOWAIT;
3987     /* The use of a GLOBAL table (as was done previously) rendered
3988      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3989      * environment.  Hence we've switched to LOCAL symbol table.
3990      */
3991     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3992     int j, wait = 0, n;
3993     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3994     char *in, *out, *err, mbx[512];
3995     FILE *tpipe = 0;
3996     char tfilebuf[NAM$C_MAXRSS+1];
3997     pInfo info = NULL;
3998     char cmd_sym_name[20];
3999     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4000                                       DSC$K_CLASS_S, symbol};
4001     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4002                                       DSC$K_CLASS_S, 0};
4003     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4004                                       DSC$K_CLASS_S, cmd_sym_name};
4005     struct dsc$descriptor_s *vmscmd;
4006     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4007     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4008     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4009
4010 #ifdef USE_VMS_DECTERM
4011     /* Check here for Xterm create request.  This means looking for
4012      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4013      *  is possible to create an xterm.
4014      */
4015     if (*in_mode == 'r') {
4016         PerlIO * xterm_fd;
4017
4018         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4019         if (xterm_fd != Nullfp)
4020             return xterm_fd;
4021     }
4022 #endif
4023
4024     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4025
4026     /* once-per-program initialization...
4027        note that the SETAST calls and the dual test of pipe_ef
4028        makes sure that only the FIRST thread through here does
4029        the initialization...all other threads wait until it's
4030        done.
4031
4032        Yeah, uglier than a pthread call, it's got all the stuff inline
4033        rather than in a separate routine.
4034     */
4035
4036     if (!pipe_ef) {
4037         _ckvmssts(sys$setast(0));
4038         if (!pipe_ef) {
4039             unsigned long int pidcode = JPI$_PID;
4040             $DESCRIPTOR(d_delay, RETRY_DELAY);
4041             _ckvmssts(lib$get_ef(&pipe_ef));
4042             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4043             _ckvmssts(sys$bintim(&d_delay, delaytime));
4044         }
4045         if (!handler_set_up) {
4046           _ckvmssts(sys$dclexh(&pipe_exitblock));
4047           handler_set_up = TRUE;
4048         }
4049         _ckvmssts(sys$setast(1));
4050     }
4051
4052     /* see if we can find a VMSPIPE.COM */
4053
4054     tfilebuf[0] = '@';
4055     vmspipe = find_vmspipe(aTHX);
4056     if (vmspipe) {
4057         strcpy(tfilebuf+1,vmspipe);
4058     } else {        /* uh, oh...we're in tempfile hell */
4059         tpipe = vmspipe_tempfile(aTHX);
4060         if (!tpipe) {       /* a fish popular in Boston */
4061             if (ckWARN(WARN_PIPE)) {
4062                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4063             }
4064         return Nullfp;
4065         }
4066         fgetname(tpipe,tfilebuf+1,1);
4067     }
4068     vmspipedsc.dsc$a_pointer = tfilebuf;
4069     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4070
4071     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4072     if (!(sts & 1)) {
4073       switch (sts) {
4074         case RMS$_FNF:  case RMS$_DNF:
4075           set_errno(ENOENT); break;
4076         case RMS$_DIR:
4077           set_errno(ENOTDIR); break;
4078         case RMS$_DEV:
4079           set_errno(ENODEV); break;
4080         case RMS$_PRV:
4081           set_errno(EACCES); break;
4082         case RMS$_SYN:
4083           set_errno(EINVAL); break;
4084         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4085           set_errno(E2BIG); break;
4086         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4087           _ckvmssts(sts); /* fall through */
4088         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4089           set_errno(EVMSERR);
4090       }
4091       set_vaxc_errno(sts);
4092       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4093         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4094       }
4095       *psts = sts;
4096       return Nullfp;
4097     }
4098     n = sizeof(Info);
4099     _ckvmssts(lib$get_vm(&n, &info));
4100
4101     strcpy(mode,in_mode);
4102     info->mode = *mode;
4103     info->done = FALSE;
4104     info->completion = 0;
4105     info->closing    = FALSE;
4106     info->in         = 0;
4107     info->out        = 0;
4108     info->err        = 0;
4109     info->fp         = Nullfp;
4110     info->useFILE    = 0;
4111     info->waiting    = 0;
4112     info->in_done    = TRUE;
4113     info->out_done   = TRUE;
4114     info->err_done   = TRUE;
4115     info->xchan      = 0;
4116     info->xchan_valid = 0;
4117
4118     in = PerlMem_malloc(VMS_MAXRSS);
4119     if (in == NULL) _ckvmssts(SS$_INSFMEM);
4120     out = PerlMem_malloc(VMS_MAXRSS);
4121     if (out == NULL) _ckvmssts(SS$_INSFMEM);
4122     err = PerlMem_malloc(VMS_MAXRSS);
4123     if (err == NULL) _ckvmssts(SS$_INSFMEM);
4124
4125     in[0] = out[0] = err[0] = '\0';
4126
4127     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4128         info->useFILE = 1;
4129         strcpy(p,p+1);
4130     }
4131     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4132         wait = 1;
4133         strcpy(p,p+1);
4134     }
4135
4136     if (*mode == 'r') {             /* piping from subroutine */
4137
4138         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4139         if (info->out) {
4140             info->out->pipe_done = &info->out_done;
4141             info->out_done = FALSE;
4142             info->out->info = info;
4143         }
4144         if (!info->useFILE) {
4145             info->fp  = PerlIO_open(mbx, mode);
4146         } else {
4147             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4148             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4149         }
4150
4151         if (!info->fp && info->out) {
4152             sys$cancel(info->out->chan_out);
4153
4154             while (!info->out_done) {
4155                 int done;
4156                 _ckvmssts(sys$setast(0));
4157                 done = info->out_done;
4158                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4159                 _ckvmssts(sys$setast(1));
4160                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4161             }
4162
4163             if (info->out->buf) {
4164                 n = info->out->bufsize * sizeof(char);
4165                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4166             }
4167             n = sizeof(Pipe);
4168             _ckvmssts(lib$free_vm(&n, &info->out));
4169             n = sizeof(Info);
4170             _ckvmssts(lib$free_vm(&n, &info));
4171             *psts = RMS$_FNF;
4172             return Nullfp;
4173         }
4174
4175         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4176         if (info->err) {
4177             info->err->pipe_done = &info->err_done;
4178             info->err_done = FALSE;
4179             info->err->info = info;
4180         }
4181
4182     } else if (*mode == 'w') {      /* piping to subroutine */
4183
4184         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4185         if (info->out) {
4186             info->out->pipe_done = &info->out_done;
4187             info->out_done = FALSE;
4188             info->out->info = info;
4189         }
4190
4191         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4192         if (info->err) {
4193             info->err->pipe_done = &info->err_done;
4194             info->err_done = FALSE;
4195             info->err->info = info;
4196         }
4197
4198         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4199         if (!info->useFILE) {
4200             info->fp  = PerlIO_open(mbx, mode);
4201         } else {
4202             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4203             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4204         }
4205
4206         if (info->in) {
4207             info->in->pipe_done = &info->in_done;
4208             info->in_done = FALSE;
4209             info->in->info = info;
4210         }
4211
4212         /* error cleanup */
4213         if (!info->fp && info->in) {
4214             info->done = TRUE;
4215             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4216                               0, 0, 0, 0, 0, 0, 0, 0));
4217
4218             while (!info->in_done) {
4219                 int done;
4220                 _ckvmssts(sys$setast(0));
4221                 done = info->in_done;
4222                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4223                 _ckvmssts(sys$setast(1));
4224                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4225             }
4226
4227             if (info->in->buf) {
4228                 n = info->in->bufsize * sizeof(char);
4229                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4230             }
4231             n = sizeof(Pipe);
4232             _ckvmssts(lib$free_vm(&n, &info->in));
4233             n = sizeof(Info);
4234             _ckvmssts(lib$free_vm(&n, &info));
4235             *psts = RMS$_FNF;
4236             return Nullfp;
4237         }
4238
4239
4240     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4241         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4242         if (info->out) {
4243             info->out->pipe_done = &info->out_done;
4244             info->out_done = FALSE;
4245             info->out->info = info;
4246         }
4247
4248         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4249         if (info->err) {
4250             info->err->pipe_done = &info->err_done;
4251             info->err_done = FALSE;
4252             info->err->info = info;
4253         }
4254     }
4255
4256     symbol[MAX_DCL_SYMBOL] = '\0';
4257
4258     strncpy(symbol, in, MAX_DCL_SYMBOL);
4259     d_symbol.dsc$w_length = strlen(symbol);
4260     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4261
4262     strncpy(symbol, err, MAX_DCL_SYMBOL);
4263     d_symbol.dsc$w_length = strlen(symbol);
4264     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4265
4266     strncpy(symbol, out, MAX_DCL_SYMBOL);
4267     d_symbol.dsc$w_length = strlen(symbol);
4268     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4269
4270     /* Done with the names for the pipes */
4271     PerlMem_free(err);
4272     PerlMem_free(out);
4273     PerlMem_free(in);
4274
4275     p = vmscmd->dsc$a_pointer;
4276     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4277     if (*p == '$') p++;                         /* remove leading $ */
4278     while (*p == ' ' || *p == '\t') p++;
4279
4280     for (j = 0; j < 4; j++) {
4281         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4282         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4283
4284     strncpy(symbol, p, MAX_DCL_SYMBOL);
4285     d_symbol.dsc$w_length = strlen(symbol);
4286     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4287
4288         if (strlen(p) > MAX_DCL_SYMBOL) {
4289             p += MAX_DCL_SYMBOL;
4290         } else {
4291             p += strlen(p);
4292         }
4293     }
4294     _ckvmssts(sys$setast(0));
4295     info->next=open_pipes;  /* prepend to list */
4296     open_pipes=info;
4297     _ckvmssts(sys$setast(1));
4298     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4299      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4300      * have SYS$COMMAND if we need it.
4301      */
4302     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4303                       0, &info->pid, &info->completion,
4304                       0, popen_completion_ast,info,0,0,0));
4305
4306     /* if we were using a tempfile, close it now */
4307
4308     if (tpipe) fclose(tpipe);
4309
4310     /* once the subprocess is spawned, it has copied the symbols and
4311        we can get rid of ours */
4312
4313     for (j = 0; j < 4; j++) {
4314         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4315         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4316     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4317     }
4318     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4319     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4320     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4321     vms_execfree(vmscmd);
4322
4323 #ifdef PERL_IMPLICIT_CONTEXT
4324     if (aTHX)
4325 #endif
4326     PL_forkprocess = info->pid;
4327
4328     if (wait) {
4329          int done = 0;
4330          while (!done) {
4331              _ckvmssts(sys$setast(0));
4332              done = info->done;
4333              if (!done) _ckvmssts(sys$clref(pipe_ef));
4334              _ckvmssts(sys$setast(1));
4335              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4336          }
4337         *psts = info->completion;
4338 /* Caller thinks it is open and tries to close it. */
4339 /* This causes some problems, as it changes the error status */
4340 /*        my_pclose(info->fp); */
4341     } else {
4342         *psts = SS$_NORMAL;
4343     }
4344     return info->fp;
4345 }  /* end of safe_popen */
4346
4347
4348 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4349 PerlIO *
4350 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4351 {
4352     int sts;
4353     TAINT_ENV();
4354     TAINT_PROPER("popen");
4355     PERL_FLUSHALL_FOR_CHILD;
4356     return safe_popen(aTHX_ cmd,mode,&sts);
4357 }
4358
4359 /*}}}*/
4360
4361 /*{{{  I32 my_pclose(PerlIO *fp)*/
4362 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4363 {
4364     pInfo info, last = NULL;
4365     unsigned long int retsts;
4366     int done, iss, n;
4367     int status;
4368
4369     for (info = open_pipes; info != NULL; last = info, info = info->next)
4370         if (info->fp == fp) break;
4371
4372     if (info == NULL) {  /* no such pipe open */
4373       set_errno(ECHILD); /* quoth POSIX */
4374       set_vaxc_errno(SS$_NONEXPR);
4375       return -1;
4376     }
4377
4378     /* If we were writing to a subprocess, insure that someone reading from
4379      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4380      * produce an EOF record in the mailbox.
4381      *
4382      *  well, at least sometimes it *does*, so we have to watch out for
4383      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4384      */
4385      if (info->fp) {
4386         if (!info->useFILE
4387 #if defined(USE_ITHREADS)
4388           && my_perl
4389 #endif
4390           && PL_perlio_fd_refcnt)
4391             PerlIO_flush(info->fp);
4392         else
4393             fflush((FILE *)info->fp);
4394     }
4395
4396     _ckvmssts(sys$setast(0));
4397      info->closing = TRUE;
4398      done = info->done && info->in_done && info->out_done && info->err_done;
4399      /* hanging on write to Perl's input? cancel it */
4400      if (info->mode == 'r' && info->out && !info->out_done) {
4401         if (info->out->chan_out) {
4402             _ckvmssts(sys$cancel(info->out->chan_out));
4403             if (!info->out->chan_in) {   /* EOF generation, need AST */
4404                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4405             }
4406         }
4407      }
4408      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4409          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4410                            0, 0, 0, 0, 0, 0));
4411     _ckvmssts(sys$setast(1));
4412     if (info->fp) {
4413      if (!info->useFILE
4414 #if defined(USE_ITHREADS)
4415          && my_perl
4416 #endif
4417          && PL_perlio_fd_refcnt)
4418         PerlIO_close(info->fp);
4419      else
4420         fclose((FILE *)info->fp);
4421     }
4422      /*
4423         we have to wait until subprocess completes, but ALSO wait until all
4424         the i/o completes...otherwise we'll be freeing the "info" structure
4425         that the i/o ASTs could still be using...
4426      */
4427
4428      while (!done) {
4429          _ckvmssts(sys$setast(0));
4430          done = info->done && info->in_done && info->out_done && info->err_done;
4431          if (!done) _ckvmssts(sys$clref(pipe_ef));
4432          _ckvmssts(sys$setast(1));
4433          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4434      }
4435      retsts = info->completion;
4436
4437     /* remove from list of open pipes */
4438     _ckvmssts(sys$setast(0));
4439     if (last) last->next = info->next;
4440     else open_pipes = info->next;
4441     _ckvmssts(sys$setast(1));
4442
4443     /* free buffers and structures */
4444
4445     if (info->in) {
4446         if (info->in->buf) {
4447             n = info->in->bufsize * sizeof(char);
4448             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4449         }
4450         n = sizeof(Pipe);
4451         _ckvmssts(lib$free_vm(&n, &info->in));
4452     }
4453     if (info->out) {
4454         if (info->out->buf) {
4455             n = info->out->bufsize * sizeof(char);
4456             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4457         }
4458         n = sizeof(Pipe);
4459         _ckvmssts(lib$free_vm(&n, &info->out));
4460     }
4461     if (info->err) {
4462         if (info->err->buf) {
4463             n = info->err->bufsize * sizeof(char);
4464             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4465         }
4466         n = sizeof(Pipe);
4467         _ckvmssts(lib$free_vm(&n, &info->err));
4468     }
4469     n = sizeof(Info);
4470     _ckvmssts(lib$free_vm(&n, &info));
4471
4472     return retsts;
4473
4474 }  /* end of my_pclose() */
4475
4476 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4477   /* Roll our own prototype because we want this regardless of whether
4478    * _VMS_WAIT is defined.
4479    */
4480   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4481 #endif
4482 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4483    created with popen(); otherwise partially emulate waitpid() unless
4484    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4485    Also check processes not considered by the CRTL waitpid().
4486  */
4487 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4488 Pid_t
4489 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4490 {
4491     pInfo info;
4492     int done;
4493     int sts;
4494     int j;
4495
4496     if (statusp) *statusp = 0;
4497
4498     for (info = open_pipes; info != NULL; info = info->next)
4499         if (info->pid == pid) break;
4500
4501     if (info != NULL) {  /* we know about this child */
4502       while (!info->done) {
4503           _ckvmssts(sys$setast(0));
4504           done = info->done;
4505           if (!done) _ckvmssts(sys$clref(pipe_ef));
4506           _ckvmssts(sys$setast(1));
4507           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4508       }
4509
4510       if (statusp) *statusp = info->completion;
4511       return pid;
4512     }
4513
4514     /* child that already terminated? */
4515
4516     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4517         if (closed_list[j].pid == pid) {
4518             if (statusp) *statusp = closed_list[j].completion;
4519             return pid;
4520         }
4521     }
4522
4523     /* fall through if this child is not one of our own pipe children */
4524
4525 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4526
4527       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4528        * in 7.2 did we get a version that fills in the VMS completion
4529        * status as Perl has always tried to do.
4530        */
4531
4532       sts = __vms_waitpid( pid, statusp, flags );
4533
4534       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4535          return sts;
4536
4537       /* If the real waitpid tells us the child does not exist, we
4538        * fall through here to implement waiting for a child that
4539        * was created by some means other than exec() (say, spawned
4540        * from DCL) or to wait for a process that is not a subprocess
4541        * of the current process.
4542        */
4543
4544 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4545
4546     {
4547       $DESCRIPTOR(intdsc,"0 00:00:01");
4548       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4549       unsigned long int pidcode = JPI$_PID, mypid;
4550       unsigned long int interval[2];
4551       unsigned int jpi_iosb[2];
4552       struct itmlst_3 jpilist[2] = {
4553           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4554           {                      0,         0,                 0, 0}
4555       };
4556
4557       if (pid <= 0) {
4558         /* Sorry folks, we don't presently implement rooting around for
4559            the first child we can find, and we definitely don't want to
4560            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4561          */
4562         set_errno(ENOTSUP);
4563         return -1;
4564       }
4565
4566       /* Get the owner of the child so I can warn if it's not mine. If the
4567        * process doesn't exist or I don't have the privs to look at it,
4568        * I can go home early.
4569        */
4570       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4571       if (sts & 1) sts = jpi_iosb[0];
4572       if (!(sts & 1)) {
4573         switch (sts) {
4574             case SS$_NONEXPR:
4575                 set_errno(ECHILD);
4576                 break;
4577             case SS$_NOPRIV:
4578                 set_errno(EACCES);
4579                 break;
4580             default:
4581                 _ckvmssts(sts);
4582         }
4583         set_vaxc_errno(sts);
4584         return -1;
4585       }
4586
4587       if (ckWARN(WARN_EXEC)) {
4588         /* remind folks they are asking for non-standard waitpid behavior */
4589         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4590         if (ownerpid != mypid)
4591           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4592                       "waitpid: process %x is not a child of process %x",
4593                       pid,mypid);
4594       }
4595
4596       /* simply check on it once a second until it's not there anymore. */
4597
4598       _ckvmssts(sys$bintim(&intdsc,interval));
4599       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4600             _ckvmssts(sys$schdwk(0,0,interval,0));
4601             _ckvmssts(sys$hiber());
4602       }
4603       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4604
4605       _ckvmssts(sts);
4606       return pid;
4607     }
4608 }  /* end of waitpid() */
4609 /*}}}*/
4610 /*}}}*/
4611 /*}}}*/
4612
4613 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4614 char *
4615 my_gconvert(double val, int ndig, int trail, char *buf)
4616 {
4617   static char __gcvtbuf[DBL_DIG+1];
4618   char *loc;
4619
4620   loc = buf ? buf : __gcvtbuf;
4621
4622 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4623   if (val < 1) {
4624     sprintf(loc,"%.*g",ndig,val);
4625     return loc;
4626   }
4627 #endif
4628
4629   if (val) {
4630     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4631     return gcvt(val,ndig,loc);
4632   }
4633   else {
4634     loc[0] = '0'; loc[1] = '\0';
4635     return loc;
4636   }
4637
4638 }
4639 /*}}}*/
4640
4641 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4642 static int rms_free_search_context(struct FAB * fab)
4643 {
4644 struct NAM * nam;
4645
4646     nam = fab->fab$l_nam;
4647     nam->nam$b_nop |= NAM$M_SYNCHK;
4648     nam->nam$l_rlf = NULL;
4649     fab->fab$b_dns = 0;
4650     return sys$parse(fab, NULL, NULL);
4651 }
4652
4653 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4654 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4655 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4656 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4657 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4658 #define rms_nam_esll(nam) nam.nam$b_esl
4659 #define rms_nam_esl(nam) nam.nam$b_esl
4660 #define rms_nam_name(nam) nam.nam$l_name
4661 #define rms_nam_namel(nam) nam.nam$l_name
4662 #define rms_nam_type(nam) nam.nam$l_type
4663 #define rms_nam_typel(nam) nam.nam$l_type
4664 #define rms_nam_ver(nam) nam.nam$l_ver
4665 #define rms_nam_verl(nam) nam.nam$l_ver
4666 #define rms_nam_rsll(nam) nam.nam$b_rsl
4667 #define rms_nam_rsl(nam) nam.nam$b_rsl
4668 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4669 #define rms_set_fna(fab, nam, name, size) \
4670         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4671 #define rms_get_fna(fab, nam) fab.fab$l_fna
4672 #define rms_set_dna(fab, nam, name, size) \
4673         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4674 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4675 #define rms_set_esa(fab, nam, name, size) \
4676         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4677 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4678         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4679 #define rms_set_rsa(nam, name, size) \
4680         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4681 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4682         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4683 #define rms_nam_name_type_l_size(nam) \
4684         (nam.nam$b_name + nam.nam$b_type)
4685 #else
4686 static int rms_free_search_context(struct FAB * fab)
4687 {
4688 struct NAML * nam;
4689
4690     nam = fab->fab$l_naml;
4691     nam->naml$b_nop |= NAM$M_SYNCHK;
4692     nam->naml$l_rlf = NULL;
4693     nam->naml$l_long_defname_size = 0;
4694
4695     fab->fab$b_dns = 0;
4696     return sys$parse(fab, NULL, NULL);
4697 }
4698
4699 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4700 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4701 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4702 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4703 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4704 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4705 #define rms_nam_esl(nam) nam.naml$b_esl
4706 #define rms_nam_name(nam) nam.naml$l_name
4707 #define rms_nam_namel(nam) nam.naml$l_long_name
4708 #define rms_nam_type(nam) nam.naml$l_type
4709 #define rms_nam_typel(nam) nam.naml$l_long_type
4710 #define rms_nam_ver(nam) nam.naml$l_ver
4711 #define rms_nam_verl(nam) nam.naml$l_long_ver
4712 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4713 #define rms_nam_rsl(nam) nam.naml$b_rsl
4714 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4715 #define rms_set_fna(fab, nam, name, size) \
4716         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4717         nam.naml$l_long_filename_size = size; \
4718         nam.naml$l_long_filename = name;}
4719 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4720 #define rms_set_dna(fab, nam, name, size) \
4721         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4722         nam.naml$l_long_defname_size = size; \
4723         nam.naml$l_long_defname = name; }
4724 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4725 #define rms_set_esa(fab, nam, name, size) \
4726         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4727         nam.naml$l_long_expand_alloc = size; \
4728         nam.naml$l_long_expand = name; }
4729 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4730         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4731         nam.naml$l_long_expand = l_name; \
4732         nam.naml$l_long_expand_alloc = l_size; }
4733 #define rms_set_rsa(nam, name, size) \
4734         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4735         nam.naml$l_long_result = name; \
4736         nam.naml$l_long_result_alloc = size; }
4737 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4738         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4739         nam.naml$l_long_result = l_name; \
4740         nam.naml$l_long_result_alloc = l_size; }
4741 #define rms_nam_name_type_l_size(nam) \
4742         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4743 #endif
4744
4745
4746 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4747 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4748  * to expand file specification.  Allows for a single default file
4749  * specification and a simple mask of options.  If outbuf is non-NULL,
4750  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4751  * the resultant file specification is placed.  If outbuf is NULL, the
4752  * resultant file specification is placed into a static buffer.
4753  * The third argument, if non-NULL, is taken to be a default file
4754  * specification string.  The fourth argument is unused at present.
4755  * rmesexpand() returns the address of the resultant string if
4756  * successful, and NULL on error.
4757  *
4758  * New functionality for previously unused opts value:
4759  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4760  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
4761  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4762  */
4763 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4764
4765 static char *
4766 mp_do_rmsexpand
4767    (pTHX_ const char *filespec,
4768     char *outbuf,
4769     int ts,
4770     const char *defspec,
4771     unsigned opts,
4772     int * fs_utf8,
4773     int * dfs_utf8)
4774 {
4775   static char __rmsexpand_retbuf[VMS_MAXRSS];
4776   char * vmsfspec, *tmpfspec;
4777   char * esa, *cp, *out = NULL;
4778   char * tbuf;
4779   char * esal = NULL;
4780   char * outbufl;
4781   struct FAB myfab = cc$rms_fab;
4782   rms_setup_nam(mynam);
4783   STRLEN speclen;
4784   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4785   int sts;
4786
4787   /* temp hack until UTF8 is actually implemented */
4788   if (fs_utf8 != NULL)
4789     *fs_utf8 = 0;
4790
4791   if (!filespec || !*filespec) {
4792     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4793     return NULL;
4794   }
4795   if (!outbuf) {
4796     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4797     else    outbuf = __rmsexpand_retbuf;
4798   }
4799
4800   vmsfspec = NULL;
4801   tmpfspec = NULL;
4802   outbufl = NULL;
4803
4804   isunix = 0;
4805   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4806     isunix = is_unix_filespec(filespec);
4807     if (isunix) {
4808       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4809       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4810       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4811         PerlMem_free(vmsfspec);
4812         if (out)
4813            Safefree(out);
4814         return NULL;
4815       }
4816       filespec = vmsfspec;
4817
4818       /* Unless we are forcing to VMS format, a UNIX input means
4819        * UNIX output, and that requires long names to be used
4820        */
4821       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4822         opts |= PERL_RMSEXPAND_M_LONG;
4823       else {
4824         isunix = 0;
4825       }
4826     }
4827   }
4828
4829   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4830   rms_bind_fab_nam(myfab, mynam);
4831
4832   if (defspec && *defspec) {
4833     int t_isunix;
4834     t_isunix = is_unix_filespec(defspec);
4835     if (t_isunix) {
4836       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4837       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4838       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4839         PerlMem_free(tmpfspec);
4840         if (vmsfspec != NULL)
4841             PerlMem_free(vmsfspec);
4842         if (out)
4843            Safefree(out);
4844         return NULL;
4845       }
4846       defspec = tmpfspec;
4847     }
4848     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4849   }
4850
4851   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4852   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4853 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4854   esal = PerlMem_malloc(VMS_MAXRSS);
4855   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4856 #endif
4857   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4858
4859   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4860     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4861   }
4862   else {
4863 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4864     outbufl = PerlMem_malloc(VMS_MAXRSS);
4865     if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4866     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4867 #else
4868     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4869 #endif
4870   }
4871
4872 #ifdef NAM$M_NO_SHORT_UPCASE
4873   if (decc_efs_case_preserve)
4874     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4875 #endif
4876
4877   /* First attempt to parse as an existing file */
4878   retsts = sys$parse(&myfab,0,0);
4879   if (!(retsts & STS$K_SUCCESS)) {
4880
4881     /* Could not find the file, try as syntax only if error is not fatal */
4882     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4883     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4884       retsts = sys$parse(&myfab,0,0);
4885       if (retsts & STS$K_SUCCESS) goto expanded;
4886     }
4887
4888      /* Still could not parse the file specification */
4889     /*----------------------------------------------*/
4890     sts = rms_free_search_context(&myfab); /* Free search context */
4891     if (out) Safefree(out);
4892     if (tmpfspec != NULL)
4893         PerlMem_free(tmpfspec);
4894     if (vmsfspec != NULL)
4895         PerlMem_free(vmsfspec);
4896     if (outbufl != NULL)
4897         PerlMem_free(outbufl);
4898     PerlMem_free(esa);
4899     if (esal != NULL)
4900         PerlMem_free(esal);
4901     set_vaxc_errno(retsts);
4902     if      (retsts == RMS$_PRV) set_errno(EACCES);
4903     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4904     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4905     else                         set_errno(EVMSERR);
4906     return NULL;
4907   }
4908   retsts = sys$search(&myfab,0,0);
4909   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4910     sts = rms_free_search_context(&myfab); /* Free search context */
4911     if (out) Safefree(out);
4912     if (tmpfspec != NULL)
4913         PerlMem_free(tmpfspec);
4914     if (vmsfspec != NULL)
4915         PerlMem_free(vmsfspec);
4916     if (outbufl != NULL)
4917         PerlMem_free(outbufl);
4918     PerlMem_free(esa);
4919     if (esal != NULL)
4920         PerlMem_free(esal);
4921     set_vaxc_errno(retsts);
4922     if      (retsts == RMS$_PRV) set_errno(EACCES);
4923     else                         set_errno(EVMSERR);
4924     return NULL;
4925   }
4926
4927   /* If the input filespec contained any lowercase characters,
4928    * downcase the result for compatibility with Unix-minded code. */
4929   expanded:
4930   if (!decc_efs_case_preserve) {
4931     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4932       if (islower(*tbuf)) { haslower = 1; break; }
4933   }
4934
4935    /* Is a long or a short name expected */
4936   /*------------------------------------*/
4937   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4938     if (rms_nam_rsll(mynam)) {
4939         tbuf = outbuf;
4940         speclen = rms_nam_rsll(mynam);
4941     }
4942     else {
4943         tbuf = esal; /* Not esa */
4944         speclen = rms_nam_esll(mynam);
4945     }
4946   }
4947   else {
4948     if (rms_nam_rsl(mynam)) {
4949         tbuf = outbuf;
4950         speclen = rms_nam_rsl(mynam);
4951     }
4952     else {
4953         tbuf = esa; /* Not esal */
4954         speclen = rms_nam_esl(mynam);
4955     }
4956   }
4957   tbuf[speclen] = '\0';
4958
4959   /* Trim off null fields added by $PARSE
4960    * If type > 1 char, must have been specified in original or default spec
4961    * (not true for version; $SEARCH may have added version of existing file).
4962    */
4963   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4964   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4965     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4966              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4967   }
4968   else {
4969     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4970              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4971   }
4972   if (trimver || trimtype) {
4973     if (defspec && *defspec) {
4974       char *defesal = NULL;
4975       defesal = PerlMem_malloc(VMS_MAXRSS + 1);
4976       if (defesal != NULL) {
4977         struct FAB deffab = cc$rms_fab;
4978         rms_setup_nam(defnam);
4979
4980         rms_bind_fab_nam(deffab, defnam);
4981
4982         /* Cast ok */
4983         rms_set_fna
4984             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4985
4986         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4987
4988         rms_clear_nam_nop(defnam);
4989         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4990 #ifdef NAM$M_NO_SHORT_UPCASE
4991         if (decc_efs_case_preserve)
4992           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4993 #endif
4994         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4995           if (trimver) {
4996              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4997           }
4998           if (trimtype) {
4999             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5000           }
5001         }
5002         PerlMem_free(defesal);
5003       }
5004     }
5005     if (trimver) {
5006       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5007         if (*(rms_nam_verl(mynam)) != '\"')
5008           speclen = rms_nam_verl(mynam) - tbuf;
5009       }
5010       else {
5011         if (*(rms_nam_ver(mynam)) != '\"')
5012           speclen = rms_nam_ver(mynam) - tbuf;
5013       }
5014     }
5015     if (trimtype) {
5016       /* If we didn't already trim version, copy down */
5017       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5018         if (speclen > rms_nam_verl(mynam) - tbuf)
5019           memmove
5020            (rms_nam_typel(mynam),
5021             rms_nam_verl(mynam),
5022             speclen - (rms_nam_verl(mynam) - tbuf));
5023           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5024       }
5025       else {
5026         if (speclen > rms_nam_ver(mynam) - tbuf)
5027           memmove
5028            (rms_nam_type(mynam),
5029             rms_nam_ver(mynam),
5030             speclen - (rms_nam_ver(mynam) - tbuf));
5031           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5032       }
5033     }
5034   }
5035
5036    /* Done with these copies of the input files */
5037   /*-------------------------------------------*/
5038   if (vmsfspec != NULL)
5039         PerlMem_free(vmsfspec);
5040   if (tmpfspec != NULL)
5041         PerlMem_free(tmpfspec);
5042
5043   /* If we just had a directory spec on input, $PARSE "helpfully"
5044    * adds an empty name and type for us */
5045   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5046     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5047         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5048         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5049       speclen = rms_nam_namel(mynam) - tbuf;
5050   }
5051   else {
5052     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5053         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5054         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5055       speclen = rms_nam_name(mynam) - tbuf;
5056   }
5057
5058   /* Posix format specifications must have matching quotes */
5059   if (speclen < (VMS_MAXRSS - 1)) {
5060     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5061       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5062         tbuf[speclen] = '\"';
5063         speclen++;
5064       }
5065     }
5066   }
5067   tbuf[speclen] = '\0';
5068   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5069
5070   /* Have we been working with an expanded, but not resultant, spec? */
5071   /* Also, convert back to Unix syntax if necessary. */
5072
5073   if (!rms_nam_rsll(mynam)) {
5074     if (isunix) {
5075       if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
5076         if (out) Safefree(out);
5077         if (esal != NULL)
5078             PerlMem_free(esal);
5079         PerlMem_free(esa);
5080         if (outbufl != NULL)
5081             PerlMem_free(outbufl);
5082         return NULL;
5083       }
5084     }
5085     else strcpy(outbuf,esa);
5086   }
5087   else if (isunix) {
5088     tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5089     if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5090     if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
5091         if (out) Safefree(out);
5092         PerlMem_free(esa);
5093         if (esal != NULL)
5094             PerlMem_free(esal);
5095         PerlMem_free(tmpfspec);
5096         if (outbufl != NULL)
5097             PerlMem_free(outbufl);
5098         return NULL;
5099     }
5100     strcpy(outbuf,tmpfspec);
5101     PerlMem_free(tmpfspec);
5102   }
5103
5104   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5105   sts = rms_free_search_context(&myfab); /* Free search context */
5106   PerlMem_free(esa);
5107   if (esal != NULL)
5108      PerlMem_free(esal);
5109   if (outbufl != NULL)
5110      PerlMem_free(outbufl);
5111   return outbuf;
5112 }
5113 /*}}}*/
5114 /* External entry points */
5115 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5116 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5117 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5118 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5119 char *Perl_rmsexpand_utf8
5120   (pTHX_ const char *spec, char *buf, const char *def,
5121    unsigned opt, int * fs_utf8, int * dfs_utf8)
5122 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5123 char *Perl_rmsexpand_utf8_ts
5124   (pTHX_ const char *spec, char *buf, const char *def,
5125    unsigned opt, int * fs_utf8, int * dfs_utf8)
5126 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5127
5128
5129 /*
5130 ** The following routines are provided to make life easier when
5131 ** converting among VMS-style and Unix-style directory specifications.
5132 ** All will take input specifications in either VMS or Unix syntax. On
5133 ** failure, all return NULL.  If successful, the routines listed below
5134 ** return a pointer to a buffer containing the appropriately
5135 ** reformatted spec (and, therefore, subsequent calls to that routine
5136 ** will clobber the result), while the routines of the same names with
5137 ** a _ts suffix appended will return a pointer to a mallocd string
5138 ** containing the appropriately reformatted spec.
5139 ** In all cases, only explicit syntax is altered; no check is made that
5140 ** the resulting string is valid or that the directory in question
5141 ** actually exists.
5142 **
5143 **   fileify_dirspec() - convert a directory spec into the name of the
5144 **     directory file (i.e. what you can stat() to see if it's a dir).
5145 **     The style (VMS or Unix) of the result is the same as the style
5146 **     of the parameter passed in.
5147 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5148 **     what you prepend to a filename to indicate what directory it's in).
5149 **     The style (VMS or Unix) of the result is the same as the style
5150 **     of the parameter passed in.
5151 **   tounixpath() - convert a directory spec into a Unix-style path.
5152 **   tovmspath() - convert a directory spec into a VMS-style path.
5153 **   tounixspec() - convert any file spec into a Unix-style file spec.
5154 **   tovmsspec() - convert any file spec into a VMS-style spec.
5155 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5156 **
5157 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5158 ** Permission is given to distribute this code as part of the Perl
5159 ** standard distribution under the terms of the GNU General Public
5160 ** License or the Perl Artistic License.  Copies of each may be
5161 ** found in the Perl standard distribution.
5162  */
5163
5164 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5165 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5166 {
5167     static char __fileify_retbuf[VMS_MAXRSS];
5168     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5169     char *retspec, *cp1, *cp2, *lastdir;
5170     char *trndir, *vmsdir;
5171     unsigned short int trnlnm_iter_count;
5172     int sts;
5173     if (utf8_fl != NULL)
5174         *utf8_fl = 0;
5175
5176     if (!dir || !*dir) {
5177       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5178     }
5179     dirlen = strlen(dir);
5180     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5181     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5182       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5183         dir = "/sys$disk";
5184         dirlen = 9;
5185       }
5186       else
5187         dirlen = 1;
5188     }
5189     if (dirlen > (VMS_MAXRSS - 1)) {
5190       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5191       return NULL;
5192     }
5193     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5194     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5195     if (!strpbrk(dir+1,"/]>:")  &&
5196         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5197       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5198       trnlnm_iter_count = 0;
5199       while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5200         trnlnm_iter_count++;
5201         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5202       }
5203       dirlen = strlen(trndir);
5204     }
5205     else {
5206       strncpy(trndir,dir,dirlen);
5207       trndir[dirlen] = '\0';
5208     }
5209
5210     /* At this point we are done with *dir and use *trndir which is a
5211      * copy that can be modified.  *dir must not be modified.
5212      */
5213
5214     /* If we were handed a rooted logical name or spec, treat it like a
5215      * simple directory, so that
5216      *    $ Define myroot dev:[dir.]
5217      *    ... do_fileify_dirspec("myroot",buf,1) ...
5218      * does something useful.
5219      */
5220     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5221       trndir[--dirlen] = '\0';
5222       trndir[dirlen-1] = ']';
5223     }
5224     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5225       trndir[--dirlen] = '\0';
5226       trndir[dirlen-1] = '>';
5227     }
5228
5229     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5230       /* If we've got an explicit filename, we can just shuffle the string. */
5231       if (*(cp1+1)) hasfilename = 1;
5232       /* Similarly, we can just back up a level if we've got multiple levels
5233          of explicit directories in a VMS spec which ends with directories. */
5234       else {
5235         for (cp2 = cp1; cp2 > trndir; cp2--) {
5236           if (*cp2 == '.') {
5237             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5238 /* fix-me, can not scan EFS file specs backward like this */
5239               *cp2 = *cp1; *cp1 = '\0';
5240               hasfilename = 1;
5241               break;
5242             }
5243           }
5244           if (*cp2 == '[' || *cp2 == '<') break;
5245         }
5246       }
5247     }
5248
5249     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5250     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5251     cp1 = strpbrk(trndir,"]:>");
5252     if (hasfilename || !cp1) { /* Unix-style path or filename */
5253       if (trndir[0] == '.') {
5254         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5255           PerlMem_free(trndir);
5256           PerlMem_free(vmsdir);
5257           return do_fileify_dirspec("[]",buf,ts,NULL);
5258         }
5259         else if (trndir[1] == '.' &&
5260                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5261           PerlMem_free(trndir);
5262           PerlMem_free(vmsdir);
5263           return do_fileify_dirspec("[-]",buf,ts,NULL);
5264         }
5265       }
5266       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5267         dirlen -= 1;                 /* to last element */
5268         lastdir = strrchr(trndir,'/');
5269       }
5270       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5271         /* If we have "/." or "/..", VMSify it and let the VMS code
5272          * below expand it, rather than repeating the code to handle
5273          * relative components of a filespec here */
5274         do {
5275           if (*(cp1+2) == '.') cp1++;
5276           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5277             char * ret_chr;
5278             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5279                 PerlMem_free(trndir);
5280                 PerlMem_free(vmsdir);
5281                 return NULL;
5282             }
5283             if (strchr(vmsdir,'/') != NULL) {
5284               /* If do_tovmsspec() returned it, it must have VMS syntax
5285                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5286                * the time to check this here only so we avoid a recursion
5287                * loop; otherwise, gigo.
5288                */
5289               PerlMem_free(trndir);
5290               PerlMem_free(vmsdir);
5291               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5292               return NULL;
5293             }
5294             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5295                 PerlMem_free(trndir);
5296                 PerlMem_free(vmsdir);
5297                 return NULL;
5298             }
5299             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5300             PerlMem_free(trndir);
5301             PerlMem_free(vmsdir);
5302             return ret_chr;
5303           }
5304           cp1++;
5305         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5306         lastdir = strrchr(trndir,'/');
5307       }
5308       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5309         char * ret_chr;
5310         /* Ditto for specs that end in an MFD -- let the VMS code
5311          * figure out whether it's a real device or a rooted logical. */
5312
5313         /* This should not happen any more.  Allowing the fake /000000
5314          * in a UNIX pathname causes all sorts of problems when trying
5315          * to run in UNIX emulation.  So the VMS to UNIX conversions
5316          * now remove the fake /000000 directories.
5317          */
5318
5319         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5320         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5321             PerlMem_free(trndir);
5322             PerlMem_free(vmsdir);
5323             return NULL;
5324         }
5325         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5326             PerlMem_free(trndir);
5327             PerlMem_free(vmsdir);
5328             return NULL;
5329         }
5330         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5331         PerlMem_free(trndir);
5332         PerlMem_free(vmsdir);
5333         return ret_chr;
5334       }
5335       else {
5336
5337         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5338              !(lastdir = cp1 = strrchr(trndir,']')) &&
5339              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5340         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5341           int ver; char *cp3;
5342
5343           /* For EFS or ODS-5 look for the last dot */
5344           if (decc_efs_charset) {
5345               cp2 = strrchr(cp1,'.');
5346           }
5347           if (vms_process_case_tolerant) {
5348               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5349                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5350                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5351                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5352                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5353                             (ver || *cp3)))))) {
5354                   PerlMem_free(trndir);
5355                   PerlMem_free(vmsdir);
5356                   set_errno(ENOTDIR);
5357                   set_vaxc_errno(RMS$_DIR);
5358                   return NULL;
5359               }
5360           }
5361           else {
5362               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5363                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5364                   !*(cp2+3) || *(cp2+3) != 'R' ||
5365                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5366                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5367                             (ver || *cp3)))))) {
5368                  PerlMem_free(trndir);
5369                  PerlMem_free(vmsdir);
5370                  set_errno(ENOTDIR);
5371                  set_vaxc_errno(RMS$_DIR);
5372                  return NULL;
5373               }
5374           }
5375           dirlen = cp2 - trndir;
5376         }
5377       }
5378
5379       retlen = dirlen + 6;
5380       if (buf) retspec = buf;
5381       else if (ts) Newx(retspec,retlen+1,char);
5382       else retspec = __fileify_retbuf;
5383       memcpy(retspec,trndir,dirlen);
5384       retspec[dirlen] = '\0';
5385
5386       /* We've picked up everything up to the directory file name.
5387          Now just add the type and version, and we're set. */
5388       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5389         strcat(retspec,".dir;1");
5390       else
5391         strcat(retspec,".DIR;1");
5392       PerlMem_free(trndir);
5393       PerlMem_free(vmsdir);
5394       return retspec;
5395     }
5396     else {  /* VMS-style directory spec */
5397
5398       char *esa, term, *cp;
5399       unsigned long int sts, cmplen, haslower = 0;
5400       unsigned int nam_fnb;
5401       char * nam_type;
5402       struct FAB dirfab = cc$rms_fab;
5403       rms_setup_nam(savnam);
5404       rms_setup_nam(dirnam);
5405
5406       esa = PerlMem_malloc(VMS_MAXRSS + 1);
5407       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5408       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5409       rms_bind_fab_nam(dirfab, dirnam);
5410       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5411       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5412 #ifdef NAM$M_NO_SHORT_UPCASE
5413       if (decc_efs_case_preserve)
5414         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5415 #endif
5416
5417       for (cp = trndir; *cp; cp++)
5418         if (islower(*cp)) { haslower = 1; break; }
5419       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5420         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5421           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5422           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5423         }
5424         if (!sts) {
5425           PerlMem_free(esa);
5426           PerlMem_free(trndir);
5427           PerlMem_free(vmsdir);
5428           set_errno(EVMSERR);
5429           set_vaxc_errno(dirfab.fab$l_sts);
5430           return NULL;
5431         }
5432       }
5433       else {
5434         savnam = dirnam;
5435         /* Does the file really exist? */
5436         if (sys$search(&dirfab)& STS$K_SUCCESS) {
5437           /* Yes; fake the fnb bits so we'll check type below */
5438         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5439         }
5440         else { /* No; just work with potential name */
5441           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5442           else {
5443             int fab_sts;
5444             fab_sts = dirfab.fab$l_sts;
5445             sts = rms_free_search_context(&dirfab);
5446             PerlMem_free(esa);
5447             PerlMem_free(trndir);
5448             PerlMem_free(vmsdir);
5449             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
5450             return NULL;
5451           }
5452         }
5453       }
5454       esa[rms_nam_esll(dirnam)] = '\0';
5455       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5456         cp1 = strchr(esa,']');
5457         if (!cp1) cp1 = strchr(esa,'>');
5458         if (cp1) {  /* Should always be true */
5459           rms_nam_esll(dirnam) -= cp1 - esa - 1;
5460           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5461         }
5462       }
5463       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5464         /* Yep; check version while we're at it, if it's there. */
5465         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5466         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5467           /* Something other than .DIR[;1].  Bzzt. */
5468           sts = rms_free_search_context(&dirfab);
5469           PerlMem_free(esa);
5470           PerlMem_free(trndir);
5471           PerlMem_free(vmsdir);
5472           set_errno(ENOTDIR);
5473           set_vaxc_errno(RMS$_DIR);
5474           return NULL;
5475         }
5476       }
5477
5478       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5479         /* They provided at least the name; we added the type, if necessary, */
5480         if (buf) retspec = buf;                            /* in sys$parse() */
5481         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5482         else retspec = __fileify_retbuf;
5483         strcpy(retspec,esa);
5484         sts = rms_free_search_context(&dirfab);
5485         PerlMem_free(trndir);
5486         PerlMem_free(esa);
5487         PerlMem_free(vmsdir);
5488         return retspec;
5489       }
5490       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5491         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5492         *cp1 = '\0';
5493         rms_nam_esll(dirnam) -= 9;
5494       }
5495       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5496       if (cp1 == NULL) { /* should never happen */
5497         sts = rms_free_search_context(&dirfab);
5498         PerlMem_free(trndir);
5499         PerlMem_free(esa);
5500         PerlMem_free(vmsdir);
5501         return NULL;
5502       }
5503       term = *cp1;
5504       *cp1 = '\0';
5505       retlen = strlen(esa);
5506       cp1 = strrchr(esa,'.');
5507       /* ODS-5 directory specifications can have extra "." in them. */
5508       /* Fix-me, can not scan EFS file specifications backwards */
5509       while (cp1 != NULL) {
5510         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5511           break;
5512         else {
5513            cp1--;
5514            while ((cp1 > esa) && (*cp1 != '.'))
5515              cp1--;
5516         }
5517         if (cp1 == esa)
5518           cp1 = NULL;
5519       }
5520
5521       if ((cp1) != NULL) {
5522         /* There's more than one directory in the path.  Just roll back. */
5523         *cp1 = term;
5524         if (buf) retspec = buf;
5525         else if (ts) Newx(retspec,retlen+7,char);
5526         else retspec = __fileify_retbuf;
5527         strcpy(retspec,esa);
5528       }
5529       else {
5530         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5531           /* Go back and expand rooted logical name */
5532           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5533 #ifdef NAM$M_NO_SHORT_UPCASE
5534           if (decc_efs_case_preserve)
5535             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5536 #endif
5537           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5538             sts = rms_free_search_context(&dirfab);
5539             PerlMem_free(esa);
5540             PerlMem_free(trndir);
5541             PerlMem_free(vmsdir);
5542             set_errno(EVMSERR);
5543             set_vaxc_errno(dirfab.fab$l_sts);
5544             return NULL;
5545           }
5546           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5547           if (buf) retspec = buf;
5548           else if (ts) Newx(retspec,retlen+16,char);
5549           else retspec = __fileify_retbuf;
5550           cp1 = strstr(esa,"][");
5551           if (!cp1) cp1 = strstr(esa,"]<");
5552           dirlen = cp1 - esa;
5553           memcpy(retspec,esa,dirlen);
5554           if (!strncmp(cp1+2,"000000]",7)) {
5555             retspec[dirlen-1] = '\0';
5556             /* fix-me Not full ODS-5, just extra dots in directories for now */
5557             cp1 = retspec + dirlen - 1;
5558             while (cp1 > retspec)
5559             {
5560               if (*cp1 == '[')
5561                 break;
5562               if (*cp1 == '.') {
5563                 if (*(cp1-1) != '^')
5564                   break;
5565               }
5566               cp1--;
5567             }
5568             if (*cp1 == '.') *cp1 = ']';
5569             else {
5570               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5571               memmove(cp1+1,"000000]",7);
5572             }
5573           }
5574           else {
5575             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5576             retspec[retlen] = '\0';
5577             /* Convert last '.' to ']' */
5578             cp1 = retspec+retlen-1;
5579             while (*cp != '[') {
5580               cp1--;
5581               if (*cp1 == '.') {
5582                 /* Do not trip on extra dots in ODS-5 directories */
5583                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5584                 break;
5585               }
5586             }
5587             if (*cp1 == '.') *cp1 = ']';
5588             else {
5589               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5590               memmove(cp1+1,"000000]",7);
5591             }
5592           }
5593         }
5594         else {  /* This is a top-level dir.  Add the MFD to the path. */
5595           if (buf) retspec = buf;
5596           else if (ts) Newx(retspec,retlen+16,char);
5597           else retspec = __fileify_retbuf;
5598           cp1 = esa;
5599           cp2 = retspec;
5600           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5601           strcpy(cp2,":[000000]");
5602           cp1 += 2;
5603           strcpy(cp2+9,cp1);
5604         }
5605       }
5606       sts = rms_free_search_context(&dirfab);
5607       /* We've set up the string up through the filename.  Add the
5608          type and version, and we're done. */
5609       strcat(retspec,".DIR;1");
5610
5611       /* $PARSE may have upcased filespec, so convert output to lower
5612        * case if input contained any lowercase characters. */
5613       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5614       PerlMem_free(trndir);
5615       PerlMem_free(esa);
5616       PerlMem_free(vmsdir);
5617       return retspec;
5618     }
5619 }  /* end of do_fileify_dirspec() */
5620 /*}}}*/
5621 /* External entry points */
5622 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5623 { return do_fileify_dirspec(dir,buf,0,NULL); }
5624 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5625 { return do_fileify_dirspec(dir,buf,1,NULL); }
5626 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5627 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5628 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5629 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5630
5631 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5632 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5633 {
5634     static char __pathify_retbuf[VMS_MAXRSS];
5635     unsigned long int retlen;
5636     char *retpath, *cp1, *cp2, *trndir;
5637     unsigned short int trnlnm_iter_count;
5638     STRLEN trnlen;
5639     int sts;
5640     if (utf8_fl != NULL)
5641         *utf8_fl = 0;
5642
5643     if (!dir || !*dir) {
5644       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5645     }
5646
5647     trndir = PerlMem_malloc(VMS_MAXRSS);
5648     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5649     if (*dir) strcpy(trndir,dir);
5650     else getcwd(trndir,VMS_MAXRSS - 1);
5651
5652     trnlnm_iter_count = 0;
5653     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5654            && my_trnlnm(trndir,trndir,0)) {
5655       trnlnm_iter_count++;
5656       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5657       trnlen = strlen(trndir);
5658
5659       /* Trap simple rooted lnms, and return lnm:[000000] */
5660       if (!strcmp(trndir+trnlen-2,".]")) {
5661         if (buf) retpath = buf;
5662         else if (ts) Newx(retpath,strlen(dir)+10,char);
5663         else retpath = __pathify_retbuf;
5664         strcpy(retpath,dir);
5665         strcat(retpath,":[000000]");
5666         PerlMem_free(trndir);
5667         return retpath;
5668       }
5669     }
5670
5671     /* At this point we do not work with *dir, but the copy in
5672      * *trndir that is modifiable.
5673      */
5674
5675     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5676       if (*trndir == '.' && (*(trndir+1) == '\0' ||
5677                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5678         retlen = 2 + (*(trndir+1) != '\0');
5679       else {
5680         if ( !(cp1 = strrchr(trndir,'/')) &&
5681              !(cp1 = strrchr(trndir,']')) &&
5682              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5683         if ((cp2 = strchr(cp1,'.')) != NULL &&
5684             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
5685              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
5686               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5687               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5688           int ver; char *cp3;
5689
5690           /* For EFS or ODS-5 look for the last dot */
5691           if (decc_efs_charset) {
5692             cp2 = strrchr(cp1,'.');
5693           }
5694           if (vms_process_case_tolerant) {
5695               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5696                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5697                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5698                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5699                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5700                             (ver || *cp3)))))) {
5701                 PerlMem_free(trndir);
5702                 set_errno(ENOTDIR);
5703                 set_vaxc_errno(RMS$_DIR);
5704                 return NULL;
5705               }
5706           }
5707           else {
5708               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5709                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5710                   !*(cp2+3) || *(cp2+3) != 'R' ||
5711                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5712                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5713                             (ver || *cp3)))))) {
5714                 PerlMem_free(trndir);
5715                 set_errno(ENOTDIR);
5716                 set_vaxc_errno(RMS$_DIR);
5717                 return NULL;
5718               }
5719           }
5720           retlen = cp2 - trndir + 1;
5721         }
5722         else {  /* No file type present.  Treat the filename as a directory. */
5723           retlen = strlen(trndir) + 1;
5724         }
5725       }
5726       if (buf) retpath = buf;
5727       else if (ts) Newx(retpath,retlen+1,char);
5728       else retpath = __pathify_retbuf;
5729       strncpy(retpath, trndir, retlen-1);
5730       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5731         retpath[retlen-1] = '/';      /* with '/', add it. */
5732         retpath[retlen] = '\0';
5733       }
5734       else retpath[retlen-1] = '\0';
5735     }
5736     else {  /* VMS-style directory spec */
5737       char *esa, *cp;
5738       unsigned long int sts, cmplen, haslower;
5739       struct FAB dirfab = cc$rms_fab;
5740       int dirlen;
5741       rms_setup_nam(savnam);
5742       rms_setup_nam(dirnam);
5743
5744       /* If we've got an explicit filename, we can just shuffle the string. */
5745       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5746              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
5747         if ((cp2 = strchr(cp1,'.')) != NULL) {
5748           int ver; char *cp3;
5749           if (vms_process_case_tolerant) {
5750               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5751                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5752                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5753                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5754                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5755                             (ver || *cp3)))))) {
5756                PerlMem_free(trndir);
5757                set_errno(ENOTDIR);
5758                set_vaxc_errno(RMS$_DIR);
5759                return NULL;
5760              }
5761           }
5762           else {
5763               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5764                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5765                   !*(cp2+3) || *(cp2+3) != 'R' ||
5766                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5767                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5768                             (ver || *cp3)))))) {
5769                PerlMem_free(trndir);
5770                set_errno(ENOTDIR);
5771                set_vaxc_errno(RMS$_DIR);
5772                return NULL;
5773              }
5774           }
5775         }
5776         else {  /* No file type, so just draw name into directory part */
5777           for (cp2 = cp1; *cp2; cp2++) ;
5778         }
5779         *cp2 = *cp1;
5780         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5781         *cp1 = '.';
5782         /* We've now got a VMS 'path'; fall through */
5783       }
5784
5785       dirlen = strlen(trndir);
5786       if (trndir[dirlen-1] == ']' ||
5787           trndir[dirlen-1] == '>' ||
5788           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5789         if (buf) retpath = buf;
5790         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5791         else retpath = __pathify_retbuf;
5792         strcpy(retpath,trndir);
5793         PerlMem_free(trndir);
5794         return retpath;
5795       }
5796       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5797       esa = PerlMem_malloc(VMS_MAXRSS);
5798       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5799       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5800       rms_bind_fab_nam(dirfab, dirnam);
5801       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5802 #ifdef NAM$M_NO_SHORT_UPCASE
5803       if (decc_efs_case_preserve)
5804           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5805 #endif
5806
5807       for (cp = trndir; *cp; cp++)
5808         if (islower(*cp)) { haslower = 1; break; }
5809
5810       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5811         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5812           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5813           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5814         }
5815         if (!sts) {
5816           PerlMem_free(trndir);
5817           PerlMem_free(esa);
5818           set_errno(EVMSERR);
5819           set_vaxc_errno(dirfab.fab$l_sts);
5820           return NULL;
5821         }
5822       }
5823       else {
5824         savnam = dirnam;
5825         /* Does the file really exist? */
5826         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5827           if (dirfab.fab$l_sts != RMS$_FNF) {
5828             int sts1;
5829             sts1 = rms_free_search_context(&dirfab);
5830             PerlMem_free(trndir);
5831             PerlMem_free(esa);
5832             set_errno(EVMSERR);
5833             set_vaxc_errno(dirfab.fab$l_sts);
5834             return NULL;
5835           }
5836           dirnam = savnam; /* No; just work with potential name */
5837         }
5838       }
5839       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5840         /* Yep; check version while we're at it, if it's there. */
5841         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5842         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5843           int sts2;
5844           /* Something other than .DIR[;1].  Bzzt. */
5845           sts2 = rms_free_search_context(&dirfab);
5846           PerlMem_free(trndir);
5847           PerlMem_free(esa);
5848           set_errno(ENOTDIR);
5849           set_vaxc_errno(RMS$_DIR);
5850           return NULL;
5851         }
5852       }
5853       /* OK, the type was fine.  Now pull any file name into the
5854          directory path. */
5855       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5856       else {
5857         cp1 = strrchr(esa,'>');
5858         *(rms_nam_typel(dirnam)) = '>';
5859       }
5860       *cp1 = '.';
5861       *(rms_nam_typel(dirnam) + 1) = '\0';
5862       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5863       if (buf) retpath = buf;
5864       else if (ts) Newx(retpath,retlen,char);
5865       else retpath = __pathify_retbuf;
5866       strcpy(retpath,esa);
5867       PerlMem_free(esa);
5868       sts = rms_free_search_context(&dirfab);
5869       /* $PARSE may have upcased filespec, so convert output to lower
5870        * case if input contained any lowercase characters. */
5871       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5872     }
5873
5874     PerlMem_free(trndir);
5875     return retpath;
5876 }  /* end of do_pathify_dirspec() */
5877 /*}}}*/
5878 /* External entry points */
5879 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5880 { return do_pathify_dirspec(dir,buf,0,NULL); }
5881 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5882 { return do_pathify_dirspec(dir,buf,1,NULL); }
5883 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5884 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5885 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5886 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5887
5888 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5889 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5890 {
5891   static char __tounixspec_retbuf[VMS_MAXRSS];
5892   char *dirend, *rslt, *cp1, *cp3, *tmp;
5893   const char *cp2;
5894   int devlen, dirlen, retlen = VMS_MAXRSS;
5895   int expand = 1; /* guarantee room for leading and trailing slashes */
5896   unsigned short int trnlnm_iter_count;
5897   int cmp_rslt;
5898   if (utf8_fl != NULL)
5899     *utf8_fl = 0;
5900
5901   if (spec == NULL) return NULL;
5902   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5903   if (buf) rslt = buf;
5904   else if (ts) {
5905     Newx(rslt, VMS_MAXRSS, char);
5906   }
5907   else rslt = __tounixspec_retbuf;
5908
5909   /* New VMS specific format needs translation
5910    * glob passes filenames with trailing '\n' and expects this preserved.
5911    */
5912   if (decc_posix_compliant_pathnames) {
5913     if (strncmp(spec, "\"^UP^", 5) == 0) {
5914       char * uspec;
5915       char *tunix;
5916       int tunix_len;
5917       int nl_flag;
5918
5919       tunix = PerlMem_malloc(VMS_MAXRSS);
5920       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5921       strcpy(tunix, spec);
5922       tunix_len = strlen(tunix);
5923       nl_flag = 0;
5924       if (tunix[tunix_len - 1] == '\n') {
5925         tunix[tunix_len - 1] = '\"';
5926         tunix[tunix_len] = '\0';
5927         tunix_len--;
5928         nl_flag = 1;
5929       }
5930       uspec = decc$translate_vms(tunix);
5931       PerlMem_free(tunix);
5932       if ((int)uspec > 0) {
5933         strcpy(rslt,uspec);
5934         if (nl_flag) {
5935           strcat(rslt,"\n");
5936         }
5937         else {
5938           /* If we can not translate it, makemaker wants as-is */
5939           strcpy(rslt, spec);
5940         }
5941         return rslt;
5942       }
5943     }
5944   }
5945
5946   cmp_rslt = 0; /* Presume VMS */
5947   cp1 = strchr(spec, '/');
5948   if (cp1 == NULL)
5949     cmp_rslt = 0;
5950
5951     /* Look for EFS ^/ */
5952     if (decc_efs_charset) {
5953       while (cp1 != NULL) {
5954         cp2 = cp1 - 1;
5955         if (*cp2 != '^') {
5956           /* Found illegal VMS, assume UNIX */
5957           cmp_rslt = 1;
5958           break;
5959         }
5960       cp1++;
5961       cp1 = strchr(cp1, '/');
5962     }
5963   }
5964
5965   /* Look for "." and ".." */
5966   if (decc_filename_unix_report) {
5967     if (spec[0] == '.') {
5968       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5969         cmp_rslt = 1;
5970       }
5971       else {
5972         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5973           cmp_rslt = 1;
5974         }
5975       }
5976     }
5977   }
5978   /* This is already UNIX or at least nothing VMS understands */
5979   if (cmp_rslt) {
5980     strcpy(rslt,spec);
5981     return rslt;
5982   }
5983
5984   cp1 = rslt;
5985   cp2 = spec;
5986   dirend = strrchr(spec,']');
5987   if (dirend == NULL) dirend = strrchr(spec,'>');
5988   if (dirend == NULL) dirend = strchr(spec,':');
5989   if (dirend == NULL) {
5990     strcpy(rslt,spec);
5991     return rslt;
5992   }
5993
5994   /* Special case 1 - sys$posix_root = / */
5995 #if __CRTL_VER >= 70000000
5996   if (!decc_disable_posix_root) {
5997     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5998       *cp1 = '/';
5999       cp1++;
6000       cp2 = cp2 + 15;
6001       }
6002   }
6003 #endif
6004
6005   /* Special case 2 - Convert NLA0: to /dev/null */
6006 #if __CRTL_VER < 70000000
6007   cmp_rslt = strncmp(spec,"NLA0:", 5);
6008   if (cmp_rslt != 0)
6009      cmp_rslt = strncmp(spec,"nla0:", 5);
6010 #else
6011   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6012 #endif
6013   if (cmp_rslt == 0) {
6014     strcpy(rslt, "/dev/null");
6015     cp1 = cp1 + 9;
6016     cp2 = cp2 + 5;
6017     if (spec[6] != '\0') {
6018       cp1[9] == '/';
6019       cp1++;
6020       cp2++;
6021     }
6022   }
6023
6024    /* Also handle special case "SYS$SCRATCH:" */
6025 #if __CRTL_VER < 70000000
6026   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6027   if (cmp_rslt != 0)
6028      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6029 #else
6030   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6031 #endif
6032   tmp = PerlMem_malloc(VMS_MAXRSS);
6033   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6034   if (cmp_rslt == 0) {
6035   int islnm;
6036
6037     islnm = my_trnlnm(tmp, "TMP", 0);
6038     if (!islnm) {
6039       strcpy(rslt, "/tmp");
6040       cp1 = cp1 + 4;
6041       cp2 = cp2 + 12;
6042       if (spec[12] != '\0') {
6043         cp1[4] == '/';
6044         cp1++;
6045         cp2++;
6046       }
6047     }
6048   }
6049
6050   if (*cp2 != '[' && *cp2 != '<') {
6051     *(cp1++) = '/';
6052   }
6053   else {  /* the VMS spec begins with directories */
6054     cp2++;
6055     if (*cp2 == ']' || *cp2 == '>') {
6056       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6057       PerlMem_free(tmp);
6058       return rslt;
6059     }
6060     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6061       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6062         if (ts) Safefree(rslt);
6063         PerlMem_free(tmp);
6064         return NULL;
6065       }
6066       trnlnm_iter_count = 0;
6067       do {
6068         cp3 = tmp;
6069         while (*cp3 != ':' && *cp3) cp3++;
6070         *(cp3++) = '\0';
6071         if (strchr(cp3,']') != NULL) break;
6072         trnlnm_iter_count++;
6073         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6074       } while (vmstrnenv(tmp,tmp,0,fildev,0));
6075       if (ts && !buf &&
6076           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6077         retlen = devlen + dirlen;
6078         Renew(rslt,retlen+1+2*expand,char);
6079         cp1 = rslt;
6080       }
6081       cp3 = tmp;
6082       *(cp1++) = '/';
6083       while (*cp3) {
6084         *(cp1++) = *(cp3++);
6085         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6086             PerlMem_free(tmp);
6087             return NULL; /* No room */
6088         }
6089       }
6090       *(cp1++) = '/';
6091     }
6092     if ((*cp2 == '^')) {
6093         /* EFS file escape, pass the next character as is */
6094         /* Fix me: HEX encoding for UNICODE not implemented */
6095         cp2++;
6096     }
6097     else if ( *cp2 == '.') {
6098       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6099         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6100         cp2 += 3;
6101       }
6102       else cp2++;
6103     }
6104   }
6105   PerlMem_free(tmp);
6106   for (; cp2 <= dirend; cp2++) {
6107     if ((*cp2 == '^')) {
6108         /* EFS file escape, pass the next character as is */
6109         /* Fix me: HEX encoding for UNICODE not implemented */
6110         *(cp1++) = *(++cp2);
6111         /* An escaped dot stays as is -- don't convert to slash */
6112         if (*cp2 == '.') cp2++;
6113     }
6114     if (*cp2 == ':') {
6115       *(cp1++) = '/';
6116       if (*(cp2+1) == '[') cp2++;
6117     }
6118     else if (*cp2 == ']' || *cp2 == '>') {
6119       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6120     }
6121     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6122       *(cp1++) = '/';
6123       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6124         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6125                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6126         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6127             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6128       }
6129       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6130         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6131         cp2 += 2;
6132       }
6133     }
6134     else if (*cp2 == '-') {
6135       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6136         while (*cp2 == '-') {
6137           cp2++;
6138           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6139         }
6140         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6141           if (ts) Safefree(rslt);                        /* filespecs like */
6142           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
6143           return NULL;
6144         }
6145       }
6146       else *(cp1++) = *cp2;
6147     }
6148     else *(cp1++) = *cp2;
6149   }
6150   while (*cp2) {
6151     if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++;  /* '^.' --> '.' */
6152     *(cp1++) = *(cp2++);
6153   }
6154   *cp1 = '\0';
6155
6156   /* This still leaves /000000/ when working with a
6157    * VMS device root or concealed root.
6158    */
6159   {
6160   int ulen;
6161   char * zeros;
6162
6163       ulen = strlen(rslt);
6164
6165       /* Get rid of "000000/ in rooted filespecs */
6166       if (ulen > 7) {
6167         zeros = strstr(rslt, "/000000/");
6168         if (zeros != NULL) {
6169           int mlen;
6170           mlen = ulen - (zeros - rslt) - 7;
6171           memmove(zeros, &zeros[7], mlen);
6172           ulen = ulen - 7;
6173           rslt[ulen] = '\0';
6174         }
6175       }
6176   }
6177
6178   return rslt;
6179
6180 }  /* end of do_tounixspec() */
6181 /*}}}*/
6182 /* External entry points */
6183 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6184   { return do_tounixspec(spec,buf,0, NULL); }
6185 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6186   { return do_tounixspec(spec,buf,1, NULL); }
6187 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6188   { return do_tounixspec(spec,buf,0, utf8_fl); }
6189 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6190   { return do_tounixspec(spec,buf,1, utf8_fl); }
6191
6192 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6193
6194 /*
6195  This procedure is used to identify if a path is based in either
6196  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6197  it returns the OpenVMS format directory for it.
6198
6199  It is expecting specifications of only '/' or '/xxxx/'
6200
6201  If a posix root does not exist, or 'xxxx' is not a directory
6202  in the posix root, it returns a failure.
6203
6204  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6205
6206  It is used only internally by posix_to_vmsspec_hardway().
6207  */
6208
6209 static int posix_root_to_vms
6210   (char *vmspath, int vmspath_len,
6211    const char *unixpath,
6212    const int * utf8_fl) {
6213 int sts;
6214 struct FAB myfab = cc$rms_fab;
6215 struct NAML mynam = cc$rms_naml;
6216 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6217  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6218 char *esa;
6219 char *vms_delim;
6220 int dir_flag;
6221 int unixlen;
6222
6223     dir_flag = 0;
6224     unixlen = strlen(unixpath);
6225     if (unixlen == 0) {
6226       vmspath[0] = '\0';
6227       return RMS$_FNF;
6228     }
6229
6230 #if __CRTL_VER >= 80200000
6231   /* If not a posix spec already, convert it */
6232   if (decc_posix_compliant_pathnames) {
6233     if (strncmp(unixpath,"\"^UP^",5) != 0) {
6234       sprintf(vmspath,"\"^UP^%s\"",unixpath);
6235     }
6236     else {
6237       /* This is already a VMS specification, no conversion */
6238       unixlen--;
6239       strncpy(vmspath,unixpath, vmspath_len);
6240     }
6241   }
6242   else
6243 #endif
6244   {
6245   int path_len;
6246   int i,j;
6247
6248      /* Check to see if this is under the POSIX root */
6249      if (decc_disable_posix_root) {
6250         return RMS$_FNF;
6251      }
6252
6253      /* Skip leading / */
6254      if (unixpath[0] == '/') {
6255         unixpath++;
6256         unixlen--;
6257      }
6258
6259
6260      strcpy(vmspath,"SYS$POSIX_ROOT:");
6261
6262      /* If this is only the / , or blank, then... */
6263      if (unixpath[0] == '\0') {
6264         /* by definition, this is the answer */
6265         return SS$_NORMAL;
6266      }
6267
6268      /* Need to look up a directory */
6269      vmspath[15] = '[';
6270      vmspath[16] = '\0';
6271
6272      /* Copy and add '^' escape characters as needed */
6273      j = 16;
6274      i = 0;
6275      while (unixpath[i] != 0) {
6276      int k;
6277
6278         j += copy_expand_unix_filename_escape
6279             (&vmspath[j], &unixpath[i], &k, utf8_fl);
6280         i += k;
6281      }
6282
6283      path_len = strlen(vmspath);
6284      if (vmspath[path_len - 1] == '/')
6285         path_len--;
6286      vmspath[path_len] = ']';
6287      path_len++;
6288      vmspath[path_len] = '\0';
6289
6290   }
6291   vmspath[vmspath_len] = 0;
6292   if (unixpath[unixlen - 1] == '/')
6293   dir_flag = 1;
6294   esa = PerlMem_malloc(VMS_MAXRSS);
6295   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6296   myfab.fab$l_fna = vmspath;
6297   myfab.fab$b_fns = strlen(vmspath);
6298   myfab.fab$l_naml = &mynam;
6299   mynam.naml$l_esa = NULL;
6300   mynam.naml$b_ess = 0;
6301   mynam.naml$l_long_expand = esa;
6302   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6303   mynam.naml$l_rsa = NULL;
6304   mynam.naml$b_rss = 0;
6305   if (decc_efs_case_preserve)
6306     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6307 #ifdef NAML$M_OPEN_SPECIAL
6308   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6309 #endif
6310
6311   /* Set up the remaining naml fields */
6312   sts = sys$parse(&myfab);
6313
6314   /* It failed! Try again as a UNIX filespec */
6315   if (!(sts & 1)) {
6316     PerlMem_free(esa);
6317     return sts;
6318   }
6319
6320    /* get the Device ID and the FID */
6321    sts = sys$search(&myfab);
6322    /* on any failure, returned the POSIX ^UP^ filespec */
6323    if (!(sts & 1)) {
6324       PerlMem_free(esa);
6325       return sts;
6326    }
6327    specdsc.dsc$a_pointer = vmspath;
6328    specdsc.dsc$w_length = vmspath_len;
6329
6330    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6331    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6332    sts = lib$fid_to_name
6333       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6334
6335   /* on any failure, returned the POSIX ^UP^ filespec */
6336   if (!(sts & 1)) {
6337      /* This can happen if user does not have permission to read directories */
6338      if (strncmp(unixpath,"\"^UP^",5) != 0)
6339        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6340      else
6341        strcpy(vmspath, unixpath);
6342   }
6343   else {
6344     vmspath[specdsc.dsc$w_length] = 0;
6345
6346     /* Are we expecting a directory? */
6347     if (dir_flag != 0) {
6348     int i;
6349     char *eptr;
6350
6351       eptr = NULL;
6352
6353       i = specdsc.dsc$w_length - 1;
6354       while (i > 0) {
6355       int zercnt;
6356         zercnt = 0;
6357         /* Version must be '1' */
6358         if (vmspath[i--] != '1')
6359           break;
6360         /* Version delimiter is one of ".;" */
6361         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6362           break;
6363         i--;
6364         if (vmspath[i--] != 'R')
6365           break;
6366         if (vmspath[i--] != 'I')
6367           break;
6368         if (vmspath[i--] != 'D')
6369           break;
6370         if (vmspath[i--] != '.')
6371           break;
6372         eptr = &vmspath[i+1];
6373         while (i > 0) {
6374           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6375             if (vmspath[i-1] != '^') {
6376               if (zercnt != 6) {
6377                 *eptr = vmspath[i];
6378                 eptr[1] = '\0';
6379                 vmspath[i] = '.';
6380                 break;
6381               }
6382               else {
6383                 /* Get rid of 6 imaginary zero directory filename */
6384                 vmspath[i+1] = '\0';
6385               }
6386             }
6387           }
6388           if (vmspath[i] == '0')
6389             zercnt++;
6390           else
6391             zercnt = 10;
6392           i--;
6393         }
6394         break;
6395       }
6396     }
6397   }
6398   PerlMem_free(esa);
6399   return sts;
6400 }
6401
6402 /* /dev/mumble needs to be handled special.
6403    /dev/null becomes NLA0:, And there is the potential for other stuff
6404    like /dev/tty which may need to be mapped to something.
6405 */
6406
6407 static int
6408 slash_dev_special_to_vms
6409    (const char * unixptr,
6410     char * vmspath,
6411     int vmspath_len)
6412 {
6413 char * nextslash;
6414 int len;
6415 int cmp;
6416 int islnm;
6417
6418     unixptr += 4;
6419     nextslash = strchr(unixptr, '/');
6420     len = strlen(unixptr);
6421     if (nextslash != NULL)
6422         len = nextslash - unixptr;
6423     cmp = strncmp("null", unixptr, 5);
6424     if (cmp == 0) {
6425         if (vmspath_len >= 6) {
6426             strcpy(vmspath, "_NLA0:");
6427             return SS$_NORMAL;
6428         }
6429     }
6430 }
6431
6432
6433 /* The built in routines do not understand perl's special needs, so
6434     doing a manual conversion from UNIX to VMS
6435
6436     If the utf8_fl is not null and points to a non-zero value, then
6437     treat 8 bit characters as UTF-8.
6438
6439     The sequence starting with '$(' and ending with ')' will be passed
6440     through with out interpretation instead of being escaped.
6441
6442   */
6443 static int posix_to_vmsspec_hardway
6444   (char *vmspath, int vmspath_len,
6445    const char *unixpath,
6446    int dir_flag,
6447    int * utf8_fl) {
6448
6449 char *esa;
6450 const char *unixptr;
6451 const char *unixend;
6452 char *vmsptr;
6453 const char *lastslash;
6454 const char *lastdot;
6455 int unixlen;
6456 int vmslen;
6457 int dir_start;
6458 int dir_dot;
6459 int quoted;
6460 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6461 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6462
6463   if (utf8_fl != NULL)
6464     *utf8_fl = 0;
6465
6466   unixptr = unixpath;
6467   dir_dot = 0;
6468
6469   /* Ignore leading "/" characters */
6470   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6471     unixptr++;
6472   }
6473   unixlen = strlen(unixptr);
6474
6475   /* Do nothing with blank paths */
6476   if (unixlen == 0) {
6477     vmspath[0] = '\0';
6478     return SS$_NORMAL;
6479   }
6480
6481   quoted = 0;
6482   /* This could have a "^UP^ on the front */
6483   if (strncmp(unixptr,"\"^UP^",5) == 0) {
6484     quoted = 1;
6485     unixptr+= 5;
6486     unixlen-= 5;
6487   }
6488
6489   lastslash = strrchr(unixptr,'/');
6490   lastdot = strrchr(unixptr,'.');
6491   unixend = strrchr(unixptr,'\"');
6492   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6493     unixend = unixptr + unixlen;
6494   }
6495
6496   /* last dot is last dot or past end of string */
6497   if (lastdot == NULL)
6498     lastdot = unixptr + unixlen;
6499
6500   /* if no directories, set last slash to beginning of string */
6501   if (lastslash == NULL) {
6502     lastslash = unixptr;
6503   }
6504   else {
6505     /* Watch out for trailing "." after last slash, still a directory */
6506     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6507       lastslash = unixptr + unixlen;
6508     }
6509
6510     /* Watch out for traiing ".." after last slash, still a directory */
6511     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6512       lastslash = unixptr + unixlen;
6513     }
6514
6515     /* dots in directories are aways escaped */
6516     if (lastdot < lastslash)
6517       lastdot = unixptr + unixlen;
6518   }
6519
6520   /* if (unixptr < lastslash) then we are in a directory */
6521
6522   dir_start = 0;
6523
6524   vmsptr = vmspath;
6525   vmslen = 0;
6526
6527   /* Start with the UNIX path */
6528   if (*unixptr != '/') {
6529     /* relative paths */
6530
6531     /* If allowing logical names on relative pathnames, then handle here */
6532     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6533         !decc_posix_compliant_pathnames) {
6534     char * nextslash;
6535     int seg_len;
6536     char * trn;
6537     int islnm;
6538
6539         /* Find the next slash */
6540         nextslash = strchr(unixptr,'/');
6541
6542         esa = PerlMem_malloc(vmspath_len);
6543         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6544
6545         trn = PerlMem_malloc(VMS_MAXRSS);
6546         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6547
6548         if (nextslash != NULL) {
6549
6550             seg_len = nextslash - unixptr;
6551             strncpy(esa, unixptr, seg_len);
6552             esa[seg_len] = 0;
6553         }
6554         else {
6555             strcpy(esa, unixptr);
6556             seg_len = strlen(unixptr);
6557         }
6558         /* trnlnm(section) */
6559         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6560
6561         if (islnm) {
6562             /* Now fix up the directory */
6563
6564             /* Split up the path to find the components */
6565             sts = vms_split_path
6566                   (trn,
6567                    &v_spec,
6568                    &v_len,
6569                    &r_spec,
6570                    &r_len,
6571                    &d_spec,
6572                    &d_len,
6573                    &n_spec,
6574                    &n_len,
6575                    &e_spec,
6576                    &e_len,
6577                    &vs_spec,
6578                    &vs_len);
6579
6580             while (sts == 0) {
6581             char * strt;
6582             int cmp;
6583
6584                 /* A logical name must be a directory  or the full
6585                    specification.  It is only a full specification if
6586                    it is the only component */
6587                 if ((unixptr[seg_len] == '\0') ||
6588                     (unixptr[seg_len+1] == '\0')) {
6589
6590                     /* Is a directory being required? */
6591                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6592                         /* Not a logical name */
6593                         break;
6594                     }
6595
6596
6597                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6598                         /* This must be a directory */
6599                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6600                             strcpy(vmsptr, esa);
6601                             vmslen=strlen(vmsptr);
6602                             vmsptr[vmslen] = ':';
6603                             vmslen++;
6604                             vmsptr[vmslen] = '\0';
6605                             return SS$_NORMAL;
6606                         }
6607                     }
6608
6609                 }
6610
6611
6612                 /* must be dev/directory - ignore version */
6613                 if ((n_len + e_len) != 0)
6614                     break;
6615
6616                 /* transfer the volume */
6617                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6618                     strncpy(vmsptr, v_spec, v_len);
6619                     vmsptr += v_len;
6620                     vmsptr[0] = '\0';
6621                     vmslen += v_len;
6622                 }
6623
6624                 /* unroot the rooted directory */
6625                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6626                     r_spec[0] = '[';
6627                     r_spec[r_len - 1] = ']';
6628
6629                     /* This should not be there, but nothing is perfect */
6630                     if (r_len > 9) {
6631                         cmp = strcmp(&r_spec[1], "000000.");
6632                         if (cmp == 0) {
6633                             r_spec += 7;
6634                             r_spec[7] = '[';
6635                             r_len -= 7;
6636                             if (r_len == 2)
6637                                 r_len = 0;
6638                         }
6639                     }
6640                     if (r_len > 0) {
6641                         strncpy(vmsptr, r_spec, r_len);
6642                         vmsptr += r_len;
6643                         vmslen += r_len;
6644                         vmsptr[0] = '\0';
6645                     }
6646                 }
6647                 /* Bring over the directory. */
6648                 if ((d_len > 0) &&
6649                     ((d_len + vmslen) < vmspath_len)) {
6650                     d_spec[0] = '[';
6651                     d_spec[d_len - 1] = ']';
6652                     if (d_len > 9) {
6653                         cmp = strcmp(&d_spec[1], "000000.");
6654                         if (cmp == 0) {
6655                             d_spec += 7;
6656                             d_spec[7] = '[';
6657                             d_len -= 7;
6658                             if (d_len == 2)
6659                                 d_len = 0;
6660                         }
6661                     }
6662
6663                     if (r_len > 0) {
6664                         /* Remove the redundant root */
6665                         if (r_len > 0) {
6666                             /* remove the ][ */
6667                             vmsptr--;
6668                             vmslen--;
6669                             d_spec++;
6670                             d_len--;
6671                         }
6672                         strncpy(vmsptr, d_spec, d_len);
6673                             vmsptr += d_len;
6674                             vmslen += d_len;
6675                             vmsptr[0] = '\0';
6676                     }
6677                 }
6678                 break;
6679             }
6680         }
6681
6682         PerlMem_free(esa);
6683         PerlMem_free(trn);
6684     }
6685
6686     if (lastslash > unixptr) {
6687     int dotdir_seen;
6688
6689       /* skip leading ./ */
6690       dotdir_seen = 0;
6691       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6692         dotdir_seen = 1;
6693         unixptr++;
6694         unixptr++;
6695       }
6696
6697       /* Are we still in a directory? */
6698       if (unixptr <= lastslash) {
6699         *vmsptr++ = '[';
6700         vmslen = 1;
6701         dir_start = 1;
6702
6703         /* if not backing up, then it is relative forward. */
6704         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6705               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6706           *vmsptr++ = '.';
6707           vmslen++;
6708           dir_dot = 1;
6709           }
6710        }
6711        else {
6712          if (dotdir_seen) {
6713            /* Perl wants an empty directory here to tell the difference
6714             * between a DCL commmand and a filename
6715             */
6716           *vmsptr++ = '[';
6717           *vmsptr++ = ']';
6718           vmslen = 2;
6719         }
6720       }
6721     }
6722     else {
6723       /* Handle two special files . and .. */
6724       if (unixptr[0] == '.') {
6725         if (&unixptr[1] == unixend) {
6726           *vmsptr++ = '[';
6727           *vmsptr++ = ']';
6728           vmslen += 2;
6729           *vmsptr++ = '\0';
6730           return SS$_NORMAL;
6731         }
6732         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6733           *vmsptr++ = '[';
6734           *vmsptr++ = '-';
6735           *vmsptr++ = ']';
6736           vmslen += 3;
6737           *vmsptr++ = '\0';
6738           return SS$_NORMAL;
6739         }
6740       }
6741     }
6742   }
6743   else {        /* Absolute PATH handling */
6744   int sts;
6745   char * nextslash;
6746   int seg_len;
6747     /* Need to find out where root is */
6748
6749     /* In theory, this procedure should never get an absolute POSIX pathname
6750      * that can not be found on the POSIX root.
6751      * In practice, that can not be relied on, and things will show up
6752      * here that are a VMS device name or concealed logical name instead.
6753      * So to make things work, this procedure must be tolerant.
6754      */
6755     esa = PerlMem_malloc(vmspath_len);
6756     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6757
6758     sts = SS$_NORMAL;
6759     nextslash = strchr(&unixptr[1],'/');
6760     seg_len = 0;
6761     if (nextslash != NULL) {
6762     int cmp;
6763       seg_len = nextslash - &unixptr[1];
6764       strncpy(vmspath, unixptr, seg_len + 1);
6765       vmspath[seg_len+1] = 0;
6766       cmp = 1;
6767       if (seg_len == 3) {
6768         cmp = strncmp(vmspath, "dev", 4);
6769         if (cmp == 0) {
6770             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6771             if (sts = SS$_NORMAL)
6772                 return SS$_NORMAL;
6773         }
6774       }
6775       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6776     }
6777
6778     if ($VMS_STATUS_SUCCESS(sts)) {
6779       /* This is verified to be a real path */
6780
6781       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6782       if ($VMS_STATUS_SUCCESS(sts)) {
6783         strcpy(vmspath, esa);
6784         vmslen = strlen(vmspath);
6785         vmsptr = vmspath + vmslen;
6786         unixptr++;
6787         if (unixptr < lastslash) {
6788         char * rptr;
6789           vmsptr--;
6790           *vmsptr++ = '.';
6791           dir_start = 1;
6792           dir_dot = 1;
6793           if (vmslen > 7) {
6794           int cmp;
6795             rptr = vmsptr - 7;
6796             cmp = strcmp(rptr,"000000.");
6797             if (cmp == 0) {
6798               vmslen -= 7;
6799               vmsptr -= 7;
6800               vmsptr[1] = '\0';
6801             } /* removing 6 zeros */
6802           } /* vmslen < 7, no 6 zeros possible */
6803         } /* Not in a directory */
6804       } /* Posix root found */
6805       else {
6806         /* No posix root, fall back to default directory */
6807         strcpy(vmspath, "SYS$DISK:[");
6808         vmsptr = &vmspath[10];
6809         vmslen = 10;
6810         if (unixptr > lastslash) {
6811            *vmsptr = ']';
6812            vmsptr++;
6813            vmslen++;
6814         }
6815         else {
6816            dir_start = 1;
6817         }
6818       }
6819     } /* end of verified real path handling */
6820     else {
6821     int add_6zero;
6822     int islnm;
6823
6824       /* Ok, we have a device or a concealed root that is not in POSIX
6825        * or we have garbage.  Make the best of it.
6826        */
6827
6828       /* Posix to VMS destroyed this, so copy it again */
6829       strncpy(vmspath, &unixptr[1], seg_len);
6830       vmspath[seg_len] = 0;
6831       vmslen = seg_len;
6832       vmsptr = &vmsptr[vmslen];
6833       islnm = 0;
6834
6835       /* Now do we need to add the fake 6 zero directory to it? */
6836       add_6zero = 1;
6837       if ((*lastslash == '/') && (nextslash < lastslash)) {
6838         /* No there is another directory */
6839         add_6zero = 0;
6840       }
6841       else {
6842       int trnend;
6843       int cmp;
6844
6845         /* now we have foo:bar or foo:[000000]bar to decide from */
6846         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6847
6848         if (!islnm && !decc_posix_compliant_pathnames) {
6849
6850             cmp = strncmp("bin", vmspath, 4);
6851             if (cmp == 0) {
6852                 /* bin => SYS$SYSTEM: */
6853                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6854             }
6855             else {
6856                 /* tmp => SYS$SCRATCH: */
6857                 cmp = strncmp("tmp", vmspath, 4);
6858                 if (cmp == 0) {
6859                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6860                 }
6861             }
6862         }
6863
6864         trnend = islnm ? islnm - 1 : 0;
6865
6866         /* if this was a logical name, ']' or '>' must be present */
6867         /* if not a logical name, then assume a device and hope. */
6868         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6869
6870         /* if log name and trailing '.' then rooted - treat as device */
6871         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6872
6873         /* Fix me, if not a logical name, a device lookup should be
6874          * done to see if the device is file structured.  If the device
6875          * is not file structured, the 6 zeros should not be put on.
6876          *
6877          * As it is, perl is occasionally looking for dev:[000000]tty.
6878          * which looks a little strange.
6879          *
6880          * Not that easy to detect as "/dev" may be file structured with
6881          * special device files.
6882          */
6883
6884         if ((add_6zero == 0) && (*nextslash == '/') &&
6885             (&nextslash[1] == unixend)) {
6886           /* No real directory present */
6887           add_6zero = 1;
6888         }
6889       }
6890
6891       /* Put the device delimiter on */
6892       *vmsptr++ = ':';
6893       vmslen++;
6894       unixptr = nextslash;
6895       unixptr++;
6896
6897       /* Start directory if needed */
6898       if (!islnm || add_6zero) {
6899         *vmsptr++ = '[';
6900         vmslen++;
6901         dir_start = 1;
6902       }
6903
6904       /* add fake 000000] if needed */
6905       if (add_6zero) {
6906         *vmsptr++ = '0';
6907         *vmsptr++ = '0';
6908         *vmsptr++ = '0';
6909         *vmsptr++ = '0';
6910         *vmsptr++ = '0';
6911         *vmsptr++ = '0';
6912         *vmsptr++ = ']';
6913         vmslen += 7;
6914         dir_start = 0;
6915       }
6916
6917     } /* non-POSIX translation */
6918     PerlMem_free(esa);
6919   } /* End of relative/absolute path handling */
6920
6921   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6922   int dash_flag;
6923   int in_cnt;
6924   int out_cnt;
6925
6926     dash_flag = 0;
6927
6928     if (dir_start != 0) {
6929
6930       /* First characters in a directory are handled special */
6931       while ((*unixptr == '/') ||
6932              ((*unixptr == '.') &&
6933               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6934                 (&unixptr[1]==unixend)))) {
6935       int loop_flag;
6936
6937         loop_flag = 0;
6938
6939         /* Skip redundant / in specification */
6940         while ((*unixptr == '/') && (dir_start != 0)) {
6941           loop_flag = 1;
6942           unixptr++;
6943           if (unixptr == lastslash)
6944             break;
6945         }
6946         if (unixptr == lastslash)
6947           break;
6948
6949         /* Skip redundant ./ characters */
6950         while ((*unixptr == '.') &&
6951                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6952           loop_flag = 1;
6953           unixptr++;
6954           if (unixptr == lastslash)
6955             break;
6956           if (*unixptr == '/')
6957             unixptr++;
6958         }
6959         if (unixptr == lastslash)
6960           break;
6961
6962         /* Skip redundant ../ characters */
6963         while ((*unixptr == '.') && (unixptr[1] == '.') &&
6964              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6965           /* Set the backing up flag */
6966           loop_flag = 1;
6967           dir_dot = 0;
6968           dash_flag = 1;
6969           *vmsptr++ = '-';
6970           vmslen++;
6971           unixptr++; /* first . */
6972           unixptr++; /* second . */
6973           if (unixptr == lastslash)
6974             break;
6975           if (*unixptr == '/') /* The slash */
6976             unixptr++;
6977         }
6978         if (unixptr == lastslash)
6979           break;
6980
6981         /* To do: Perl expects /.../ to be translated to [...] on VMS */
6982         /* Not needed when VMS is pretending to be UNIX. */
6983
6984         /* Is this loop stuck because of too many dots? */
6985         if (loop_flag == 0) {
6986           /* Exit the loop and pass the rest through */
6987           break;
6988         }
6989       }
6990
6991       /* Are we done with directories yet? */
6992       if (unixptr >= lastslash) {
6993
6994         /* Watch out for trailing dots */
6995         if (dir_dot != 0) {
6996             vmslen --;
6997             vmsptr--;
6998         }
6999         *vmsptr++ = ']';
7000         vmslen++;
7001         dash_flag = 0;
7002         dir_start = 0;
7003         if (*unixptr == '/')
7004           unixptr++;
7005       }
7006       else {
7007         /* Have we stopped backing up? */
7008         if (dash_flag) {
7009           *vmsptr++ = '.';
7010           vmslen++;
7011           dash_flag = 0;
7012           /* dir_start continues to be = 1 */
7013         }
7014         if (*unixptr == '-') {
7015           *vmsptr++ = '^';
7016           *vmsptr++ = *unixptr++;
7017           vmslen += 2;
7018           dir_start = 0;
7019
7020           /* Now are we done with directories yet? */
7021           if (unixptr >= lastslash) {
7022
7023             /* Watch out for trailing dots */
7024             if (dir_dot != 0) {
7025               vmslen --;
7026               vmsptr--;
7027             }
7028
7029             *vmsptr++ = ']';
7030             vmslen++;
7031             dash_flag = 0;
7032             dir_start = 0;
7033           }
7034         }
7035       }
7036     }
7037
7038     /* All done? */
7039     if (unixptr >= unixend)
7040       break;
7041
7042     /* Normal characters - More EFS work probably needed */
7043     dir_start = 0;
7044     dir_dot = 0;
7045
7046     switch(*unixptr) {
7047     case '/':
7048         /* remove multiple / */
7049         while (unixptr[1] == '/') {
7050            unixptr++;
7051         }
7052         if (unixptr == lastslash) {
7053           /* Watch out for trailing dots */
7054           if (dir_dot != 0) {
7055             vmslen --;
7056             vmsptr--;
7057           }
7058           *vmsptr++ = ']';
7059         }
7060         else {
7061           dir_start = 1;
7062           *vmsptr++ = '.';
7063           dir_dot = 1;
7064
7065           /* To do: Perl expects /.../ to be translated to [...] on VMS */
7066           /* Not needed when VMS is pretending to be UNIX. */
7067
7068         }
7069         dash_flag = 0;
7070         if (unixptr != unixend)
7071           unixptr++;
7072         vmslen++;
7073         break;
7074     case '.':
7075         if ((unixptr < lastdot) || (unixptr < lastslash) ||
7076             (&unixptr[1] == unixend)) {
7077           *vmsptr++ = '^';
7078           *vmsptr++ = '.';
7079           vmslen += 2;
7080           unixptr++;
7081
7082           /* trailing dot ==> '^..' on VMS */
7083           if (unixptr == unixend) {
7084             *vmsptr++ = '.';
7085             vmslen++;
7086             unixptr++;
7087           }
7088           break;
7089         }
7090
7091         *vmsptr++ = *unixptr++;
7092         vmslen ++;
7093         break;
7094     case '"':
7095         if (quoted && (&unixptr[1] == unixend)) {
7096             unixptr++;
7097             break;
7098         }
7099         in_cnt = copy_expand_unix_filename_escape
7100                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7101         vmsptr += out_cnt;
7102         unixptr += in_cnt;
7103         break;
7104     case '~':
7105     case ';':
7106     case '\\':
7107     case '?':
7108     case ' ':
7109     default:
7110         in_cnt = copy_expand_unix_filename_escape
7111                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7112         vmsptr += out_cnt;
7113         unixptr += in_cnt;
7114         break;
7115     }
7116   }
7117
7118   /* Make sure directory is closed */
7119   if (unixptr == lastslash) {
7120     char *vmsptr2;
7121     vmsptr2 = vmsptr - 1;
7122
7123     if (*vmsptr2 != ']') {
7124       *vmsptr2--;
7125
7126       /* directories do not end in a dot bracket */
7127       if (*vmsptr2 == '.') {
7128         vmsptr2--;
7129
7130         /* ^. is allowed */
7131         if (*vmsptr2 != '^') {
7132           vmsptr--; /* back up over the dot */
7133         }
7134       }
7135       *vmsptr++ = ']';
7136     }
7137   }
7138   else {
7139     char *vmsptr2;
7140     /* Add a trailing dot if a file with no extension */
7141     vmsptr2 = vmsptr - 1;
7142     if ((vmslen > 1) &&
7143         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7144         (*vmsptr2 != ')') && (*lastdot != '.')) {
7145         *vmsptr++ = '.';
7146         vmslen++;
7147     }
7148   }
7149
7150   *vmsptr = '\0';
7151   return SS$_NORMAL;
7152 }
7153 #endif
7154
7155  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7156 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7157 {
7158 char * result;
7159 int utf8_flag;
7160
7161    /* If a UTF8 flag is being passed, honor it */
7162    utf8_flag = 0;
7163    if (utf8_fl != NULL) {
7164      utf8_flag = *utf8_fl;
7165     *utf8_fl = 0;
7166    }
7167
7168    if (utf8_flag) {
7169      /* If there is a possibility of UTF8, then if any UTF8 characters
7170         are present, then they must be converted to VTF-7
7171       */
7172      result = strcpy(rslt, path); /* FIX-ME */
7173    }
7174    else
7175      result = strcpy(rslt, path);
7176
7177    return result;
7178 }
7179
7180
7181 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7182 static char *mp_do_tovmsspec
7183    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7184   static char __tovmsspec_retbuf[VMS_MAXRSS];
7185   char *rslt, *dirend;
7186   char *lastdot;
7187   char *vms_delim;
7188   register char *cp1;
7189   const char *cp2;
7190   unsigned long int infront = 0, hasdir = 1;
7191   int rslt_len;
7192   int no_type_seen;
7193   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7194   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7195
7196   if (path == NULL) return NULL;
7197   rslt_len = VMS_MAXRSS-1;
7198   if (buf) rslt = buf;
7199   else if (ts) Newx(rslt, VMS_MAXRSS, char);
7200   else rslt = __tovmsspec_retbuf;
7201
7202   /* '.' and '..' are "[]" and "[-]" for a quick check */
7203   if (path[0] == '.') {
7204     if (path[1] == '\0') {
7205       strcpy(rslt,"[]");
7206       if (utf8_flag != NULL)
7207         *utf8_flag = 0;
7208       return rslt;
7209     }
7210     else {
7211       if (path[1] == '.' && path[2] == '\0') {
7212         strcpy(rslt,"[-]");
7213         if (utf8_flag != NULL)
7214            *utf8_flag = 0;
7215         return rslt;
7216       }
7217     }
7218   }
7219
7220    /* Posix specifications are now a native VMS format */
7221   /*--------------------------------------------------*/
7222 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7223   if (decc_posix_compliant_pathnames) {
7224     if (strncmp(path,"\"^UP^",5) == 0) {
7225       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7226       return rslt;
7227     }
7228   }
7229 #endif
7230
7231   /* This is really the only way to see if this is already in VMS format */
7232   sts = vms_split_path
7233        (path,
7234         &v_spec,
7235         &v_len,
7236         &r_spec,
7237         &r_len,
7238         &d_spec,
7239         &d_len,
7240         &n_spec,
7241         &n_len,
7242         &e_spec,
7243         &e_len,
7244         &vs_spec,
7245         &vs_len);
7246   if (sts == 0) {
7247     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7248        replacement, because the above parse just took care of most of
7249        what is needed to do vmspath when the specification is already
7250        in VMS format.
7251
7252        And if it is not already, it is easier to do the conversion as
7253        part of this routine than to call this routine and then work on
7254        the result.
7255      */
7256
7257     /* If VMS punctuation was found, it is already VMS format */
7258     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7259       if (utf8_flag != NULL)
7260         *utf8_flag = 0;
7261       strcpy(rslt, path);
7262       return rslt;
7263     }
7264     /* Now, what to do with trailing "." cases where there is no
7265        extension?  If this is a UNIX specification, and EFS characters
7266        are enabled, then the trailing "." should be converted to a "^.".
7267        But if this was already a VMS specification, then it should be
7268        left alone.
7269
7270        So in the case of ambiguity, leave the specification alone.
7271      */
7272
7273
7274     /* If there is a possibility of UTF8, then if any UTF8 characters
7275         are present, then they must be converted to VTF-7
7276      */
7277     if (utf8_flag != NULL)
7278       *utf8_flag = 0;
7279     strcpy(rslt, path);
7280     return rslt;
7281   }
7282
7283   dirend = strrchr(path,'/');
7284
7285   if (dirend == NULL) {
7286      /* If we get here with no UNIX directory delimiters, then this is
7287         not a complete file specification, either garbage a UNIX glob
7288         specification that can not be converted to a VMS wildcard, or
7289         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7290         so apparently other programs expect this also.
7291
7292         utf8 flag setting needs to be preserved.
7293       */
7294       strcpy(rslt, path);
7295       return rslt;
7296   }
7297
7298 /* If POSIX mode active, handle the conversion */
7299 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7300   if (decc_efs_charset) {
7301     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7302     return rslt;
7303   }
7304 #endif
7305
7306   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7307     if (!*(dirend+2)) dirend +=2;
7308     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7309     if (decc_efs_charset == 0) {
7310       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7311     }
7312   }
7313
7314   cp1 = rslt;
7315   cp2 = path;
7316   lastdot = strrchr(cp2,'.');
7317   if (*cp2 == '/') {
7318     char *trndev;
7319     int islnm, rooted;
7320     STRLEN trnend;
7321
7322     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7323     if (!*(cp2+1)) {
7324       if (decc_disable_posix_root) {
7325         strcpy(rslt,"sys$disk:[000000]");
7326       }
7327       else {
7328         strcpy(rslt,"sys$posix_root:[000000]");
7329       }
7330       if (utf8_flag != NULL)
7331         *utf8_flag = 0;
7332       return rslt;
7333     }
7334     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7335     *cp1 = '\0';
7336     trndev = PerlMem_malloc(VMS_MAXRSS);
7337     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7338     islnm =  my_trnlnm(rslt,trndev,0);
7339
7340      /* DECC special handling */
7341     if (!islnm) {
7342       if (strcmp(rslt,"bin") == 0) {
7343         strcpy(rslt,"sys$system");
7344         cp1 = rslt + 10;
7345         *cp1 = 0;
7346         islnm =  my_trnlnm(rslt,trndev,0);
7347       }
7348       else if (strcmp(rslt,"tmp") == 0) {
7349         strcpy(rslt,"sys$scratch");
7350         cp1 = rslt + 11;
7351         *cp1 = 0;
7352         islnm =  my_trnlnm(rslt,trndev,0);
7353       }
7354       else if (!decc_disable_posix_root) {
7355         strcpy(rslt, "sys$posix_root");
7356         cp1 = rslt + 13;
7357         *cp1 = 0;
7358         cp2 = path;
7359         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7360         islnm =  my_trnlnm(rslt,trndev,0);
7361       }
7362       else if (strcmp(rslt,"dev") == 0) {
7363         if (strncmp(cp2,"/null", 5) == 0) {
7364           if ((cp2[5] == 0) || (cp2[5] == '/')) {
7365             strcpy(rslt,"NLA0");
7366             cp1 = rslt + 4;
7367             *cp1 = 0;
7368             cp2 = cp2 + 5;
7369             islnm =  my_trnlnm(rslt,trndev,0);
7370           }
7371         }
7372       }
7373     }
7374
7375     trnend = islnm ? strlen(trndev) - 1 : 0;
7376     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7377     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7378     /* If the first element of the path is a logical name, determine
7379      * whether it has to be translated so we can add more directories. */
7380     if (!islnm || rooted) {
7381       *(cp1++) = ':';
7382       *(cp1++) = '[';
7383       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7384       else cp2++;
7385     }
7386     else {
7387       if (cp2 != dirend) {
7388         strcpy(rslt,trndev);
7389         cp1 = rslt + trnend;
7390         if (*cp2 != 0) {
7391           *(cp1++) = '.';
7392           cp2++;
7393         }
7394       }
7395       else {
7396         if (decc_disable_posix_root) {
7397           *(cp1++) = ':';
7398           hasdir = 0;
7399         }
7400       }
7401     }
7402     PerlMem_free(trndev);
7403   }
7404   else {
7405     *(cp1++) = '[';
7406     if (*cp2 == '.') {
7407       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7408         cp2 += 2;         /* skip over "./" - it's redundant */
7409         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
7410       }
7411       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7412         *(cp1++) = '-';                                 /* "../" --> "-" */
7413         cp2 += 3;
7414       }
7415       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7416                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7417         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7418         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7419         cp2 += 4;
7420       }
7421       else if ((cp2 != lastdot) || (lastdot < dirend)) {
7422         /* Escape the extra dots in EFS file specifications */
7423         *(cp1++) = '^';
7424       }
7425       if (cp2 > dirend) cp2 = dirend;
7426     }
7427     else *(cp1++) = '.';
7428   }
7429   for (; cp2 < dirend; cp2++) {
7430     if (*cp2 == '/') {
7431       if (*(cp2-1) == '/') continue;
7432       if (*(cp1-1) != '.') *(cp1++) = '.';
7433       infront = 0;
7434     }
7435     else if (!infront && *cp2 == '.') {
7436       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7437       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
7438       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7439         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7440         else if (*(cp1-2) == '[') *(cp1-1) = '-';
7441         else {  /* back up over previous directory name */
7442           cp1--;
7443           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7444           if (*(cp1-1) == '[') {
7445             memcpy(cp1,"000000.",7);
7446             cp1 += 7;
7447           }
7448         }
7449         cp2 += 2;
7450         if (cp2 == dirend) break;
7451       }
7452       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7453                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7454         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7455         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7456         if (!*(cp2+3)) {
7457           *(cp1++) = '.';  /* Simulate trailing '/' */
7458           cp2 += 2;  /* for loop will incr this to == dirend */
7459         }
7460         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
7461       }
7462       else {
7463         if (decc_efs_charset == 0)
7464           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
7465         else {
7466           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
7467           *(cp1++) = '.';
7468         }
7469       }
7470     }
7471     else {
7472       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
7473       if (*cp2 == '.') {
7474         if (decc_efs_charset == 0)
7475           *(cp1++) = '_';
7476         else {
7477           *(cp1++) = '^';
7478           *(cp1++) = '.';
7479         }
7480       }
7481       else                  *(cp1++) =  *cp2;
7482       infront = 1;
7483     }
7484   }
7485   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7486   if (hasdir) *(cp1++) = ']';
7487   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
7488   /* fixme for ODS5 */
7489   no_type_seen = 0;
7490   if (cp2 > lastdot)
7491     no_type_seen = 1;
7492   while (*cp2) {
7493     switch(*cp2) {
7494     case '?':
7495         if (decc_efs_charset == 0)
7496           *(cp1++) = '%';
7497         else
7498           *(cp1++) = '?';
7499         cp2++;
7500     case ' ':
7501         *(cp1)++ = '^';
7502         *(cp1)++ = '_';
7503         cp2++;
7504         break;
7505     case '.':
7506         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7507             decc_readdir_dropdotnotype) {
7508           *(cp1)++ = '^';
7509           *(cp1)++ = '.';
7510           cp2++;
7511
7512           /* trailing dot ==> '^..' on VMS */
7513           if (*cp2 == '\0') {
7514             *(cp1++) = '.';
7515             no_type_seen = 0;
7516           }
7517         }
7518         else {
7519           *(cp1++) = *(cp2++);
7520           no_type_seen = 0;
7521         }
7522         break;
7523     case '$':
7524          /* This could be a macro to be passed through */
7525         *(cp1++) = *(cp2++);
7526         if (*cp2 == '(') {
7527         const char * save_cp2;
7528         char * save_cp1;
7529         int is_macro;
7530
7531             /* paranoid check */
7532             save_cp2 = cp2;
7533             save_cp1 = cp1;
7534             is_macro = 0;
7535
7536             /* Test through */
7537             *(cp1++) = *(cp2++);
7538             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7539                 *(cp1++) = *(cp2++);
7540                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7541                     *(cp1++) = *(cp2++);
7542                 }
7543                 if (*cp2 == ')') {
7544                     *(cp1++) = *(cp2++);
7545                     is_macro = 1;
7546                 }
7547             }
7548             if (is_macro == 0) {
7549                 /* Not really a macro - never mind */
7550                 cp2 = save_cp2;
7551                 cp1 = save_cp1;
7552             }
7553         }
7554         break;
7555     case '\"':
7556     case '~':
7557     case '`':
7558     case '!':
7559     case '#':
7560     case '%':
7561     case '^':
7562     case '&':
7563     case '(':
7564     case ')':
7565     case '=':
7566     case '+':
7567     case '\'':
7568     case '@':
7569     case '[':
7570     case ']':
7571     case '{':
7572     case '}':
7573     case ':':
7574     case '\\':
7575     case '|':
7576     case '<':
7577     case '>':
7578         *(cp1++) = '^';
7579         *(cp1++) = *(cp2++);
7580         break;
7581     case ';':
7582         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7583          * which is wrong.  UNIX notation should be ".dir." unless
7584          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7585          * changing this behavior could break more things at this time.
7586          * efs character set effectively does not allow "." to be a version
7587          * delimiter as a further complication about changing this.
7588          */
7589         if (decc_filename_unix_report != 0) {
7590           *(cp1++) = '^';
7591         }
7592         *(cp1++) = *(cp2++);
7593         break;
7594     default:
7595         *(cp1++) = *(cp2++);
7596     }
7597   }
7598   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7599   char *lcp1;
7600     lcp1 = cp1;
7601     lcp1--;
7602      /* Fix me for "^]", but that requires making sure that you do
7603       * not back up past the start of the filename
7604       */
7605     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7606       *cp1++ = '.';
7607   }
7608   *cp1 = '\0';
7609
7610   if (utf8_flag != NULL)
7611     *utf8_flag = 0;
7612   return rslt;
7613
7614 }  /* end of do_tovmsspec() */
7615 /*}}}*/
7616 /* External entry points */
7617 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7618   { return do_tovmsspec(path,buf,0,NULL); }
7619 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7620   { return do_tovmsspec(path,buf,1,NULL); }
7621 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7622   { return do_tovmsspec(path,buf,0,utf8_fl); }
7623 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7624   { return do_tovmsspec(path,buf,1,utf8_fl); }
7625
7626 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7627 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7628   static char __tovmspath_retbuf[VMS_MAXRSS];
7629   int vmslen;
7630   char *pathified, *vmsified, *cp;
7631
7632   if (path == NULL) return NULL;
7633   pathified = PerlMem_malloc(VMS_MAXRSS);
7634   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7635   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7636     PerlMem_free(pathified);
7637     return NULL;
7638   }
7639
7640   vmsified = NULL;
7641   if (buf == NULL)
7642      Newx(vmsified, VMS_MAXRSS, char);
7643   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7644     PerlMem_free(pathified);
7645     if (vmsified) Safefree(vmsified);
7646     return NULL;
7647   }
7648   PerlMem_free(pathified);
7649   if (buf) {
7650     return buf;
7651   }
7652   else if (ts) {
7653     vmslen = strlen(vmsified);
7654     Newx(cp,vmslen+1,char);
7655     memcpy(cp,vmsified,vmslen);
7656     cp[vmslen] = '\0';
7657     Safefree(vmsified);
7658     return cp;
7659   }
7660   else {
7661     strcpy(__tovmspath_retbuf,vmsified);
7662     Safefree(vmsified);
7663     return __tovmspath_retbuf;
7664   }
7665
7666 }  /* end of do_tovmspath() */
7667 /*}}}*/
7668 /* External entry points */
7669 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7670   { return do_tovmspath(path,buf,0, NULL); }
7671 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7672   { return do_tovmspath(path,buf,1, NULL); }
7673 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7674   { return do_tovmspath(path,buf,0,utf8_fl); }
7675 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7676   { return do_tovmspath(path,buf,1,utf8_fl); }
7677
7678
7679 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7680 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7681   static char __tounixpath_retbuf[VMS_MAXRSS];
7682   int unixlen;
7683   char *pathified, *unixified, *cp;
7684
7685   if (path == NULL) return NULL;
7686   pathified = PerlMem_malloc(VMS_MAXRSS);
7687   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7688   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7689     PerlMem_free(pathified);
7690     return NULL;
7691   }
7692
7693   unixified = NULL;
7694   if (buf == NULL) {
7695       Newx(unixified, VMS_MAXRSS, char);
7696   }
7697   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7698     PerlMem_free(pathified);
7699     if (unixified) Safefree(unixified);
7700     return NULL;
7701   }
7702   PerlMem_free(pathified);
7703   if (buf) {
7704     return buf;
7705   }
7706   else if (ts) {
7707     unixlen = strlen(unixified);
7708     Newx(cp,unixlen+1,char);
7709     memcpy(cp,unixified,unixlen);
7710     cp[unixlen] = '\0';
7711     Safefree(unixified);
7712     return cp;
7713   }
7714   else {
7715     strcpy(__tounixpath_retbuf,unixified);
7716     Safefree(unixified);
7717     return __tounixpath_retbuf;
7718   }
7719
7720 }  /* end of do_tounixpath() */
7721 /*}}}*/
7722 /* External entry points */
7723 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7724   { return do_tounixpath(path,buf,0,NULL); }
7725 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7726   { return do_tounixpath(path,buf,1,NULL); }
7727 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7728   { return do_tounixpath(path,buf,0,utf8_fl); }
7729 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7730   { return do_tounixpath(path,buf,1,utf8_fl); }
7731
7732 /*
7733  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
7734  *
7735  *****************************************************************************
7736  *                                                                           *
7737  *  Copyright (C) 1989-1994, 2007 by                                         *
7738  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
7739  *                                                                           *
7740  *  Permission is hereby granted for the reproduction of this software       *
7741  *  on condition that this copyright notice is included in source            *
7742  *  distributions of the software.  The code may be modified and             *
7743  *  distributed under the same terms as Perl itself.                         *
7744  *                                                                           *
7745  *  27-Aug-1994 Modified for inclusion in perl5                              *
7746  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
7747  *****************************************************************************
7748  */
7749
7750 /*
7751  * getredirection() is intended to aid in porting C programs
7752  * to VMS (Vax-11 C).  The native VMS environment does not support
7753  * '>' and '<' I/O redirection, or command line wild card expansion,
7754  * or a command line pipe mechanism using the '|' AND background
7755  * command execution '&'.  All of these capabilities are provided to any
7756  * C program which calls this procedure as the first thing in the
7757  * main program.
7758  * The piping mechanism will probably work with almost any 'filter' type
7759  * of program.  With suitable modification, it may useful for other
7760  * portability problems as well.
7761  *
7762  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
7763  */
7764 struct list_item
7765     {
7766     struct list_item *next;
7767     char *value;
7768     };
7769
7770 static void add_item(struct list_item **head,
7771                      struct list_item **tail,
7772                      char *value,
7773                      int *count);
7774
7775 static void mp_expand_wild_cards(pTHX_ char *item,
7776                                 struct list_item **head,
7777                                 struct list_item **tail,
7778                                 int *count);
7779
7780 static int background_process(pTHX_ int argc, char **argv);
7781
7782 static void pipe_and_fork(pTHX_ char **cmargv);
7783
7784 /*{{{ void getredirection(int *ac, char ***av)*/
7785 static void
7786 mp_getredirection(pTHX_ int *ac, char ***av)
7787 /*
7788  * Process vms redirection arg's.  Exit if any error is seen.
7789  * If getredirection() processes an argument, it is erased
7790  * from the vector.  getredirection() returns a new argc and argv value.
7791  * In the event that a background command is requested (by a trailing "&"),
7792  * this routine creates a background subprocess, and simply exits the program.
7793  *
7794  * Warning: do not try to simplify the code for vms.  The code
7795  * presupposes that getredirection() is called before any data is
7796  * read from stdin or written to stdout.
7797  *
7798  * Normal usage is as follows:
7799  *
7800  *      main(argc, argv)
7801  *      int             argc;
7802  *      char            *argv[];
7803  *      {
7804  *              getredirection(&argc, &argv);
7805  *      }
7806  */
7807 {
7808     int                 argc = *ac;     /* Argument Count         */
7809     char                **argv = *av;   /* Argument Vector        */
7810     char                *ap;            /* Argument pointer       */
7811     int                 j;              /* argv[] index           */
7812     int                 item_count = 0; /* Count of Items in List */
7813     struct list_item    *list_head = 0; /* First Item in List       */
7814     struct list_item    *list_tail;     /* Last Item in List        */
7815     char                *in = NULL;     /* Input File Name          */
7816     char                *out = NULL;    /* Output File Name         */
7817     char                *outmode = "w"; /* Mode to Open Output File */
7818     char                *err = NULL;    /* Error File Name          */
7819     char                *errmode = "w"; /* Mode to Open Error File  */
7820     int                 cmargc = 0;     /* Piped Command Arg Count  */
7821     char                **cmargv = NULL;/* Piped Command Arg Vector */
7822
7823     /*
7824      * First handle the case where the last thing on the line ends with
7825      * a '&'.  This indicates the desire for the command to be run in a
7826      * subprocess, so we satisfy that desire.
7827      */
7828     ap = argv[argc-1];
7829     if (0 == strcmp("&", ap))
7830        exit(background_process(aTHX_ --argc, argv));
7831     if (*ap && '&' == ap[strlen(ap)-1])
7832         {
7833         ap[strlen(ap)-1] = '\0';
7834        exit(background_process(aTHX_ argc, argv));
7835         }
7836     /*
7837      * Now we handle the general redirection cases that involve '>', '>>',
7838      * '<', and pipes '|'.
7839      */
7840     for (j = 0; j < argc; ++j)
7841         {
7842         if (0 == strcmp("<", argv[j]))
7843             {
7844             if (j+1 >= argc)
7845                 {
7846                 fprintf(stderr,"No input file after < on command line");
7847                 exit(LIB$_WRONUMARG);
7848                 }
7849             in = argv[++j];
7850             continue;
7851             }
7852         if ('<' == *(ap = argv[j]))
7853             {
7854             in = 1 + ap;
7855             continue;
7856             }
7857         if (0 == strcmp(">", ap))
7858             {
7859             if (j+1 >= argc)
7860                 {
7861                 fprintf(stderr,"No output file after > on command line");
7862                 exit(LIB$_WRONUMARG);
7863                 }
7864             out = argv[++j];
7865             continue;
7866             }
7867         if ('>' == *ap)
7868             {
7869             if ('>' == ap[1])
7870                 {
7871                 outmode = "a";
7872                 if ('\0' == ap[2])
7873                     out = argv[++j];
7874                 else
7875                     out = 2 + ap;
7876                 }
7877             else
7878                 out = 1 + ap;
7879             if (j >= argc)
7880                 {
7881                 fprintf(stderr,"No output file after > or >> on command line");
7882                 exit(LIB$_WRONUMARG);
7883                 }
7884             continue;
7885             }
7886         if (('2' == *ap) && ('>' == ap[1]))
7887             {
7888             if ('>' == ap[2])
7889                 {
7890                 errmode = "a";
7891                 if ('\0' == ap[3])
7892                     err = argv[++j];
7893                 else
7894                     err = 3 + ap;
7895                 }
7896             else
7897                 if ('\0' == ap[2])
7898                     err = argv[++j];
7899                 else
7900                     err = 2 + ap;
7901             if (j >= argc)
7902                 {
7903                 fprintf(stderr,"No output file after 2> or 2>> on command line");
7904                 exit(LIB$_WRONUMARG);
7905                 }
7906             continue;
7907             }
7908         if (0 == strcmp("|", argv[j]))
7909             {
7910             if (j+1 >= argc)
7911                 {
7912                 fprintf(stderr,"No command into which to pipe on command line");
7913                 exit(LIB$_WRONUMARG);
7914                 }
7915             cmargc = argc-(j+1);
7916             cmargv = &argv[j+1];
7917             argc = j;
7918             continue;
7919             }
7920         if ('|' == *(ap = argv[j]))
7921             {
7922             ++argv[j];
7923             cmargc = argc-j;
7924             cmargv = &argv[j];
7925             argc = j;
7926             continue;
7927             }
7928         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7929         }
7930     /*
7931      * Allocate and fill in the new argument vector, Some Unix's terminate
7932      * the list with an extra null pointer.
7933      */
7934     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7935     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7936     *av = argv;
7937     for (j = 0; j < item_count; ++j, list_head = list_head->next)
7938         argv[j] = list_head->value;
7939     *ac = item_count;
7940     if (cmargv != NULL)
7941         {
7942         if (out != NULL)
7943             {
7944             fprintf(stderr,"'|' and '>' may not both be specified on command line");
7945             exit(LIB$_INVARGORD);
7946             }
7947         pipe_and_fork(aTHX_ cmargv);
7948         }
7949
7950     /* Check for input from a pipe (mailbox) */
7951
7952     if (in == NULL && 1 == isapipe(0))
7953         {
7954         char mbxname[L_tmpnam];
7955         long int bufsize;
7956         long int dvi_item = DVI$_DEVBUFSIZ;
7957         $DESCRIPTOR(mbxnam, "");
7958         $DESCRIPTOR(mbxdevnam, "");
7959
7960         /* Input from a pipe, reopen it in binary mode to disable       */
7961         /* carriage control processing.                                 */
7962
7963         fgetname(stdin, mbxname);
7964         mbxnam.dsc$a_pointer = mbxname;
7965         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7966         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7967         mbxdevnam.dsc$a_pointer = mbxname;
7968         mbxdevnam.dsc$w_length = sizeof(mbxname);
7969         dvi_item = DVI$_DEVNAM;
7970         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7971         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7972         set_errno(0);
7973         set_vaxc_errno(1);
7974         freopen(mbxname, "rb", stdin);
7975         if (errno != 0)
7976             {
7977             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7978             exit(vaxc$errno);
7979             }
7980         }
7981     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7982         {
7983         fprintf(stderr,"Can't open input file %s as stdin",in);
7984         exit(vaxc$errno);
7985         }
7986     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7987         {
7988         fprintf(stderr,"Can't open output file %s as stdout",out);
7989         exit(vaxc$errno);
7990         }
7991         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7992
7993     if (err != NULL) {
7994         if (strcmp(err,"&1") == 0) {
7995             dup2(fileno(stdout), fileno(stderr));
7996             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7997         } else {
7998         FILE *tmperr;
7999         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8000             {
8001             fprintf(stderr,"Can't open error file %s as stderr",err);
8002             exit(vaxc$errno);
8003             }
8004             fclose(tmperr);
8005            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8006                 {
8007                 exit(vaxc$errno);
8008                 }
8009             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8010         }
8011         }
8012 #ifdef ARGPROC_DEBUG
8013     PerlIO_printf(Perl_debug_log, "Arglist:\n");
8014     for (j = 0; j < *ac;  ++j)
8015         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8016 #endif
8017    /* Clear errors we may have hit expanding wildcards, so they don't
8018       show up in Perl's $! later */
8019    set_errno(0); set_vaxc_errno(1);
8020 }  /* end of getredirection() */
8021 /*}}}*/
8022
8023 static void add_item(struct list_item **head,
8024                      struct list_item **tail,
8025                      char *value,
8026                      int *count)
8027 {
8028     if (*head == 0)
8029         {
8030         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8031         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8032         *tail = *head;
8033         }
8034     else {
8035         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8036         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8037         *tail = (*tail)->next;
8038         }
8039     (*tail)->value = value;
8040     ++(*count);
8041 }
8042
8043 static void mp_expand_wild_cards(pTHX_ char *item,
8044                               struct list_item **head,
8045                               struct list_item **tail,
8046                               int *count)
8047 {
8048 int expcount = 0;
8049 unsigned long int context = 0;
8050 int isunix = 0;
8051 int item_len = 0;
8052 char *had_version;
8053 char *had_device;
8054 int had_directory;
8055 char *devdir,*cp;
8056 char *vmsspec;
8057 $DESCRIPTOR(filespec, "");
8058 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8059 $DESCRIPTOR(resultspec, "");
8060 unsigned long int lff_flags = 0;
8061 int sts;
8062 int rms_sts;
8063
8064 #ifdef VMS_LONGNAME_SUPPORT
8065     lff_flags = LIB$M_FIL_LONG_NAMES;
8066 #endif
8067
8068     for (cp = item; *cp; cp++) {
8069         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8070         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8071     }
8072     if (!*cp || isspace(*cp))
8073         {
8074         add_item(head, tail, item, count);
8075         return;
8076         }
8077     else
8078         {
8079      /* "double quoted" wild card expressions pass as is */
8080      /* From DCL that means using e.g.:                  */
8081      /* perl program """perl.*"""                        */
8082      item_len = strlen(item);
8083      if ( '"' == *item && '"' == item[item_len-1] )
8084        {
8085        item++;
8086        item[item_len-2] = '\0';
8087        add_item(head, tail, item, count);
8088        return;
8089        }
8090      }
8091     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8092     resultspec.dsc$b_class = DSC$K_CLASS_D;
8093     resultspec.dsc$a_pointer = NULL;
8094     vmsspec = PerlMem_malloc(VMS_MAXRSS);
8095     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8096     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8097       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8098     if (!isunix || !filespec.dsc$a_pointer)
8099       filespec.dsc$a_pointer = item;
8100     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8101     /*
8102      * Only return version specs, if the caller specified a version
8103      */
8104     had_version = strchr(item, ';');
8105     /*
8106      * Only return device and directory specs, if the caller specifed either.
8107      */
8108     had_device = strchr(item, ':');
8109     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8110
8111     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8112                                  (&filespec, &resultspec, &context,
8113                                   &defaultspec, 0, &rms_sts, &lff_flags)))
8114         {
8115         char *string;
8116         char *c;
8117
8118         string = PerlMem_malloc(resultspec.dsc$w_length+1);
8119         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8120         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8121         string[resultspec.dsc$w_length] = '\0';
8122         if (NULL == had_version)
8123             *(strrchr(string, ';')) = '\0';
8124         if ((!had_directory) && (had_device == NULL))
8125             {
8126             if (NULL == (devdir = strrchr(string, ']')))
8127                 devdir = strrchr(string, '>');
8128             strcpy(string, devdir + 1);
8129             }
8130         /*
8131          * Be consistent with what the C RTL has already done to the rest of
8132          * the argv items and lowercase all of these names.
8133          */
8134         if (!decc_efs_case_preserve) {
8135             for (c = string; *c; ++c)
8136             if (isupper(*c))
8137                 *c = tolower(*c);
8138         }
8139         if (isunix) trim_unixpath(string,item,1);
8140         add_item(head, tail, string, count);
8141         ++expcount;
8142     }
8143     PerlMem_free(vmsspec);
8144     if (sts != RMS$_NMF)
8145         {
8146         set_vaxc_errno(sts);
8147         switch (sts)
8148             {
8149             case RMS$_FNF: case RMS$_DNF:
8150                 set_errno(ENOENT); break;
8151             case RMS$_DIR:
8152                 set_errno(ENOTDIR); break;
8153             case RMS$_DEV:
8154                 set_errno(ENODEV); break;
8155             case RMS$_FNM: case RMS$_SYN:
8156                 set_errno(EINVAL); break;
8157             case RMS$_PRV:
8158                 set_errno(EACCES); break;
8159             default:
8160                 _ckvmssts_noperl(sts);
8161             }
8162         }
8163     if (expcount == 0)
8164         add_item(head, tail, item, count);
8165     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8166     _ckvmssts_noperl(lib$find_file_end(&context));
8167 }
8168
8169 static int child_st[2];/* Event Flag set when child process completes   */
8170
8171 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
8172
8173 static unsigned long int exit_handler(int *status)
8174 {
8175 short iosb[4];
8176
8177     if (0 == child_st[0])
8178         {
8179 #ifdef ARGPROC_DEBUG
8180         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8181 #endif
8182         fflush(stdout);     /* Have to flush pipe for binary data to    */
8183                             /* terminate properly -- <tp@mccall.com>    */
8184         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8185         sys$dassgn(child_chan);
8186         fclose(stdout);
8187         sys$synch(0, child_st);
8188         }
8189     return(1);
8190 }
8191
8192 static void sig_child(int chan)
8193 {
8194 #ifdef ARGPROC_DEBUG
8195     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8196 #endif
8197     if (child_st[0] == 0)
8198         child_st[0] = 1;
8199 }
8200
8201 static struct exit_control_block exit_block =
8202     {
8203     0,
8204     exit_handler,
8205     1,
8206     &exit_block.exit_status,
8207     0
8208     };
8209
8210 static void
8211 pipe_and_fork(pTHX_ char **cmargv)
8212 {
8213     PerlIO *fp;
8214     struct dsc$descriptor_s *vmscmd;
8215     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8216     int sts, j, l, ismcr, quote, tquote = 0;
8217
8218     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8219     vms_execfree(vmscmd);
8220
8221     j = l = 0;
8222     p = subcmd;
8223     q = cmargv[0];
8224     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
8225               && toupper(*(q+2)) == 'R' && !*(q+3);
8226
8227     while (q && l < MAX_DCL_LINE_LENGTH) {
8228         if (!*q) {
8229             if (j > 0 && quote) {
8230                 *p++ = '"';
8231                 l++;
8232             }
8233             q = cmargv[++j];
8234             if (q) {
8235                 if (ismcr && j > 1) quote = 1;
8236                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
8237                 *p++ = ' ';
8238                 l++;
8239                 if (quote || tquote) {
8240                     *p++ = '"';
8241                     l++;
8242                 }
8243             }
8244         } else {
8245             if ((quote||tquote) && *q == '"') {
8246                 *p++ = '"';
8247                 l++;
8248             }
8249             *p++ = *q++;
8250             l++;
8251         }
8252     }
8253     *p = '\0';
8254
8255     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8256     if (fp == Nullfp) {
8257         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8258     }
8259 }
8260
8261 static int background_process(pTHX_ int argc, char **argv)
8262 {
8263 char command[MAX_DCL_SYMBOL + 1] = "$";
8264 $DESCRIPTOR(value, "");
8265 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8266 static $DESCRIPTOR(null, "NLA0:");
8267 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8268 char pidstring[80];
8269 $DESCRIPTOR(pidstr, "");
8270 int pid;
8271 unsigned long int flags = 17, one = 1, retsts;
8272 int len;
8273
8274     strcat(command, argv[0]);
8275     len = strlen(command);
8276     while (--argc && (len < MAX_DCL_SYMBOL))
8277         {
8278         strcat(command, " \"");
8279         strcat(command, *(++argv));
8280         strcat(command, "\"");
8281         len = strlen(command);
8282         }
8283     value.dsc$a_pointer = command;
8284     value.dsc$w_length = strlen(value.dsc$a_pointer);
8285     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8286     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8287     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8288         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8289     }
8290     else {
8291         _ckvmssts_noperl(retsts);
8292     }
8293 #ifdef ARGPROC_DEBUG
8294     PerlIO_printf(Perl_debug_log, "%s\n", command);
8295 #endif
8296     sprintf(pidstring, "%08X", pid);
8297     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8298     pidstr.dsc$a_pointer = pidstring;
8299     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8300     lib$set_symbol(&pidsymbol, &pidstr);
8301     return(SS$_NORMAL);
8302 }
8303 /*}}}*/
8304 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8305
8306
8307 /* OS-specific initialization at image activation (not thread startup) */
8308 /* Older VAXC header files lack these constants */
8309 #ifndef JPI$_RIGHTS_SIZE
8310 #  define JPI$_RIGHTS_SIZE 817
8311 #endif
8312 #ifndef KGB$M_SUBSYSTEM
8313 #  define KGB$M_SUBSYSTEM 0x8
8314 #endif
8315
8316 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8317
8318 /*{{{void vms_image_init(int *, char ***)*/
8319 void
8320 vms_image_init(int *argcp, char ***argvp)
8321 {
8322   char eqv[LNM$C_NAMLENGTH+1] = "";
8323   unsigned int len, tabct = 8, tabidx = 0;
8324   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8325   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8326   unsigned short int dummy, rlen;
8327   struct dsc$descriptor_s **tabvec;
8328 #if defined(PERL_IMPLICIT_CONTEXT)
8329   pTHX = NULL;
8330 #endif
8331   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8332                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8333                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8334                                  {          0,                0,    0,      0} };
8335
8336 #ifdef KILL_BY_SIGPRC
8337     Perl_csighandler_init();
8338 #endif
8339
8340   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8341   _ckvmssts_noperl(iosb[0]);
8342   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8343     if (iprv[i]) {           /* Running image installed with privs? */
8344       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8345       will_taint = TRUE;
8346       break;
8347     }
8348   }
8349   /* Rights identifiers might trigger tainting as well. */
8350   if (!will_taint && (rlen || rsz)) {
8351     while (rlen < rsz) {
8352       /* We didn't get all the identifiers on the first pass.  Allocate a
8353        * buffer much larger than $GETJPI wants (rsz is size in bytes that
8354        * were needed to hold all identifiers at time of last call; we'll
8355        * allocate that many unsigned long ints), and go back and get 'em.
8356        * If it gave us less than it wanted to despite ample buffer space,
8357        * something's broken.  Is your system missing a system identifier?
8358        */
8359       if (rsz <= jpilist[1].buflen) {
8360          /* Perl_croak accvios when used this early in startup. */
8361          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8362                          rsz, (unsigned long) jpilist[1].buflen,
8363                          "Check your rights database for corruption.\n");
8364          exit(SS$_ABORT);
8365       }
8366       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8367       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8368       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8369       jpilist[1].buflen = rsz * sizeof(unsigned long int);
8370       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8371       _ckvmssts_noperl(iosb[0]);
8372     }
8373     mask = jpilist[1].bufadr;
8374     /* Check attribute flags for each identifier (2nd longword); protected
8375      * subsystem identifiers trigger tainting.
8376      */
8377     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8378       if (mask[i] & KGB$M_SUBSYSTEM) {
8379         will_taint = TRUE;
8380         break;
8381       }
8382     }
8383     if (mask != rlst) PerlMem_free(mask);
8384   }
8385
8386   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8387    * logical, some versions of the CRTL will add a phanthom /000000/
8388    * directory.  This needs to be removed.
8389    */
8390   if (decc_filename_unix_report) {
8391   char * zeros;
8392   int ulen;
8393     ulen = strlen(argvp[0][0]);
8394     if (ulen > 7) {
8395       zeros = strstr(argvp[0][0], "/000000/");
8396       if (zeros != NULL) {
8397         int mlen;
8398         mlen = ulen - (zeros - argvp[0][0]) - 7;
8399         memmove(zeros, &zeros[7], mlen);
8400         ulen = ulen - 7;
8401         argvp[0][0][ulen] = '\0';
8402       }
8403     }
8404     /* It also may have a trailing dot that needs to be removed otherwise
8405      * it will be converted to VMS mode incorrectly.
8406      */
8407     ulen--;
8408     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8409       argvp[0][0][ulen] = '\0';
8410   }
8411
8412   /* We need to use this hack to tell Perl it should run with tainting,
8413    * since its tainting flag may be part of the PL_curinterp struct, which
8414    * hasn't been allocated when vms_image_init() is called.
8415    */
8416   if (will_taint) {
8417     char **newargv, **oldargv;
8418     oldargv = *argvp;
8419     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8420     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8421     newargv[0] = oldargv[0];
8422     newargv[1] = PerlMem_malloc(3 * sizeof(char));
8423     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8424     strcpy(newargv[1], "-T");
8425     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8426     (*argcp)++;
8427     newargv[*argcp] = NULL;
8428     /* We orphan the old argv, since we don't know where it's come from,
8429      * so we don't know how to free it.
8430      */
8431     *argvp = newargv;
8432   }
8433   else {  /* Did user explicitly request tainting? */
8434     int i;
8435     char *cp, **av = *argvp;
8436     for (i = 1; i < *argcp; i++) {
8437       if (*av[i] != '-') break;
8438       for (cp = av[i]+1; *cp; cp++) {
8439         if (*cp == 'T') { will_taint = 1; break; }
8440         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8441                   strchr("DFIiMmx",*cp)) break;
8442       }
8443       if (will_taint) break;
8444     }
8445   }
8446
8447   for (tabidx = 0;
8448        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8449        tabidx++) {
8450     if (!tabidx) {
8451       tabvec = (struct dsc$descriptor_s **)
8452             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8453       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8454     }
8455     else if (tabidx >= tabct) {
8456       tabct += 8;
8457       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8458       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8459     }
8460     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8461     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8462     tabvec[tabidx]->dsc$w_length  = 0;
8463     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
8464     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
8465     tabvec[tabidx]->dsc$a_pointer = NULL;
8466     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8467   }
8468   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8469
8470   getredirection(argcp,argvp);
8471 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8472   {
8473 # include <reentrancy.h>
8474   decc$set_reentrancy(C$C_MULTITHREAD);
8475   }
8476 #endif
8477   return;
8478 }
8479 /*}}}*/
8480
8481
8482 /* trim_unixpath()
8483  * Trim Unix-style prefix off filespec, so it looks like what a shell
8484  * glob expansion would return (i.e. from specified prefix on, not
8485  * full path).  Note that returned filespec is Unix-style, regardless
8486  * of whether input filespec was VMS-style or Unix-style.
8487  *
8488  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8489  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
8490  * vector of options; at present, only bit 0 is used, and if set tells
8491  * trim unixpath to try the current default directory as a prefix when
8492  * presented with a possibly ambiguous ... wildcard.
8493  *
8494  * Returns !=0 on success, with trimmed filespec replacing contents of
8495  * fspec, and 0 on failure, with contents of fpsec unchanged.
8496  */
8497 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8498 int
8499 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8500 {
8501   char *unixified, *unixwild,
8502        *template, *base, *end, *cp1, *cp2;
8503   register int tmplen, reslen = 0, dirs = 0;
8504
8505   unixwild = PerlMem_malloc(VMS_MAXRSS);
8506   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8507   if (!wildspec || !fspec) return 0;
8508   template = unixwild;
8509   if (strpbrk(wildspec,"]>:") != NULL) {
8510     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8511         PerlMem_free(unixwild);
8512         return 0;
8513     }
8514   }
8515   else {
8516     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8517     unixwild[VMS_MAXRSS-1] = 0;
8518   }
8519   unixified = PerlMem_malloc(VMS_MAXRSS);
8520   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8521   if (strpbrk(fspec,"]>:") != NULL) {
8522     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8523         PerlMem_free(unixwild);
8524         PerlMem_free(unixified);
8525         return 0;
8526     }
8527     else base = unixified;
8528     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8529      * check to see that final result fits into (isn't longer than) fspec */
8530     reslen = strlen(fspec);
8531   }
8532   else base = fspec;
8533
8534   /* No prefix or absolute path on wildcard, so nothing to remove */
8535   if (!*template || *template == '/') {
8536     PerlMem_free(unixwild);
8537     if (base == fspec) {
8538         PerlMem_free(unixified);
8539         return 1;
8540     }
8541     tmplen = strlen(unixified);
8542     if (tmplen > reslen) {
8543         PerlMem_free(unixified);
8544         return 0;  /* not enough space */
8545     }
8546     /* Copy unixified resultant, including trailing NUL */
8547     memmove(fspec,unixified,tmplen+1);
8548     PerlMem_free(unixified);
8549     return 1;
8550   }
8551
8552   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
8553   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8554     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8555     for (cp1 = end ;cp1 >= base; cp1--)
8556       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8557         { cp1++; break; }
8558     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8559     PerlMem_free(unixified);
8560     PerlMem_free(unixwild);
8561     return 1;
8562   }
8563   else {
8564     char *tpl, *lcres;
8565     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8566     int ells = 1, totells, segdirs, match;
8567     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8568                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8569
8570     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8571     totells = ells;
8572     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8573     tpl = PerlMem_malloc(VMS_MAXRSS);
8574     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8575     if (ellipsis == template && opts & 1) {
8576       /* Template begins with an ellipsis.  Since we can't tell how many
8577        * directory names at the front of the resultant to keep for an
8578        * arbitrary starting point, we arbitrarily choose the current
8579        * default directory as a starting point.  If it's there as a prefix,
8580        * clip it off.  If not, fall through and act as if the leading
8581        * ellipsis weren't there (i.e. return shortest possible path that
8582        * could match template).
8583        */
8584       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8585           PerlMem_free(tpl);
8586           PerlMem_free(unixified);
8587           PerlMem_free(unixwild);
8588           return 0;
8589       }
8590       if (!decc_efs_case_preserve) {
8591         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8592           if (_tolower(*cp1) != _tolower(*cp2)) break;
8593       }
8594       segdirs = dirs - totells;  /* Min # of dirs we must have left */
8595       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8596       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8597         memmove(fspec,cp2+1,end - cp2);
8598         PerlMem_free(tpl);
8599         PerlMem_free(unixified);
8600         PerlMem_free(unixwild);
8601         return 1;
8602       }
8603     }
8604     /* First off, back up over constant elements at end of path */
8605     if (dirs) {
8606       for (front = end ; front >= base; front--)
8607          if (*front == '/' && !dirs--) { front++; break; }
8608     }
8609     lcres = PerlMem_malloc(VMS_MAXRSS);
8610     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8611     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8612          cp1++,cp2++) {
8613             if (!decc_efs_case_preserve) {
8614                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
8615             }
8616             else {
8617                 *cp2 = *cp1;
8618             }
8619     }
8620     if (cp1 != '\0') {
8621         PerlMem_free(tpl);
8622         PerlMem_free(unixified);
8623         PerlMem_free(unixwild);
8624         PerlMem_free(lcres);
8625         return 0;  /* Path too long. */
8626     }
8627     lcend = cp2;
8628     *cp2 = '\0';  /* Pick up with memcpy later */
8629     lcfront = lcres + (front - base);
8630     /* Now skip over each ellipsis and try to match the path in front of it. */
8631     while (ells--) {
8632       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8633         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
8634             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
8635       if (cp1 < template) break; /* template started with an ellipsis */
8636       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8637         ellipsis = cp1; continue;
8638       }
8639       wilddsc.dsc$a_pointer = tpl;
8640       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8641       nextell = cp1;
8642       for (segdirs = 0, cp2 = tpl;
8643            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8644            cp1++, cp2++) {
8645          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8646          else {
8647             if (!decc_efs_case_preserve) {
8648               *cp2 = _tolower(*cp1);  /* else lowercase for match */
8649             }
8650             else {
8651               *cp2 = *cp1;  /* else preserve case for match */
8652             }
8653          }
8654          if (*cp2 == '/') segdirs++;
8655       }
8656       if (cp1 != ellipsis - 1) {
8657           PerlMem_free(tpl);
8658           PerlMem_free(unixified);
8659           PerlMem_free(unixwild);
8660           PerlMem_free(lcres);
8661           return 0; /* Path too long */
8662       }
8663       /* Back up at least as many dirs as in template before matching */
8664       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8665         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8666       for (match = 0; cp1 > lcres;) {
8667         resdsc.dsc$a_pointer = cp1;
8668         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8669           match++;
8670           if (match == 1) lcfront = cp1;
8671         }
8672         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8673       }
8674       if (!match) {
8675         PerlMem_free(tpl);
8676         PerlMem_free(unixified);
8677         PerlMem_free(unixwild);
8678         PerlMem_free(lcres);
8679         return 0;  /* Can't find prefix ??? */
8680       }
8681       if (match > 1 && opts & 1) {
8682         /* This ... wildcard could cover more than one set of dirs (i.e.
8683          * a set of similar dir names is repeated).  If the template
8684          * contains more than 1 ..., upstream elements could resolve the
8685          * ambiguity, but it's not worth a full backtracking setup here.
8686          * As a quick heuristic, clip off the current default directory
8687          * if it's present to find the trimmed spec, else use the
8688          * shortest string that this ... could cover.
8689          */
8690         char def[NAM$C_MAXRSS+1], *st;
8691
8692         if (getcwd(def, sizeof def,0) == NULL) {
8693             Safefree(unixified);
8694             Safefree(unixwild);
8695             Safefree(lcres);
8696             Safefree(tpl);
8697             return 0;
8698         }
8699         if (!decc_efs_case_preserve) {
8700           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8701             if (_tolower(*cp1) != _tolower(*cp2)) break;
8702         }
8703         segdirs = dirs - totells;  /* Min # of dirs we must have left */
8704         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8705         if (*cp1 == '\0' && *cp2 == '/') {
8706           memmove(fspec,cp2+1,end - cp2);
8707           PerlMem_free(tpl);
8708           PerlMem_free(unixified);
8709           PerlMem_free(unixwild);
8710           PerlMem_free(lcres);
8711           return 1;
8712         }
8713         /* Nope -- stick with lcfront from above and keep going. */
8714       }
8715     }
8716     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8717     PerlMem_free(tpl);
8718     PerlMem_free(unixified);
8719     PerlMem_free(unixwild);
8720     PerlMem_free(lcres);
8721     return 1;
8722     ellipsis = nextell;
8723   }
8724
8725 }  /* end of trim_unixpath() */
8726 /*}}}*/
8727
8728
8729 /*
8730  *  VMS readdir() routines.
8731  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8732  *
8733  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
8734  *  Minor modifications to original routines.
8735  */
8736
8737 /* readdir may have been redefined by reentr.h, so make sure we get
8738  * the local version for what we do here.
8739  */
8740 #ifdef readdir
8741 # undef readdir
8742 #endif
8743 #if !defined(PERL_IMPLICIT_CONTEXT)
8744 # define readdir Perl_readdir
8745 #else
8746 # define readdir(a) Perl_readdir(aTHX_ a)
8747 #endif
8748
8749     /* Number of elements in vms_versions array */
8750 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
8751
8752 /*
8753  *  Open a directory, return a handle for later use.
8754  */
8755 /*{{{ DIR *opendir(char*name) */
8756 DIR *
8757 Perl_opendir(pTHX_ const char *name)
8758 {
8759     DIR *dd;
8760     char *dir;
8761     Stat_t sb;
8762
8763     Newx(dir, VMS_MAXRSS, char);
8764     if (do_tovmspath(name,dir,0,NULL) == NULL) {
8765       Safefree(dir);
8766       return NULL;
8767     }
8768     /* Check access before stat; otherwise stat does not
8769      * accurately report whether it's a directory.
8770      */
8771     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8772       /* cando_by_name has already set errno */
8773       Safefree(dir);
8774       return NULL;
8775     }
8776     if (flex_stat(dir,&sb) == -1) return NULL;
8777     if (!S_ISDIR(sb.st_mode)) {
8778       Safefree(dir);
8779       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
8780       return NULL;
8781     }
8782     /* Get memory for the handle, and the pattern. */
8783     Newx(dd,1,DIR);
8784     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8785
8786     /* Fill in the fields; mainly playing with the descriptor. */
8787     sprintf(dd->pattern, "%s*.*",dir);
8788     Safefree(dir);
8789     dd->context = 0;
8790     dd->count = 0;
8791     dd->flags = 0;
8792     /* By saying we always want the result of readdir() in unix format, we
8793      * are really saying we want all the escapes removed.  Otherwise the caller,
8794      * having no way to know whether it's already in VMS format, might send it
8795      * through tovmsspec again, thus double escaping.
8796      */
8797     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8798     dd->pat.dsc$a_pointer = dd->pattern;
8799     dd->pat.dsc$w_length = strlen(dd->pattern);
8800     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8801     dd->pat.dsc$b_class = DSC$K_CLASS_S;
8802 #if defined(USE_ITHREADS)
8803     Newx(dd->mutex,1,perl_mutex);
8804     MUTEX_INIT( (perl_mutex *) dd->mutex );
8805 #else
8806     dd->mutex = NULL;
8807 #endif
8808
8809     return dd;
8810 }  /* end of opendir() */
8811 /*}}}*/
8812
8813 /*
8814  *  Set the flag to indicate we want versions or not.
8815  */
8816 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8817 void
8818 vmsreaddirversions(DIR *dd, int flag)
8819 {
8820     if (flag)
8821         dd->flags |= PERL_VMSDIR_M_VERSIONS;
8822     else
8823         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8824 }
8825 /*}}}*/
8826
8827 /*
8828  *  Free up an opened directory.
8829  */
8830 /*{{{ void closedir(DIR *dd)*/
8831 void
8832 Perl_closedir(DIR *dd)
8833 {
8834     int sts;
8835
8836     sts = lib$find_file_end(&dd->context);
8837     Safefree(dd->pattern);
8838 #if defined(USE_ITHREADS)
8839     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8840     Safefree(dd->mutex);
8841 #endif
8842     Safefree(dd);
8843 }
8844 /*}}}*/
8845
8846 /*
8847  *  Collect all the version numbers for the current file.
8848  */
8849 static void
8850 collectversions(pTHX_ DIR *dd)
8851 {
8852     struct dsc$descriptor_s     pat;
8853     struct dsc$descriptor_s     res;
8854     struct dirent *e;
8855     char *p, *text, *buff;
8856     int i;
8857     unsigned long context, tmpsts;
8858
8859     /* Convenient shorthand. */
8860     e = &dd->entry;
8861
8862     /* Add the version wildcard, ignoring the "*.*" put on before */
8863     i = strlen(dd->pattern);
8864     Newx(text,i + e->d_namlen + 3,char);
8865     strcpy(text, dd->pattern);
8866     sprintf(&text[i - 3], "%s;*", e->d_name);
8867
8868     /* Set up the pattern descriptor. */
8869     pat.dsc$a_pointer = text;
8870     pat.dsc$w_length = i + e->d_namlen - 1;
8871     pat.dsc$b_dtype = DSC$K_DTYPE_T;
8872     pat.dsc$b_class = DSC$K_CLASS_S;
8873
8874     /* Set up result descriptor. */
8875     Newx(buff, VMS_MAXRSS, char);
8876     res.dsc$a_pointer = buff;
8877     res.dsc$w_length = VMS_MAXRSS - 1;
8878     res.dsc$b_dtype = DSC$K_DTYPE_T;
8879     res.dsc$b_class = DSC$K_CLASS_S;
8880
8881     /* Read files, collecting versions. */
8882     for (context = 0, e->vms_verscount = 0;
8883          e->vms_verscount < VERSIZE(e);
8884          e->vms_verscount++) {
8885         unsigned long rsts;
8886         unsigned long flags = 0;
8887
8888 #ifdef VMS_LONGNAME_SUPPORT
8889         flags = LIB$M_FIL_LONG_NAMES;
8890 #endif
8891         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8892         if (tmpsts == RMS$_NMF || context == 0) break;
8893         _ckvmssts(tmpsts);
8894         buff[VMS_MAXRSS - 1] = '\0';
8895         if ((p = strchr(buff, ';')))
8896             e->vms_versions[e->vms_verscount] = atoi(p + 1);
8897         else
8898             e->vms_versions[e->vms_verscount] = -1;
8899     }
8900
8901     _ckvmssts(lib$find_file_end(&context));
8902     Safefree(text);
8903     Safefree(buff);
8904
8905 }  /* end of collectversions() */
8906
8907 /*
8908  *  Read the next entry from the directory.
8909  */
8910 /*{{{ struct dirent *readdir(DIR *dd)*/
8911 struct dirent *
8912 Perl_readdir(pTHX_ DIR *dd)
8913 {
8914     struct dsc$descriptor_s     res;
8915     char *p, *buff;
8916     unsigned long int tmpsts;
8917     unsigned long rsts;
8918     unsigned long flags = 0;
8919     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8920     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8921
8922     /* Set up result descriptor, and get next file. */
8923     Newx(buff, VMS_MAXRSS, char);
8924     res.dsc$a_pointer = buff;
8925     res.dsc$w_length = VMS_MAXRSS - 1;
8926     res.dsc$b_dtype = DSC$K_DTYPE_T;
8927     res.dsc$b_class = DSC$K_CLASS_S;
8928
8929 #ifdef VMS_LONGNAME_SUPPORT
8930     flags = LIB$M_FIL_LONG_NAMES;
8931 #endif
8932
8933     tmpsts = lib$find_file
8934         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8935     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
8936     if (!(tmpsts & 1)) {
8937       set_vaxc_errno(tmpsts);
8938       switch (tmpsts) {
8939         case RMS$_PRV:
8940           set_errno(EACCES); break;
8941         case RMS$_DEV:
8942           set_errno(ENODEV); break;
8943         case RMS$_DIR:
8944           set_errno(ENOTDIR); break;
8945         case RMS$_FNF: case RMS$_DNF:
8946           set_errno(ENOENT); break;
8947         default:
8948           set_errno(EVMSERR);
8949       }
8950       Safefree(buff);
8951       return NULL;
8952     }
8953     dd->count++;
8954     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8955     if (!decc_efs_case_preserve) {
8956       buff[VMS_MAXRSS - 1] = '\0';
8957       for (p = buff; *p; p++) *p = _tolower(*p);
8958     }
8959     else {
8960       /* we don't want to force to lowercase, just null terminate */
8961       buff[res.dsc$w_length] = '\0';
8962     }
8963     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
8964     *p = '\0';
8965
8966     /* Skip any directory component and just copy the name. */
8967     sts = vms_split_path
8968        (buff,
8969         &v_spec,
8970         &v_len,
8971         &r_spec,
8972         &r_len,
8973         &d_spec,
8974         &d_len,
8975         &n_spec,
8976         &n_len,
8977         &e_spec,
8978         &e_len,
8979         &vs_spec,
8980         &vs_len);
8981
8982     /* Drop NULL extensions on UNIX file specification */
8983     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8984         (e_len == 1) && decc_readdir_dropdotnotype)) {
8985         e_len = 0;
8986         e_spec[0] = '\0';
8987     }
8988
8989     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8990     dd->entry.d_name[n_len + e_len] = '\0';
8991     dd->entry.d_namlen = strlen(dd->entry.d_name);
8992
8993     /* Convert the filename to UNIX format if needed */
8994     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8995
8996         /* Translate the encoded characters. */
8997         /* Fixme: unicode handling could result in embedded 0 characters */
8998         if (strchr(dd->entry.d_name, '^') != NULL) {
8999             char new_name[256];
9000             char * q;
9001             p = dd->entry.d_name;
9002             q = new_name;
9003             while (*p != 0) {
9004                 int inchars_read, outchars_added;
9005                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9006                 p += inchars_read;
9007                 q += outchars_added;
9008                 /* fix-me */
9009                 /* if outchars_added > 1, then this is a wide file specification */
9010                 /* Wide file specifications need to be passed in Perl */
9011                 /* counted strings apparently with a unicode flag */
9012             }
9013             *q = 0;
9014             strcpy(dd->entry.d_name, new_name);
9015             dd->entry.d_namlen = strlen(dd->entry.d_name);
9016         }
9017     }
9018
9019     dd->entry.vms_verscount = 0;
9020     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9021     Safefree(buff);
9022     return &dd->entry;
9023
9024 }  /* end of readdir() */
9025 /*}}}*/
9026
9027 /*
9028  *  Read the next entry from the directory -- thread-safe version.
9029  */
9030 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9031 int
9032 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9033 {
9034     int retval;
9035
9036     MUTEX_LOCK( (perl_mutex *) dd->mutex );
9037
9038     entry = readdir(dd);
9039     *result = entry;
9040     retval = ( *result == NULL ? errno : 0 );
9041
9042     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9043
9044     return retval;
9045
9046 }  /* end of readdir_r() */
9047 /*}}}*/
9048
9049 /*
9050  *  Return something that can be used in a seekdir later.
9051  */
9052 /*{{{ long telldir(DIR *dd)*/
9053 long
9054 Perl_telldir(DIR *dd)
9055 {
9056     return dd->count;
9057 }
9058 /*}}}*/
9059
9060 /*
9061  *  Return to a spot where we used to be.  Brute force.
9062  */
9063 /*{{{ void seekdir(DIR *dd,long count)*/
9064 void
9065 Perl_seekdir(pTHX_ DIR *dd, long count)
9066 {
9067     int old_flags;
9068
9069     /* If we haven't done anything yet... */
9070     if (dd->count == 0)
9071         return;
9072
9073     /* Remember some state, and clear it. */
9074     old_flags = dd->flags;
9075     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9076     _ckvmssts(lib$find_file_end(&dd->context));
9077     dd->context = 0;
9078
9079     /* The increment is in readdir(). */
9080     for (dd->count = 0; dd->count < count; )
9081         readdir(dd);
9082
9083     dd->flags = old_flags;
9084
9085 }  /* end of seekdir() */
9086 /*}}}*/
9087
9088 /* VMS subprocess management
9089  *
9090  * my_vfork() - just a vfork(), after setting a flag to record that
9091  * the current script is trying a Unix-style fork/exec.
9092  *
9093  * vms_do_aexec() and vms_do_exec() are called in response to the
9094  * perl 'exec' function.  If this follows a vfork call, then they
9095  * call out the regular perl routines in doio.c which do an
9096  * execvp (for those who really want to try this under VMS).
9097  * Otherwise, they do exactly what the perl docs say exec should
9098  * do - terminate the current script and invoke a new command
9099  * (See below for notes on command syntax.)
9100  *
9101  * do_aspawn() and do_spawn() implement the VMS side of the perl
9102  * 'system' function.
9103  *
9104  * Note on command arguments to perl 'exec' and 'system': When handled
9105  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9106  * are concatenated to form a DCL command string.  If the first arg
9107  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
9108  * the command string is handed off to DCL directly.  Otherwise,
9109  * the first token of the command is taken as the filespec of an image
9110  * to run.  The filespec is expanded using a default type of '.EXE' and
9111  * the process defaults for device, directory, etc., and if found, the resultant
9112  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9113  * the command string as parameters.  This is perhaps a bit complicated,
9114  * but I hope it will form a happy medium between what VMS folks expect
9115  * from lib$spawn and what Unix folks expect from exec.
9116  */
9117
9118 static int vfork_called;
9119
9120 /*{{{int my_vfork()*/
9121 int
9122 my_vfork()
9123 {
9124   vfork_called++;
9125   return vfork();
9126 }
9127 /*}}}*/
9128
9129
9130 static void
9131 vms_execfree(struct dsc$descriptor_s *vmscmd)
9132 {
9133   if (vmscmd) {
9134       if (vmscmd->dsc$a_pointer) {
9135           PerlMem_free(vmscmd->dsc$a_pointer);
9136       }
9137       PerlMem_free(vmscmd);
9138   }
9139 }
9140
9141 static char *
9142 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9143 {
9144   char *junk, *tmps = Nullch;
9145   register size_t cmdlen = 0;
9146   size_t rlen;
9147   register SV **idx;
9148   STRLEN n_a;
9149
9150   idx = mark;
9151   if (really) {
9152     tmps = SvPV(really,rlen);
9153     if (*tmps) {
9154       cmdlen += rlen + 1;
9155       idx++;
9156     }
9157   }
9158
9159   for (idx++; idx <= sp; idx++) {
9160     if (*idx) {
9161       junk = SvPVx(*idx,rlen);
9162       cmdlen += rlen ? rlen + 1 : 0;
9163     }
9164   }
9165   Newx(PL_Cmd, cmdlen+1, char);
9166
9167   if (tmps && *tmps) {
9168     strcpy(PL_Cmd,tmps);
9169     mark++;
9170   }
9171   else *PL_Cmd = '\0';
9172   while (++mark <= sp) {
9173     if (*mark) {
9174       char *s = SvPVx(*mark,n_a);
9175       if (!*s) continue;
9176       if (*PL_Cmd) strcat(PL_Cmd," ");
9177       strcat(PL_Cmd,s);
9178     }
9179   }
9180   return PL_Cmd;
9181
9182 }  /* end of setup_argstr() */
9183
9184
9185 static unsigned long int
9186 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9187                    struct dsc$descriptor_s **pvmscmd)
9188 {
9189   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9190   char image_name[NAM$C_MAXRSS+1];
9191   char image_argv[NAM$C_MAXRSS+1];
9192   $DESCRIPTOR(defdsc,".EXE");
9193   $DESCRIPTOR(defdsc2,".");
9194   $DESCRIPTOR(resdsc,resspec);
9195   struct dsc$descriptor_s *vmscmd;
9196   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9197   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9198   register char *s, *rest, *cp, *wordbreak;
9199   char * cmd;
9200   int cmdlen;
9201   register int isdcl;
9202
9203   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9204   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9205
9206   /* Make a copy for modification */
9207   cmdlen = strlen(incmd);
9208   cmd = PerlMem_malloc(cmdlen+1);
9209   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9210   strncpy(cmd, incmd, cmdlen);
9211   cmd[cmdlen] = 0;
9212   image_name[0] = 0;
9213   image_argv[0] = 0;
9214
9215   vmscmd->dsc$a_pointer = NULL;
9216   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
9217   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
9218   vmscmd->dsc$w_length = 0;
9219   if (pvmscmd) *pvmscmd = vmscmd;
9220
9221   if (suggest_quote) *suggest_quote = 0;
9222
9223   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9224     PerlMem_free(cmd);
9225     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
9226   }
9227
9228   s = cmd;
9229
9230   while (*s && isspace(*s)) s++;
9231
9232   if (*s == '@' || *s == '$') {
9233     vmsspec[0] = *s;  rest = s + 1;
9234     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9235   }
9236   else { cp = vmsspec; rest = s; }
9237   if (*rest == '.' || *rest == '/') {
9238     char *cp2;
9239     for (cp2 = resspec;
9240          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9241          rest++, cp2++) *cp2 = *rest;
9242     *cp2 = '\0';
9243     if (do_tovmsspec(resspec,cp,0,NULL)) {
9244       s = vmsspec;
9245       if (*rest) {
9246         for (cp2 = vmsspec + strlen(vmsspec);
9247              *rest && cp2 - vmsspec < sizeof vmsspec;
9248              rest++, cp2++) *cp2 = *rest;
9249         *cp2 = '\0';
9250       }
9251     }
9252   }
9253   /* Intuit whether verb (first word of cmd) is a DCL command:
9254    *   - if first nonspace char is '@', it's a DCL indirection
9255    * otherwise
9256    *   - if verb contains a filespec separator, it's not a DCL command
9257    *   - if it doesn't, caller tells us whether to default to a DCL
9258    *     command, or to a local image unless told it's DCL (by leading '$')
9259    */
9260   if (*s == '@') {
9261       isdcl = 1;
9262       if (suggest_quote) *suggest_quote = 1;
9263   } else {
9264     register char *filespec = strpbrk(s,":<[.;");
9265     rest = wordbreak = strpbrk(s," \"\t/");
9266     if (!wordbreak) wordbreak = s + strlen(s);
9267     if (*s == '$') check_img = 0;
9268     if (filespec && (filespec < wordbreak)) isdcl = 0;
9269     else isdcl = !check_img;
9270   }
9271
9272   if (!isdcl) {
9273     int rsts;
9274     imgdsc.dsc$a_pointer = s;
9275     imgdsc.dsc$w_length = wordbreak - s;
9276     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9277     if (!(retsts&1)) {
9278         _ckvmssts(lib$find_file_end(&cxt));
9279         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9280       if (!(retsts & 1) && *s == '$') {
9281         _ckvmssts(lib$find_file_end(&cxt));
9282         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9283         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9284         if (!(retsts&1)) {
9285           _ckvmssts(lib$find_file_end(&cxt));
9286           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9287         }
9288       }
9289     }
9290     _ckvmssts(lib$find_file_end(&cxt));
9291
9292     if (retsts & 1) {
9293       FILE *fp;
9294       s = resspec;
9295       while (*s && !isspace(*s)) s++;
9296       *s = '\0';
9297
9298       /* check that it's really not DCL with no file extension */
9299       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9300       if (fp) {
9301         char b[256] = {0,0,0,0};
9302         read(fileno(fp), b, 256);
9303         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9304         if (isdcl) {
9305           int shebang_len;
9306
9307           /* Check for script */
9308           shebang_len = 0;
9309           if ((b[0] == '#') && (b[1] == '!'))
9310              shebang_len = 2;
9311 #ifdef ALTERNATE_SHEBANG
9312           else {
9313             shebang_len = strlen(ALTERNATE_SHEBANG);
9314             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9315               char * perlstr;
9316                 perlstr = strstr("perl",b);
9317                 if (perlstr == NULL)
9318                   shebang_len = 0;
9319             }
9320             else
9321               shebang_len = 0;
9322           }
9323 #endif
9324
9325           if (shebang_len > 0) {
9326           int i;
9327           int j;
9328           char tmpspec[NAM$C_MAXRSS + 1];
9329
9330             i = shebang_len;
9331              /* Image is following after white space */
9332             /*--------------------------------------*/
9333             while (isprint(b[i]) && isspace(b[i]))
9334                 i++;
9335
9336             j = 0;
9337             while (isprint(b[i]) && !isspace(b[i])) {
9338                 tmpspec[j++] = b[i++];
9339                 if (j >= NAM$C_MAXRSS)
9340                    break;
9341             }
9342             tmpspec[j] = '\0';
9343
9344              /* There may be some default parameters to the image */
9345             /*---------------------------------------------------*/
9346             j = 0;
9347             while (isprint(b[i])) {
9348                 image_argv[j++] = b[i++];
9349                 if (j >= NAM$C_MAXRSS)
9350                    break;
9351             }
9352             while ((j > 0) && !isprint(image_argv[j-1]))
9353                 j--;
9354             image_argv[j] = 0;
9355
9356             /* It will need to be converted to VMS format and validated */
9357             if (tmpspec[0] != '\0') {
9358               char * iname;
9359
9360                /* Try to find the exact program requested to be run */
9361               /*---------------------------------------------------*/
9362               iname = do_rmsexpand
9363                  (tmpspec, image_name, 0, ".exe",
9364                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
9365               if (iname != NULL) {
9366                 if (cando_by_name_int
9367                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9368                   /* MCR prefix needed */
9369                   isdcl = 0;
9370                 }
9371                 else {
9372                    /* Try again with a null type */
9373                   /*----------------------------*/
9374                   iname = do_rmsexpand
9375                     (tmpspec, image_name, 0, ".",
9376                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
9377                   if (iname != NULL) {
9378                     if (cando_by_name_int
9379                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9380                       /* MCR prefix needed */
9381                       isdcl = 0;
9382                     }
9383                   }
9384                 }
9385
9386                  /* Did we find the image to run the script? */
9387                 /*------------------------------------------*/
9388                 if (isdcl) {
9389                   char *tchr;
9390
9391                    /* Assume DCL or foreign command exists */
9392                   /*--------------------------------------*/
9393                   tchr = strrchr(tmpspec, '/');
9394                   if (tchr != NULL) {
9395                     tchr++;
9396                   }
9397                   else {
9398                     tchr = tmpspec;
9399                   }
9400                   strcpy(image_name, tchr);
9401                 }
9402               }
9403             }
9404           }
9405         }
9406         fclose(fp);
9407       }
9408       if (check_img && isdcl) return RMS$_FNF;
9409
9410       if (cando_by_name(S_IXUSR,0,resspec)) {
9411         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9412         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9413         if (!isdcl) {
9414             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9415             if (image_name[0] != 0) {
9416                 strcat(vmscmd->dsc$a_pointer, image_name);
9417                 strcat(vmscmd->dsc$a_pointer, " ");
9418             }
9419         } else if (image_name[0] != 0) {
9420             strcpy(vmscmd->dsc$a_pointer, image_name);
9421             strcat(vmscmd->dsc$a_pointer, " ");
9422         } else {
9423             strcpy(vmscmd->dsc$a_pointer,"@");
9424         }
9425         if (suggest_quote) *suggest_quote = 1;
9426
9427         /* If there is an image name, use original command */
9428         if (image_name[0] == 0)
9429             strcat(vmscmd->dsc$a_pointer,resspec);
9430         else {
9431             rest = cmd;
9432             while (*rest && isspace(*rest)) rest++;
9433         }
9434
9435         if (image_argv[0] != 0) {
9436           strcat(vmscmd->dsc$a_pointer,image_argv);
9437           strcat(vmscmd->dsc$a_pointer, " ");
9438         }
9439         if (rest) {
9440            int rest_len;
9441            int vmscmd_len;
9442
9443            rest_len = strlen(rest);
9444            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9445            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9446               strcat(vmscmd->dsc$a_pointer,rest);
9447            else
9448              retsts = CLI$_BUFOVF;
9449         }
9450         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9451         PerlMem_free(cmd);
9452         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9453       }
9454       else
9455         retsts = RMS$_PRV;
9456     }
9457   }
9458   /* It's either a DCL command or we couldn't find a suitable image */
9459   vmscmd->dsc$w_length = strlen(cmd);
9460
9461   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9462   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9463   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9464
9465   PerlMem_free(cmd);
9466
9467   /* check if it's a symbol (for quoting purposes) */
9468   if (suggest_quote && !*suggest_quote) {
9469     int iss;
9470     char equiv[LNM$C_NAMLENGTH];
9471     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9472     eqvdsc.dsc$a_pointer = equiv;
9473
9474     iss = lib$get_symbol(vmscmd,&eqvdsc);
9475     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9476   }
9477   if (!(retsts & 1)) {
9478     /* just hand off status values likely to be due to user error */
9479     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9480         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9481        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9482     else { _ckvmssts(retsts); }
9483   }
9484
9485   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9486
9487 }  /* end of setup_cmddsc() */
9488
9489
9490 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9491 bool
9492 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9493 {
9494 bool exec_sts;
9495 char * cmd;
9496
9497   if (sp > mark) {
9498     if (vfork_called) {           /* this follows a vfork - act Unixish */
9499       vfork_called--;
9500       if (vfork_called < 0) {
9501         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9502         vfork_called = 0;
9503       }
9504       else return do_aexec(really,mark,sp);
9505     }
9506                                            /* no vfork - act VMSish */
9507     cmd = setup_argstr(aTHX_ really,mark,sp);
9508     exec_sts = vms_do_exec(cmd);
9509     Safefree(cmd);  /* Clean up from setup_argstr() */
9510     return exec_sts;
9511   }
9512
9513   return FALSE;
9514 }  /* end of vms_do_aexec() */
9515 /*}}}*/
9516
9517 /* {{{bool vms_do_exec(char *cmd) */
9518 bool
9519 Perl_vms_do_exec(pTHX_ const char *cmd)
9520 {
9521   struct dsc$descriptor_s *vmscmd;
9522
9523   if (vfork_called) {             /* this follows a vfork - act Unixish */
9524     vfork_called--;
9525     if (vfork_called < 0) {
9526       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9527       vfork_called = 0;
9528     }
9529     else return do_exec(cmd);
9530   }
9531
9532   {                               /* no vfork - act VMSish */
9533     unsigned long int retsts;
9534
9535     TAINT_ENV();
9536     TAINT_PROPER("exec");
9537     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9538       retsts = lib$do_command(vmscmd);
9539
9540     switch (retsts) {
9541       case RMS$_FNF: case RMS$_DNF:
9542         set_errno(ENOENT); break;
9543       case RMS$_DIR:
9544         set_errno(ENOTDIR); break;
9545       case RMS$_DEV:
9546         set_errno(ENODEV); break;
9547       case RMS$_PRV:
9548         set_errno(EACCES); break;
9549       case RMS$_SYN:
9550         set_errno(EINVAL); break;
9551       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9552         set_errno(E2BIG); break;
9553       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9554         _ckvmssts(retsts); /* fall through */
9555       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9556         set_errno(EVMSERR);
9557     }
9558     set_vaxc_errno(retsts);
9559     if (ckWARN(WARN_EXEC)) {
9560       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9561              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9562     }
9563     vms_execfree(vmscmd);
9564   }
9565
9566   return FALSE;
9567
9568 }  /* end of vms_do_exec() */
9569 /*}}}*/
9570
9571 unsigned long int Perl_do_spawn(pTHX_ const char *);
9572
9573 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9574 unsigned long int
9575 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9576 {
9577 unsigned long int sts;
9578 char * cmd;
9579
9580   if (sp > mark) {
9581     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9582     sts = do_spawn(cmd);
9583     /* pp_sys will clean up cmd */
9584     return sts;
9585   }
9586   return SS$_ABORT;
9587 }  /* end of do_aspawn() */
9588 /*}}}*/
9589
9590 /* {{{unsigned long int do_spawn(char *cmd) */
9591 unsigned long int
9592 Perl_do_spawn(pTHX_ const char *cmd)
9593 {
9594   unsigned long int sts, substs;
9595
9596   /* The caller of this routine expects to Safefree(PL_Cmd) */
9597   Newx(PL_Cmd,10,char);
9598
9599   TAINT_ENV();
9600   TAINT_PROPER("spawn");
9601   if (!cmd || !*cmd) {
9602     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9603     if (!(sts & 1)) {
9604       switch (sts) {
9605         case RMS$_FNF:  case RMS$_DNF:
9606           set_errno(ENOENT); break;
9607         case RMS$_DIR:
9608           set_errno(ENOTDIR); break;
9609         case RMS$_DEV:
9610           set_errno(ENODEV); break;
9611         case RMS$_PRV:
9612           set_errno(EACCES); break;
9613         case RMS$_SYN:
9614           set_errno(EINVAL); break;
9615         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9616           set_errno(E2BIG); break;
9617         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9618           _ckvmssts(sts); /* fall through */
9619         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9620           set_errno(EVMSERR);
9621       }
9622       set_vaxc_errno(sts);
9623       if (ckWARN(WARN_EXEC)) {
9624         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9625                     Strerror(errno));
9626       }
9627     }
9628     sts = substs;
9629   }
9630   else {
9631     PerlIO * fp;
9632     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9633     if (fp != NULL)
9634       my_pclose(fp);
9635   }
9636   return sts;
9637 }  /* end of do_spawn() */
9638 /*}}}*/
9639
9640
9641 static unsigned int *sockflags, sockflagsize;
9642
9643 /*
9644  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9645  * routines found in some versions of the CRTL can't deal with sockets.
9646  * We don't shim the other file open routines since a socket isn't
9647  * likely to be opened by a name.
9648  */
9649 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9650 FILE *my_fdopen(int fd, const char *mode)
9651 {
9652   FILE *fp = fdopen(fd, mode);
9653
9654   if (fp) {
9655     unsigned int fdoff = fd / sizeof(unsigned int);
9656     Stat_t sbuf; /* native stat; we don't need flex_stat */
9657     if (!sockflagsize || fdoff > sockflagsize) {
9658       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
9659       else           Newx  (sockflags,fdoff+2,unsigned int);
9660       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9661       sockflagsize = fdoff + 2;
9662     }
9663     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9664       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9665   }
9666   return fp;
9667
9668 }
9669 /*}}}*/
9670
9671
9672 /*
9673  * Clear the corresponding bit when the (possibly) socket stream is closed.
9674  * There still a small hole: we miss an implicit close which might occur
9675  * via freopen().  >> Todo
9676  */
9677 /*{{{ int my_fclose(FILE *fp)*/
9678 int my_fclose(FILE *fp) {
9679   if (fp) {
9680     unsigned int fd = fileno(fp);
9681     unsigned int fdoff = fd / sizeof(unsigned int);
9682
9683     if (sockflagsize && fdoff <= sockflagsize)
9684       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9685   }
9686   return fclose(fp);
9687 }
9688 /*}}}*/
9689
9690
9691 /*
9692  * A simple fwrite replacement which outputs itmsz*nitm chars without
9693  * introducing record boundaries every itmsz chars.
9694  * We are using fputs, which depends on a terminating null.  We may
9695  * well be writing binary data, so we need to accommodate not only
9696  * data with nulls sprinkled in the middle but also data with no null
9697  * byte at the end.
9698  */
9699 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9700 int
9701 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9702 {
9703   register char *cp, *end, *cpd, *data;
9704   register unsigned int fd = fileno(dest);
9705   register unsigned int fdoff = fd / sizeof(unsigned int);
9706   int retval;
9707   int bufsize = itmsz * nitm + 1;
9708
9709   if (fdoff < sockflagsize &&
9710       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9711     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9712     return nitm;
9713   }
9714
9715   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9716   memcpy( data, src, itmsz*nitm );
9717   data[itmsz*nitm] = '\0';
9718
9719   end = data + itmsz * nitm;
9720   retval = (int) nitm; /* on success return # items written */
9721
9722   cpd = data;
9723   while (cpd <= end) {
9724     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9725     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9726     if (cp < end)
9727       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9728     cpd = cp + 1;
9729   }
9730
9731   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9732   return retval;
9733
9734 }  /* end of my_fwrite() */
9735 /*}}}*/
9736
9737 /*{{{ int my_flush(FILE *fp)*/
9738 int
9739 Perl_my_flush(pTHX_ FILE *fp)
9740 {
9741     int res;
9742     if ((res = fflush(fp)) == 0 && fp) {
9743 #ifdef VMS_DO_SOCKETS
9744         Stat_t s;
9745         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9746 #endif
9747             res = fsync(fileno(fp));
9748     }
9749 /*
9750  * If the flush succeeded but set end-of-file, we need to clear
9751  * the error because our caller may check ferror().  BTW, this
9752  * probably means we just flushed an empty file.
9753  */
9754     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9755
9756     return res;
9757 }
9758 /*}}}*/
9759
9760 /*
9761  * Here are replacements for the following Unix routines in the VMS environment:
9762  *      getpwuid    Get information for a particular UIC or UID
9763  *      getpwnam    Get information for a named user
9764  *      getpwent    Get information for each user in the rights database
9765  *      setpwent    Reset search to the start of the rights database
9766  *      endpwent    Finish searching for users in the rights database
9767  *
9768  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9769  * (defined in pwd.h), which contains the following fields:-
9770  *      struct passwd {
9771  *              char        *pw_name;    Username (in lower case)
9772  *              char        *pw_passwd;  Hashed password
9773  *              unsigned int pw_uid;     UIC
9774  *              unsigned int pw_gid;     UIC group  number
9775  *              char        *pw_unixdir; Default device/directory (VMS-style)
9776  *              char        *pw_gecos;   Owner name
9777  *              char        *pw_dir;     Default device/directory (Unix-style)
9778  *              char        *pw_shell;   Default CLI name (eg. DCL)
9779  *      };
9780  * If the specified user does not exist, getpwuid and getpwnam return NULL.
9781  *
9782  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9783  * not the UIC member number (eg. what's returned by getuid()),
9784  * getpwuid() can accept either as input (if uid is specified, the caller's
9785  * UIC group is used), though it won't recognise gid=0.
9786  *
9787  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9788  * information about other users in your group or in other groups, respectively.
9789  * If the required privilege is not available, then these routines fill only
9790  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9791  * string).
9792  *
9793  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9794  */
9795
9796 /* sizes of various UAF record fields */
9797 #define UAI$S_USERNAME 12
9798 #define UAI$S_IDENT    31
9799 #define UAI$S_OWNER    31
9800 #define UAI$S_DEFDEV   31
9801 #define UAI$S_DEFDIR   63
9802 #define UAI$S_DEFCLI   31
9803 #define UAI$S_PWD       8
9804
9805 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
9806                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9807                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
9808
9809 static char __empty[]= "";
9810 static struct passwd __passwd_empty=
9811     {(char *) __empty, (char *) __empty, 0, 0,
9812      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9813 static int contxt= 0;
9814 static struct passwd __pwdcache;
9815 static char __pw_namecache[UAI$S_IDENT+1];
9816
9817 /*
9818  * This routine does most of the work extracting the user information.
9819  */
9820 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9821 {
9822     static struct {
9823         unsigned char length;
9824         char pw_gecos[UAI$S_OWNER+1];
9825     } owner;
9826     static union uicdef uic;
9827     static struct {
9828         unsigned char length;
9829         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9830     } defdev;
9831     static struct {
9832         unsigned char length;
9833         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9834     } defdir;
9835     static struct {
9836         unsigned char length;
9837         char pw_shell[UAI$S_DEFCLI+1];
9838     } defcli;
9839     static char pw_passwd[UAI$S_PWD+1];
9840
9841     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9842     struct dsc$descriptor_s name_desc;
9843     unsigned long int sts;
9844
9845     static struct itmlst_3 itmlst[]= {
9846         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
9847         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
9848         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
9849         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
9850         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
9851         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
9852         {0,                0,           NULL,    NULL}};
9853
9854     name_desc.dsc$w_length=  strlen(name);
9855     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9856     name_desc.dsc$b_class=   DSC$K_CLASS_S;
9857     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9858
9859 /*  Note that sys$getuai returns many fields as counted strings. */
9860     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9861     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9862       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9863     }
9864     else { _ckvmssts(sts); }
9865     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
9866
9867     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
9868     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9869     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9870     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9871     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9872     owner.pw_gecos[lowner]=            '\0';
9873     defdev.pw_dir[ldefdev+ldefdir]= '\0';
9874     defcli.pw_shell[ldefcli]=          '\0';
9875     if (valid_uic(uic)) {
9876         pwd->pw_uid= uic.uic$l_uic;
9877         pwd->pw_gid= uic.uic$v_group;
9878     }
9879     else
9880       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9881     pwd->pw_passwd=  pw_passwd;
9882     pwd->pw_gecos=   owner.pw_gecos;
9883     pwd->pw_dir=     defdev.pw_dir;
9884     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9885     pwd->pw_shell=   defcli.pw_shell;
9886     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9887         int ldir;
9888         ldir= strlen(pwd->pw_unixdir) - 1;
9889         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9890     }
9891     else
9892         strcpy(pwd->pw_unixdir, pwd->pw_dir);
9893     if (!decc_efs_case_preserve)
9894         __mystrtolower(pwd->pw_unixdir);
9895     return 1;
9896 }
9897
9898 /*
9899  * Get information for a named user.
9900 */
9901 /*{{{struct passwd *getpwnam(char *name)*/
9902 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9903 {
9904     struct dsc$descriptor_s name_desc;
9905     union uicdef uic;
9906     unsigned long int status, sts;
9907
9908     __pwdcache = __passwd_empty;
9909     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9910       /* We still may be able to determine pw_uid and pw_gid */
9911       name_desc.dsc$w_length=  strlen(name);
9912       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9913       name_desc.dsc$b_class=   DSC$K_CLASS_S;
9914       name_desc.dsc$a_pointer= (char *) name;
9915       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9916         __pwdcache.pw_uid= uic.uic$l_uic;
9917         __pwdcache.pw_gid= uic.uic$v_group;
9918       }
9919       else {
9920         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9921           set_vaxc_errno(sts);
9922           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9923           return NULL;
9924         }
9925         else { _ckvmssts(sts); }
9926       }
9927     }
9928     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9929     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9930     __pwdcache.pw_name= __pw_namecache;
9931     return &__pwdcache;
9932 }  /* end of my_getpwnam() */
9933 /*}}}*/
9934
9935 /*
9936  * Get information for a particular UIC or UID.
9937  * Called by my_getpwent with uid=-1 to list all users.
9938 */
9939 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9940 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9941 {
9942     const $DESCRIPTOR(name_desc,__pw_namecache);
9943     unsigned short lname;
9944     union uicdef uic;
9945     unsigned long int status;
9946
9947     if (uid == (unsigned int) -1) {
9948       do {
9949         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9950         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9951           set_vaxc_errno(status);
9952           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9953           my_endpwent();
9954           return NULL;
9955         }
9956         else { _ckvmssts(status); }
9957       } while (!valid_uic (uic));
9958     }
9959     else {
9960       uic.uic$l_uic= uid;
9961       if (!uic.uic$v_group)
9962         uic.uic$v_group= PerlProc_getgid();
9963       if (valid_uic(uic))
9964         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9965       else status = SS$_IVIDENT;
9966       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9967           status == RMS$_PRV) {
9968         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9969         return NULL;
9970       }
9971       else { _ckvmssts(status); }
9972     }
9973     __pw_namecache[lname]= '\0';
9974     __mystrtolower(__pw_namecache);
9975
9976     __pwdcache = __passwd_empty;
9977     __pwdcache.pw_name = __pw_namecache;
9978
9979 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9980     The identifier's value is usually the UIC, but it doesn't have to be,
9981     so if we can, we let fillpasswd update this. */
9982     __pwdcache.pw_uid =  uic.uic$l_uic;
9983     __pwdcache.pw_gid =  uic.uic$v_group;
9984
9985     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9986     return &__pwdcache;
9987
9988 }  /* end of my_getpwuid() */
9989 /*}}}*/
9990
9991 /*
9992  * Get information for next user.
9993 */
9994 /*{{{struct passwd *my_getpwent()*/
9995 struct passwd *Perl_my_getpwent(pTHX)
9996 {
9997     return (my_getpwuid((unsigned int) -1));
9998 }
9999 /*}}}*/
10000
10001 /*
10002  * Finish searching rights database for users.
10003 */
10004 /*{{{void my_endpwent()*/
10005 void Perl_my_endpwent(pTHX)
10006 {
10007     if (contxt) {
10008       _ckvmssts(sys$finish_rdb(&contxt));
10009       contxt= 0;
10010     }
10011 }
10012 /*}}}*/
10013
10014 #ifdef HOMEGROWN_POSIX_SIGNALS
10015   /* Signal handling routines, pulled into the core from POSIX.xs.
10016    *
10017    * We need these for threads, so they've been rolled into the core,
10018    * rather than left in POSIX.xs.
10019    *
10020    * (DRS, Oct 23, 1997)
10021    */
10022
10023   /* sigset_t is atomic under VMS, so these routines are easy */
10024 /*{{{int my_sigemptyset(sigset_t *) */
10025 int my_sigemptyset(sigset_t *set) {
10026     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10027     *set = 0; return 0;
10028 }
10029 /*}}}*/
10030
10031
10032 /*{{{int my_sigfillset(sigset_t *)*/
10033 int my_sigfillset(sigset_t *set) {
10034     int i;
10035     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10036     for (i = 0; i < NSIG; i++) *set |= (1 << i);
10037     return 0;
10038 }
10039 /*}}}*/
10040
10041
10042 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10043 int my_sigaddset(sigset_t *set, int sig) {
10044     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10045     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10046     *set |= (1 << (sig - 1));
10047     return 0;
10048 }
10049 /*}}}*/
10050
10051
10052 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10053 int my_sigdelset(sigset_t *set, int sig) {
10054     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10055     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10056     *set &= ~(1 << (sig - 1));
10057     return 0;
10058 }
10059 /*}}}*/
10060
10061
10062 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10063 int my_sigismember(sigset_t *set, int sig) {
10064     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10065     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10066     return *set & (1 << (sig - 1));
10067 }
10068 /*}}}*/
10069
10070
10071 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10072 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10073     sigset_t tempmask;
10074
10075     /* If set and oset are both null, then things are badly wrong. Bail out. */
10076     if ((oset == NULL) && (set == NULL)) {
10077       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10078       return -1;
10079     }
10080
10081     /* If set's null, then we're just handling a fetch. */
10082     if (set == NULL) {
10083         tempmask = sigblock(0);
10084     }
10085     else {
10086       switch (how) {
10087       case SIG_SETMASK:
10088         tempmask = sigsetmask(*set);
10089         break;
10090       case SIG_BLOCK:
10091         tempmask = sigblock(*set);
10092         break;
10093       case SIG_UNBLOCK:
10094         tempmask = sigblock(0);
10095         sigsetmask(*oset & ~tempmask);
10096         break;
10097       default:
10098         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10099         return -1;
10100       }
10101     }
10102
10103     /* Did they pass us an oset? If so, stick our holding mask into it */
10104     if (oset)
10105       *oset = tempmask;
10106
10107     return 0;
10108 }
10109 /*}}}*/
10110 #endif  /* HOMEGROWN_POSIX_SIGNALS */
10111
10112
10113 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10114  * my_utime(), and flex_stat(), all of which operate on UTC unless
10115  * VMSISH_TIMES is true.
10116  */
10117 /* method used to handle UTC conversions:
10118  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
10119  */
10120 static int gmtime_emulation_type;
10121 /* number of secs to add to UTC POSIX-style time to get local time */
10122 static long int utc_offset_secs;
10123
10124 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10125  * in vmsish.h.  #undef them here so we can call the CRTL routines
10126  * directly.
10127  */
10128 #undef gmtime
10129 #undef localtime
10130 #undef time
10131
10132
10133 /*
10134  * DEC C previous to 6.0 corrupts the behavior of the /prefix
10135  * qualifier with the extern prefix pragma.  This provisional
10136  * hack circumvents this prefix pragma problem in previous
10137  * precompilers.
10138  */
10139 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10140 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10141 #    pragma __extern_prefix save
10142 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
10143 #    define gmtime decc$__utctz_gmtime
10144 #    define localtime decc$__utctz_localtime
10145 #    define time decc$__utc_time
10146 #    pragma __extern_prefix restore
10147
10148      struct tm *gmtime(), *localtime();
10149
10150 #  endif
10151 #endif
10152
10153
10154 static time_t toutc_dst(time_t loc) {
10155   struct tm *rsltmp;
10156
10157   if ((rsltmp = localtime(&loc)) == NULL) return -1;
10158   loc -= utc_offset_secs;
10159   if (rsltmp->tm_isdst) loc -= 3600;
10160   return loc;
10161 }
10162 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10163        ((gmtime_emulation_type || my_time(NULL)), \
10164        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10165        ((secs) - utc_offset_secs))))
10166
10167 static time_t toloc_dst(time_t utc) {
10168   struct tm *rsltmp;
10169
10170   utc += utc_offset_secs;
10171   if ((rsltmp = localtime(&utc)) == NULL) return -1;
10172   if (rsltmp->tm_isdst) utc += 3600;
10173   return utc;
10174 }
10175 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10176        ((gmtime_emulation_type || my_time(NULL)), \
10177        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10178        ((secs) + utc_offset_secs))))
10179
10180 #ifndef RTL_USES_UTC
10181 /*
10182
10183     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
10184         DST starts on 1st sun of april      at 02:00  std time
10185             ends on last sun of october     at 02:00  dst time
10186     see the UCX management command reference, SET CONFIG TIMEZONE
10187     for formatting info.
10188
10189     No, it's not as general as it should be, but then again, NOTHING
10190     will handle UK times in a sensible way.
10191 */
10192
10193
10194 /*
10195     parse the DST start/end info:
10196     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10197 */
10198
10199 static char *
10200 tz_parse_startend(char *s, struct tm *w, int *past)
10201 {
10202     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10203     int ly, dozjd, d, m, n, hour, min, sec, j, k;
10204     time_t g;
10205
10206     if (!s)    return 0;
10207     if (!w) return 0;
10208     if (!past) return 0;
10209
10210     ly = 0;
10211     if (w->tm_year % 4        == 0) ly = 1;
10212     if (w->tm_year % 100      == 0) ly = 0;
10213     if (w->tm_year+1900 % 400 == 0) ly = 1;
10214     if (ly) dinm[1]++;
10215
10216     dozjd = isdigit(*s);
10217     if (*s == 'J' || *s == 'j' || dozjd) {
10218         if (!dozjd && !isdigit(*++s)) return 0;
10219         d = *s++ - '0';
10220         if (isdigit(*s)) {
10221             d = d*10 + *s++ - '0';
10222             if (isdigit(*s)) {
10223                 d = d*10 + *s++ - '0';
10224             }
10225         }
10226         if (d == 0) return 0;
10227         if (d > 366) return 0;
10228         d--;
10229         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
10230         g = d * 86400;
10231         dozjd = 1;
10232     } else if (*s == 'M' || *s == 'm') {
10233         if (!isdigit(*++s)) return 0;
10234         m = *s++ - '0';
10235         if (isdigit(*s)) m = 10*m + *s++ - '0';
10236         if (*s != '.') return 0;
10237         if (!isdigit(*++s)) return 0;
10238         n = *s++ - '0';
10239         if (n < 1 || n > 5) return 0;
10240         if (*s != '.') return 0;
10241         if (!isdigit(*++s)) return 0;
10242         d = *s++ - '0';
10243         if (d > 6) return 0;
10244     }
10245
10246     if (*s == '/') {
10247         if (!isdigit(*++s)) return 0;
10248         hour = *s++ - '0';
10249         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10250         if (*s == ':') {
10251             if (!isdigit(*++s)) return 0;
10252             min = *s++ - '0';
10253             if (isdigit(*s)) min = 10*min + *s++ - '0';
10254             if (*s == ':') {
10255                 if (!isdigit(*++s)) return 0;
10256                 sec = *s++ - '0';
10257                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10258             }
10259         }
10260     } else {
10261         hour = 2;
10262         min = 0;
10263         sec = 0;
10264     }
10265
10266     if (dozjd) {
10267         if (w->tm_yday < d) goto before;
10268         if (w->tm_yday > d) goto after;
10269     } else {
10270         if (w->tm_mon+1 < m) goto before;
10271         if (w->tm_mon+1 > m) goto after;
10272
10273         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
10274         k = d - j; /* mday of first d */
10275         if (k <= 0) k += 7;
10276         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
10277         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10278         if (w->tm_mday < k) goto before;
10279         if (w->tm_mday > k) goto after;
10280     }
10281
10282     if (w->tm_hour < hour) goto before;
10283     if (w->tm_hour > hour) goto after;
10284     if (w->tm_min  < min)  goto before;
10285     if (w->tm_min  > min)  goto after;
10286     if (w->tm_sec  < sec)  goto before;
10287     goto after;
10288
10289 before:
10290     *past = 0;
10291     return s;
10292 after:
10293     *past = 1;
10294     return s;
10295 }
10296
10297
10298
10299
10300 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
10301
10302 static char *
10303 tz_parse_offset(char *s, int *offset)
10304 {
10305     int hour = 0, min = 0, sec = 0;
10306     int neg = 0;
10307     if (!s) return 0;
10308     if (!offset) return 0;
10309
10310     if (*s == '-') {neg++; s++;}
10311     if (*s == '+') s++;
10312     if (!isdigit(*s)) return 0;
10313     hour = *s++ - '0';
10314     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10315     if (hour > 24) return 0;
10316     if (*s == ':') {
10317         if (!isdigit(*++s)) return 0;
10318         min = *s++ - '0';
10319         if (isdigit(*s)) min = min*10 + (*s++ - '0');
10320         if (min > 59) return 0;
10321         if (*s == ':') {
10322             if (!isdigit(*++s)) return 0;
10323             sec = *s++ - '0';
10324             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10325             if (sec > 59) return 0;
10326         }
10327     }
10328
10329     *offset = (hour*60+min)*60 + sec;
10330     if (neg) *offset = -*offset;
10331     return s;
10332 }
10333
10334 /*
10335     input time is w, whatever type of time the CRTL localtime() uses.
10336     sets dst, the zone, and the gmtoff (seconds)
10337
10338     caches the value of TZ and UCX$TZ env variables; note that
10339     my_setenv looks for these and sets a flag if they're changed
10340     for efficiency.
10341
10342     We have to watch out for the "australian" case (dst starts in
10343     october, ends in april)...flagged by "reverse" and checked by
10344     scanning through the months of the previous year.
10345
10346 */
10347
10348 static int
10349 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10350 {
10351     time_t when;
10352     struct tm *w2;
10353     char *s,*s2;
10354     char *dstzone, *tz, *s_start, *s_end;
10355     int std_off, dst_off, isdst;
10356     int y, dststart, dstend;
10357     static char envtz[1025];  /* longer than any logical, symbol, ... */
10358     static char ucxtz[1025];
10359     static char reversed = 0;
10360
10361     if (!w) return 0;
10362
10363     if (tz_updated) {
10364         tz_updated = 0;
10365         reversed = -1;  /* flag need to check  */
10366         envtz[0] = ucxtz[0] = '\0';
10367         tz = my_getenv("TZ",0);
10368         if (tz) strcpy(envtz, tz);
10369         tz = my_getenv("UCX$TZ",0);
10370         if (tz) strcpy(ucxtz, tz);
10371         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
10372     }
10373     tz = envtz;
10374     if (!*tz) tz = ucxtz;
10375
10376     s = tz;
10377     while (isalpha(*s)) s++;
10378     s = tz_parse_offset(s, &std_off);
10379     if (!s) return 0;
10380     if (!*s) {                  /* no DST, hurray we're done! */
10381         isdst = 0;
10382         goto done;
10383     }
10384
10385     dstzone = s;
10386     while (isalpha(*s)) s++;
10387     s2 = tz_parse_offset(s, &dst_off);
10388     if (s2) {
10389         s = s2;
10390     } else {
10391         dst_off = std_off - 3600;
10392     }
10393
10394     if (!*s) {      /* default dst start/end?? */
10395         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
10396             s = strchr(ucxtz,',');
10397         }
10398         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
10399     }
10400     if (*s != ',') return 0;
10401
10402     when = *w;
10403     when = _toutc(when);      /* convert to utc */
10404     when = when - std_off;    /* convert to pseudolocal time*/
10405
10406     w2 = localtime(&when);
10407     y = w2->tm_year;
10408     s_start = s+1;
10409     s = tz_parse_startend(s_start,w2,&dststart);
10410     if (!s) return 0;
10411     if (*s != ',') return 0;
10412
10413     when = *w;
10414     when = _toutc(when);      /* convert to utc */
10415     when = when - dst_off;    /* convert to pseudolocal time*/
10416     w2 = localtime(&when);
10417     if (w2->tm_year != y) {   /* spans a year, just check one time */
10418         when += dst_off - std_off;
10419         w2 = localtime(&when);
10420     }
10421     s_end = s+1;
10422     s = tz_parse_startend(s_end,w2,&dstend);
10423     if (!s) return 0;
10424
10425     if (reversed == -1) {  /* need to check if start later than end */
10426         int j, ds, de;
10427
10428         when = *w;
10429         if (when < 2*365*86400) {
10430             when += 2*365*86400;
10431         } else {
10432             when -= 365*86400;
10433         }
10434         w2 =localtime(&when);
10435         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
10436
10437         for (j = 0; j < 12; j++) {
10438             w2 =localtime(&when);
10439             tz_parse_startend(s_start,w2,&ds);
10440             tz_parse_startend(s_end,w2,&de);
10441             if (ds != de) break;
10442             when += 30*86400;
10443         }
10444         reversed = 0;
10445         if (de && !ds) reversed = 1;
10446     }
10447
10448     isdst = dststart && !dstend;
10449     if (reversed) isdst = dststart  || !dstend;
10450
10451 done:
10452     if (dst)    *dst = isdst;
10453     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10454     if (isdst)  tz = dstzone;
10455     if (zone) {
10456         while(isalpha(*tz))  *zone++ = *tz++;
10457         *zone = '\0';
10458     }
10459     return 1;
10460 }
10461
10462 #endif /* !RTL_USES_UTC */
10463
10464 /* my_time(), my_localtime(), my_gmtime()
10465  * By default traffic in UTC time values, using CRTL gmtime() or
10466  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10467  * Note: We need to use these functions even when the CRTL has working
10468  * UTC support, since they also handle C<use vmsish qw(times);>
10469  *
10470  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
10471  * Modified by Charles Bailey <bailey@newman.upenn.edu>
10472  */
10473
10474 /*{{{time_t my_time(time_t *timep)*/
10475 time_t Perl_my_time(pTHX_ time_t *timep)
10476 {
10477   time_t when;
10478   struct tm *tm_p;
10479
10480   if (gmtime_emulation_type == 0) {
10481     int dstnow;
10482     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
10483                               /* results of calls to gmtime() and localtime() */
10484                               /* for same &base */
10485
10486     gmtime_emulation_type++;
10487     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10488       char off[LNM$C_NAMLENGTH+1];;
10489
10490       gmtime_emulation_type++;
10491       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10492         gmtime_emulation_type++;
10493         utc_offset_secs = 0;
10494         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10495       }
10496       else { utc_offset_secs = atol(off); }
10497     }
10498     else { /* We've got a working gmtime() */
10499       struct tm gmt, local;
10500
10501       gmt = *tm_p;
10502       tm_p = localtime(&base);
10503       local = *tm_p;
10504       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
10505       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10506       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
10507       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
10508     }
10509   }
10510
10511   when = time(NULL);
10512 # ifdef VMSISH_TIME
10513 # ifdef RTL_USES_UTC
10514   if (VMSISH_TIME) when = _toloc(when);
10515 # else
10516   if (!VMSISH_TIME) when = _toutc(when);
10517 # endif
10518 # endif
10519   if (timep != NULL) *timep = when;
10520   return when;
10521
10522 }  /* end of my_time() */
10523 /*}}}*/
10524
10525
10526 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10527 struct tm *
10528 Perl_my_gmtime(pTHX_ const time_t *timep)
10529 {
10530   char *p;
10531   time_t when;
10532   struct tm *rsltmp;
10533
10534   if (timep == NULL) {
10535     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10536     return NULL;
10537   }
10538   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10539
10540   when = *timep;
10541 # ifdef VMSISH_TIME
10542   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10543 #  endif
10544 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
10545   return gmtime(&when);
10546 # else
10547   /* CRTL localtime() wants local time as input, so does no tz correction */
10548   rsltmp = localtime(&when);
10549   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
10550   return rsltmp;
10551 #endif
10552 }  /* end of my_gmtime() */
10553 /*}}}*/
10554
10555
10556 /*{{{struct tm *my_localtime(const time_t *timep)*/
10557 struct tm *
10558 Perl_my_localtime(pTHX_ const time_t *timep)
10559 {
10560   time_t when, whenutc;
10561   struct tm *rsltmp;
10562   int dst, offset;
10563
10564   if (timep == NULL) {
10565     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10566     return NULL;
10567   }
10568   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10569   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10570
10571   when = *timep;
10572 # ifdef RTL_USES_UTC
10573 # ifdef VMSISH_TIME
10574   if (VMSISH_TIME) when = _toutc(when);
10575 # endif
10576   /* CRTL localtime() wants UTC as input, does tz correction itself */
10577   return localtime(&when);
10578
10579 # else /* !RTL_USES_UTC */
10580   whenutc = when;
10581 # ifdef VMSISH_TIME
10582   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
10583   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
10584 # endif
10585   dst = -1;
10586 #ifndef RTL_USES_UTC
10587   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
10588       when = whenutc - offset;                   /* pseudolocal time*/
10589   }
10590 # endif
10591   /* CRTL localtime() wants local time as input, so does no tz correction */
10592   rsltmp = localtime(&when);
10593   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10594   return rsltmp;
10595 # endif
10596
10597 } /*  end of my_localtime() */
10598 /*}}}*/
10599
10600 /* Reset definitions for later calls */
10601 #define gmtime(t)    my_gmtime(t)
10602 #define localtime(t) my_localtime(t)
10603 #define time(t)      my_time(t)
10604
10605
10606 /* my_utime - update modification/access time of a file
10607  *
10608  * VMS 7.3 and later implementation
10609  * Only the UTC translation is home-grown. The rest is handled by the
10610  * CRTL utime(), which will take into account the relevant feature
10611  * logicals and ODS-5 volume characteristics for true access times.
10612  *
10613  * pre VMS 7.3 implementation:
10614  * The calling sequence is identical to POSIX utime(), but under
10615  * VMS with ODS-2, only the modification time is changed; ODS-2 does
10616  * not maintain access times.  Restrictions differ from the POSIX
10617  * definition in that the time can be changed as long as the
10618  * caller has permission to execute the necessary IO$_MODIFY $QIO;
10619  * no separate checks are made to insure that the caller is the
10620  * owner of the file or has special privs enabled.
10621  * Code here is based on Joe Meadows' FILE utility.
10622  *
10623  */
10624
10625 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10626  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
10627  * in 100 ns intervals.
10628  */
10629 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10630
10631 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10632 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10633 {
10634 #if __CRTL_VER >= 70300000
10635   struct utimbuf utc_utimes, *utc_utimesp;
10636
10637   if (utimes != NULL) {
10638     utc_utimes.actime = utimes->actime;
10639     utc_utimes.modtime = utimes->modtime;
10640 # ifdef VMSISH_TIME
10641     /* If input was local; convert to UTC for sys svc */
10642     if (VMSISH_TIME) {
10643       utc_utimes.actime = _toutc(utimes->actime);
10644       utc_utimes.modtime = _toutc(utimes->modtime);
10645     }
10646 # endif
10647     utc_utimesp = &utc_utimes;
10648   }
10649   else {
10650     utc_utimesp = NULL;
10651   }
10652
10653   return utime(file, utc_utimesp);
10654
10655 #else /* __CRTL_VER < 70300000 */
10656
10657   register int i;
10658   int sts;
10659   long int bintime[2], len = 2, lowbit, unixtime,
10660            secscale = 10000000; /* seconds --> 100 ns intervals */
10661   unsigned long int chan, iosb[2], retsts;
10662   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10663   struct FAB myfab = cc$rms_fab;
10664   struct NAM mynam = cc$rms_nam;
10665 #if defined (__DECC) && defined (__VAX)
10666   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10667    * at least through VMS V6.1, which causes a type-conversion warning.
10668    */
10669 #  pragma message save
10670 #  pragma message disable cvtdiftypes
10671 #endif
10672   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10673   struct fibdef myfib;
10674 #if defined (__DECC) && defined (__VAX)
10675   /* This should be right after the declaration of myatr, but due
10676    * to a bug in VAX DEC C, this takes effect a statement early.
10677    */
10678 #  pragma message restore
10679 #endif
10680   /* cast ok for read only parameter */
10681   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10682                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10683                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10684
10685   if (file == NULL || *file == '\0') {
10686     SETERRNO(ENOENT, LIB$_INVARG);
10687     return -1;
10688   }
10689
10690   /* Convert to VMS format ensuring that it will fit in 255 characters */
10691   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10692       SETERRNO(ENOENT, LIB$_INVARG);
10693       return -1;
10694   }
10695   if (utimes != NULL) {
10696     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
10697      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10698      * Since time_t is unsigned long int, and lib$emul takes a signed long int
10699      * as input, we force the sign bit to be clear by shifting unixtime right
10700      * one bit, then multiplying by an extra factor of 2 in lib$emul().
10701      */
10702     lowbit = (utimes->modtime & 1) ? secscale : 0;
10703     unixtime = (long int) utimes->modtime;
10704 #   ifdef VMSISH_TIME
10705     /* If input was UTC; convert to local for sys svc */
10706     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10707 #   endif
10708     unixtime >>= 1;  secscale <<= 1;
10709     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10710     if (!(retsts & 1)) {
10711       SETERRNO(EVMSERR, retsts);
10712       return -1;
10713     }
10714     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10715     if (!(retsts & 1)) {
10716       SETERRNO(EVMSERR, retsts);
10717       return -1;
10718     }
10719   }
10720   else {
10721     /* Just get the current time in VMS format directly */
10722     retsts = sys$gettim(bintime);
10723     if (!(retsts & 1)) {
10724       SETERRNO(EVMSERR, retsts);
10725       return -1;
10726     }
10727   }
10728
10729   myfab.fab$l_fna = vmsspec;
10730   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10731   myfab.fab$l_nam = &mynam;
10732   mynam.nam$l_esa = esa;
10733   mynam.nam$b_ess = (unsigned char) sizeof esa;
10734   mynam.nam$l_rsa = rsa;
10735   mynam.nam$b_rss = (unsigned char) sizeof rsa;
10736   if (decc_efs_case_preserve)
10737       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10738
10739   /* Look for the file to be affected, letting RMS parse the file
10740    * specification for us as well.  I have set errno using only
10741    * values documented in the utime() man page for VMS POSIX.
10742    */
10743   retsts = sys$parse(&myfab,0,0);
10744   if (!(retsts & 1)) {
10745     set_vaxc_errno(retsts);
10746     if      (retsts == RMS$_PRV) set_errno(EACCES);
10747     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10748     else                         set_errno(EVMSERR);
10749     return -1;
10750   }
10751   retsts = sys$search(&myfab,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 == RMS$_PRV) set_errno(EACCES);
10757     else if (retsts == RMS$_FNF) set_errno(ENOENT);
10758     else                         set_errno(EVMSERR);
10759     return -1;
10760   }
10761
10762   devdsc.dsc$w_length = mynam.nam$b_dev;
10763   /* cast ok for read only parameter */
10764   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10765
10766   retsts = sys$assign(&devdsc,&chan,0,0);
10767   if (!(retsts & 1)) {
10768     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10769     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10770     set_vaxc_errno(retsts);
10771     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
10772     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
10773     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
10774     else                               set_errno(EVMSERR);
10775     return -1;
10776   }
10777
10778   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10779   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10780
10781   memset((void *) &myfib, 0, sizeof myfib);
10782 #if defined(__DECC) || defined(__DECCXX)
10783   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10784   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10785   /* This prevents the revision time of the file being reset to the current
10786    * time as a result of our IO$_MODIFY $QIO. */
10787   myfib.fib$l_acctl = FIB$M_NORECORD;
10788 #else
10789   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10790   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10791   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10792 #endif
10793   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10794   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10795   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10796   _ckvmssts(sys$dassgn(chan));
10797   if (retsts & 1) retsts = iosb[0];
10798   if (!(retsts & 1)) {
10799     set_vaxc_errno(retsts);
10800     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10801     else                      set_errno(EVMSERR);
10802     return -1;
10803   }
10804
10805   return 0;
10806
10807 #endif /* #if __CRTL_VER >= 70300000 */
10808
10809 }  /* end of my_utime() */
10810 /*}}}*/
10811
10812 /*
10813  * flex_stat, flex_lstat, flex_fstat
10814  * basic stat, but gets it right when asked to stat
10815  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10816  */
10817
10818 #ifndef _USE_STD_STAT
10819 /* encode_dev packs a VMS device name string into an integer to allow
10820  * simple comparisons. This can be used, for example, to check whether two
10821  * files are located on the same device, by comparing their encoded device
10822  * names. Even a string comparison would not do, because stat() reuses the
10823  * device name buffer for each call; so without encode_dev, it would be
10824  * necessary to save the buffer and use strcmp (this would mean a number of
10825  * changes to the standard Perl code, to say nothing of what a Perl script
10826  * would have to do.
10827  *
10828  * The device lock id, if it exists, should be unique (unless perhaps compared
10829  * with lock ids transferred from other nodes). We have a lock id if the disk is
10830  * mounted cluster-wide, which is when we tend to get long (host-qualified)
10831  * device names. Thus we use the lock id in preference, and only if that isn't
10832  * available, do we try to pack the device name into an integer (flagged by
10833  * the sign bit (LOCKID_MASK) being set).
10834  *
10835  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10836  * name and its encoded form, but it seems very unlikely that we will find
10837  * two files on different disks that share the same encoded device names,
10838  * and even more remote that they will share the same file id (if the test
10839  * is to check for the same file).
10840  *
10841  * A better method might be to use sys$device_scan on the first call, and to
10842  * search for the device, returning an index into the cached array.
10843  * The number returned would be more intelligible.
10844  * This is probably not worth it, and anyway would take quite a bit longer
10845  * on the first call.
10846  */
10847 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
10848 static mydev_t encode_dev (pTHX_ const char *dev)
10849 {
10850   int i;
10851   unsigned long int f;
10852   mydev_t enc;
10853   char c;
10854   const char *q;
10855
10856   if (!dev || !dev[0]) return 0;
10857
10858 #if LOCKID_MASK
10859   {
10860     struct dsc$descriptor_s dev_desc;
10861     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10862
10863     /* For cluster-mounted disks, the disk lock identifier is unique, so we
10864        can try that first. */
10865     dev_desc.dsc$w_length =  strlen (dev);
10866     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
10867     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
10868     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
10869     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10870     if (!$VMS_STATUS_SUCCESS(status)) {
10871       switch (status) {
10872         case SS$_NOSUCHDEV:
10873           SETERRNO(ENODEV, status);
10874           return 0;
10875         default:
10876           _ckvmssts(status);
10877       }
10878     }
10879     if (lockid) return (lockid & ~LOCKID_MASK);
10880   }
10881 #endif
10882
10883   /* Otherwise we try to encode the device name */
10884   enc = 0;
10885   f = 1;
10886   i = 0;
10887   for (q = dev + strlen(dev); q--; q >= dev) {
10888     if (*q == ':')
10889         break;
10890     if (isdigit (*q))
10891       c= (*q) - '0';
10892     else if (isalpha (toupper (*q)))
10893       c= toupper (*q) - 'A' + (char)10;
10894     else
10895       continue; /* Skip '$'s */
10896     i++;
10897     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
10898     if (i>1) f *= 36;
10899     enc += f * (unsigned long int) c;
10900   }
10901   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
10902
10903 }  /* end of encode_dev() */
10904 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10905         device_no = encode_dev(aTHX_ devname)
10906 #else
10907 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10908         device_no = new_dev_no
10909 #endif
10910
10911 static int
10912 is_null_device(name)
10913     const char *name;
10914 {
10915   if (decc_bug_devnull != 0) {
10916     if (strncmp("/dev/null", name, 9) == 0)
10917       return 1;
10918   }
10919     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10920        The underscore prefix, controller letter, and unit number are
10921        independently optional; for our purposes, the colon punctuation
10922        is not.  The colon can be trailed by optional directory and/or
10923        filename, but two consecutive colons indicates a nodename rather
10924        than a device.  [pr]  */
10925   if (*name == '_') ++name;
10926   if (tolower(*name++) != 'n') return 0;
10927   if (tolower(*name++) != 'l') return 0;
10928   if (tolower(*name) == 'a') ++name;
10929   if (*name == '0') ++name;
10930   return (*name++ == ':') && (*name != ':');
10931 }
10932
10933
10934 static I32
10935 Perl_cando_by_name_int
10936    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10937 {
10938   char usrname[L_cuserid];
10939   struct dsc$descriptor_s usrdsc =
10940          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10941   char *vmsname = NULL, *fileified = NULL;
10942   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10943   unsigned short int retlen, trnlnm_iter_count;
10944   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10945   union prvdef curprv;
10946   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10947          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10948          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10949   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10950          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10951          {0,0,0,0}};
10952   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10953          {0,0,0,0}};
10954   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10955   Stat_t st;
10956   static int profile_context = -1;
10957
10958   if (!fname || !*fname) return FALSE;
10959
10960   /* Make sure we expand logical names, since sys$check_access doesn't */
10961   fileified = PerlMem_malloc(VMS_MAXRSS);
10962   if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
10963   if (!strpbrk(fname,"/]>:")) {
10964       strcpy(fileified,fname);
10965       trnlnm_iter_count = 0;
10966       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
10967         trnlnm_iter_count++;
10968         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10969       }
10970       fname = fileified;
10971   }
10972
10973   vmsname = PerlMem_malloc(VMS_MAXRSS);
10974   if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
10975   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
10976     /* Don't know if already in VMS format, so make sure */
10977     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10978       PerlMem_free(fileified);
10979       PerlMem_free(vmsname);
10980       return FALSE;
10981     }
10982   }
10983   else {
10984     strcpy(vmsname,fname);
10985   }
10986
10987   /* sys$check_access needs a file spec, not a directory spec.
10988    * Don't use flex_stat here, as that depends on thread context
10989    * having been initialized, and we may get here during startup.
10990    */
10991
10992   retlen = namdsc.dsc$w_length = strlen(vmsname);
10993   if (vmsname[retlen-1] == ']'
10994       || vmsname[retlen-1] == '>'
10995       || vmsname[retlen-1] == ':'
10996       || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
10997
10998       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
10999         PerlMem_free(fileified);
11000         PerlMem_free(vmsname);
11001         return FALSE;
11002       }
11003       fname = fileified;
11004   }
11005   else {
11006       fname = vmsname;
11007   }
11008
11009   retlen = namdsc.dsc$w_length = strlen(fname);
11010   namdsc.dsc$a_pointer = (char *)fname;
11011
11012   switch (bit) {
11013     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11014       access = ARM$M_EXECUTE;
11015       flags = CHP$M_READ;
11016       break;
11017     case S_IRUSR: case S_IRGRP: case S_IROTH:
11018       access = ARM$M_READ;
11019       flags = CHP$M_READ | CHP$M_USEREADALL;
11020       break;
11021     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11022       access = ARM$M_WRITE;
11023       flags = CHP$M_READ | CHP$M_WRITE;
11024       break;
11025     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11026       access = ARM$M_DELETE;
11027       flags = CHP$M_READ | CHP$M_WRITE;
11028       break;
11029     default:
11030       if (fileified != NULL)
11031         PerlMem_free(fileified);
11032       if (vmsname != NULL)
11033         PerlMem_free(vmsname);
11034       return FALSE;
11035   }
11036
11037   /* Before we call $check_access, create a user profile with the current
11038    * process privs since otherwise it just uses the default privs from the
11039    * UAF and might give false positives or negatives.  This only works on
11040    * VMS versions v6.0 and later since that's when sys$create_user_profile
11041    * became available.
11042    */
11043
11044   /* get current process privs and username */
11045   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11046   _ckvmssts(iosb[0]);
11047
11048 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11049
11050   /* find out the space required for the profile */
11051   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11052                                     &usrprodsc.dsc$w_length,&profile_context));
11053
11054   /* allocate space for the profile and get it filled in */
11055   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11056   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11057   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11058                                     &usrprodsc.dsc$w_length,&profile_context));
11059
11060   /* use the profile to check access to the file; free profile & analyze results */
11061   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11062   PerlMem_free(usrprodsc.dsc$a_pointer);
11063   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11064
11065 #else
11066
11067   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11068
11069 #endif
11070
11071   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11072       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11073       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11074     set_vaxc_errno(retsts);
11075     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11076     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11077     else set_errno(ENOENT);
11078     if (fileified != NULL)
11079       PerlMem_free(fileified);
11080     if (vmsname != NULL)
11081       PerlMem_free(vmsname);
11082     return FALSE;
11083   }
11084   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11085     if (fileified != NULL)
11086       PerlMem_free(fileified);
11087     if (vmsname != NULL)
11088       PerlMem_free(vmsname);
11089     return TRUE;
11090   }
11091   _ckvmssts(retsts);
11092
11093   if (fileified != NULL)
11094     PerlMem_free(fileified);
11095   if (vmsname != NULL)
11096     PerlMem_free(vmsname);
11097   return FALSE;  /* Should never get here */
11098
11099 }
11100
11101 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
11102 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11103  * subset of the applicable information.
11104  */
11105 bool
11106 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11107 {
11108   return cando_by_name_int
11109         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11110 }  /* end of cando() */
11111 /*}}}*/
11112
11113
11114 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11115 I32
11116 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11117 {
11118    return cando_by_name_int(bit, effective, fname, 0);
11119
11120 }  /* end of cando_by_name() */
11121 /*}}}*/
11122
11123
11124 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11125 int
11126 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11127 {
11128   if (!fstat(fd,(stat_t *) statbufp)) {
11129     char *cptr;
11130     char *vms_filename;
11131     vms_filename = PerlMem_malloc(VMS_MAXRSS);
11132     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11133
11134     /* Save name for cando by name in VMS format */
11135     cptr = getname(fd, vms_filename, 1);
11136
11137     /* This should not happen, but just in case */
11138     if (cptr == NULL) {
11139         statbufp->st_devnam[0] = 0;
11140     }
11141     else {
11142         /* Make sure that the saved name fits in 255 characters */
11143         cptr = do_rmsexpand
11144                        (vms_filename,
11145                         statbufp->st_devnam,
11146                         0,
11147                         NULL,
11148                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11149                         NULL,
11150                         NULL);
11151         if (cptr == NULL)
11152             statbufp->st_devnam[0] = 0;
11153     }
11154     PerlMem_free(vms_filename);
11155
11156     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11157     VMS_DEVICE_ENCODE
11158         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11159
11160 #   ifdef RTL_USES_UTC
11161 #   ifdef VMSISH_TIME
11162     if (VMSISH_TIME) {
11163       statbufp->st_mtime = _toloc(statbufp->st_mtime);
11164       statbufp->st_atime = _toloc(statbufp->st_atime);
11165       statbufp->st_ctime = _toloc(statbufp->st_ctime);
11166     }
11167 #   endif
11168 #   else
11169 #   ifdef VMSISH_TIME
11170     if (!VMSISH_TIME) { /* Return UTC instead of local time */
11171 #   else
11172     if (1) {
11173 #   endif
11174       statbufp->st_mtime = _toutc(statbufp->st_mtime);
11175       statbufp->st_atime = _toutc(statbufp->st_atime);
11176       statbufp->st_ctime = _toutc(statbufp->st_ctime);
11177     }
11178 #endif
11179     return 0;
11180   }
11181   return -1;
11182
11183 }  /* end of flex_fstat() */
11184 /*}}}*/
11185
11186 #if !defined(__VAX) && __CRTL_VER >= 80200000
11187 #ifdef lstat
11188 #undef lstat
11189 #endif
11190 #else
11191 #ifdef lstat
11192 #undef lstat
11193 #endif
11194 #define lstat(_x, _y) stat(_x, _y)
11195 #endif
11196
11197 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11198
11199 static int
11200 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11201 {
11202     char fileified[VMS_MAXRSS];
11203     char temp_fspec[VMS_MAXRSS];
11204     char *save_spec;
11205     int retval = -1;
11206     int saved_errno, saved_vaxc_errno;
11207
11208     if (!fspec) return retval;
11209     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11210     strcpy(temp_fspec, fspec);
11211
11212     if (decc_bug_devnull != 0) {
11213       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11214         memset(statbufp,0,sizeof *statbufp);
11215         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11216         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11217         statbufp->st_uid = 0x00010001;
11218         statbufp->st_gid = 0x0001;
11219         time((time_t *)&statbufp->st_mtime);
11220         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11221         return 0;
11222       }
11223     }
11224
11225     /* Try for a directory name first.  If fspec contains a filename without
11226      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11227      * and sea:[wine.dark]water. exist, we prefer the directory here.
11228      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11229      * not sea:[wine.dark]., if the latter exists.  If the intended target is
11230      * the file with null type, specify this by calling flex_stat() with
11231      * a '.' at the end of fspec.
11232      *
11233      * If we are in Posix filespec mode, accept the filename as is.
11234      */
11235
11236
11237 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11238   /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11239    * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11240    */
11241   if (!decc_efs_charset)
11242     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11243 #endif
11244
11245 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11246   if (decc_posix_compliant_pathnames == 0) {
11247 #endif
11248     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11249       if (lstat_flag == 0)
11250         retval = stat(fileified,(stat_t *) statbufp);
11251       else
11252         retval = lstat(fileified,(stat_t *) statbufp);
11253       save_spec = fileified;
11254     }
11255     if (retval) {
11256       if (lstat_flag == 0)
11257         retval = stat(temp_fspec,(stat_t *) statbufp);
11258       else
11259         retval = lstat(temp_fspec,(stat_t *) statbufp);
11260       save_spec = temp_fspec;
11261     }
11262 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11263   } else {
11264     if (lstat_flag == 0)
11265       retval = stat(temp_fspec,(stat_t *) statbufp);
11266     else
11267       retval = lstat(temp_fspec,(stat_t *) statbufp);
11268       save_spec = temp_fspec;
11269   }
11270 #endif
11271
11272 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11273   /* As you were... */
11274   if (!decc_efs_charset)
11275     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11276 #endif
11277
11278     if (!retval) {
11279     char * cptr;
11280       cptr = do_rmsexpand
11281        (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
11282       if (cptr == NULL)
11283         statbufp->st_devnam[0] = 0;
11284
11285       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11286       VMS_DEVICE_ENCODE
11287         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11288 #     ifdef RTL_USES_UTC
11289 #     ifdef VMSISH_TIME
11290       if (VMSISH_TIME) {
11291         statbufp->st_mtime = _toloc(statbufp->st_mtime);
11292         statbufp->st_atime = _toloc(statbufp->st_atime);
11293         statbufp->st_ctime = _toloc(statbufp->st_ctime);
11294       }
11295 #     endif
11296 #     else
11297 #     ifdef VMSISH_TIME
11298       if (!VMSISH_TIME) { /* Return UTC instead of local time */
11299 #     else
11300       if (1) {
11301 #     endif
11302         statbufp->st_mtime = _toutc(statbufp->st_mtime);
11303         statbufp->st_atime = _toutc(statbufp->st_atime);
11304         statbufp->st_ctime = _toutc(statbufp->st_ctime);
11305       }
11306 #     endif
11307     }
11308     /* If we were successful, leave errno where we found it */
11309     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
11310     return retval;
11311
11312 }  /* end of flex_stat_int() */
11313
11314
11315 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
11316 int
11317 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
11318 {
11319    return flex_stat_int(fspec, statbufp, 0);
11320 }
11321 /*}}}*/
11322
11323 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
11324 int
11325 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
11326 {
11327    return flex_stat_int(fspec, statbufp, 1);
11328 }
11329 /*}}}*/
11330
11331
11332 /*{{{char *my_getlogin()*/
11333 /* VMS cuserid == Unix getlogin, except calling sequence */
11334 char *
11335 my_getlogin(void)
11336 {
11337     static char user[L_cuserid];
11338     return cuserid(user);
11339 }
11340 /*}}}*/
11341
11342
11343 /*  rmscopy - copy a file using VMS RMS routines
11344  *
11345  *  Copies contents and attributes of spec_in to spec_out, except owner
11346  *  and protection information.  Name and type of spec_in are used as
11347  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
11348  *  should try to propagate timestamps from the input file to the output file.
11349  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
11350  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
11351  *  propagated to the output file at creation iff the output file specification
11352  *  did not contain an explicit name or type, and the revision date is always
11353  *  updated at the end of the copy operation.  If it is greater than 0, then
11354  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11355  *  other than the revision date should be propagated, and bit 1 indicates
11356  *  that the revision date should be propagated.
11357  *
11358  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11359  *
11360  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11361  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
11362  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
11363  * as part of the Perl standard distribution under the terms of the
11364  * GNU General Public License or the Perl Artistic License.  Copies
11365  * of each may be found in the Perl standard distribution.
11366  */ /* FIXME */
11367 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11368 int
11369 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11370 {
11371     char *vmsin, * vmsout, *esa, *esa_out,
11372          *rsa, *ubf;
11373     unsigned long int i, sts, sts2;
11374     int dna_len;
11375     struct FAB fab_in, fab_out;
11376     struct RAB rab_in, rab_out;
11377     rms_setup_nam(nam);
11378     rms_setup_nam(nam_out);
11379     struct XABDAT xabdat;
11380     struct XABFHC xabfhc;
11381     struct XABRDT xabrdt;
11382     struct XABSUM xabsum;
11383
11384     vmsin = PerlMem_malloc(VMS_MAXRSS);
11385     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11386     vmsout = PerlMem_malloc(VMS_MAXRSS);
11387     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11388     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11389         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11390       PerlMem_free(vmsin);
11391       PerlMem_free(vmsout);
11392       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11393       return 0;
11394     }
11395
11396     esa = PerlMem_malloc(VMS_MAXRSS);
11397     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11398     fab_in = cc$rms_fab;
11399     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11400     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11401     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11402     fab_in.fab$l_fop = FAB$M_SQO;
11403     rms_bind_fab_nam(fab_in, nam);
11404     fab_in.fab$l_xab = (void *) &xabdat;
11405
11406     rsa = PerlMem_malloc(VMS_MAXRSS);
11407     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11408     rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11409     rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11410     rms_nam_esl(nam) = 0;
11411     rms_nam_rsl(nam) = 0;
11412     rms_nam_esll(nam) = 0;
11413     rms_nam_rsll(nam) = 0;
11414 #ifdef NAM$M_NO_SHORT_UPCASE
11415     if (decc_efs_case_preserve)
11416         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11417 #endif
11418
11419     xabdat = cc$rms_xabdat;        /* To get creation date */
11420     xabdat.xab$l_nxt = (void *) &xabfhc;
11421
11422     xabfhc = cc$rms_xabfhc;        /* To get record length */
11423     xabfhc.xab$l_nxt = (void *) &xabsum;
11424
11425     xabsum = cc$rms_xabsum;        /* To get key and area information */
11426
11427     if (!((sts = sys$open(&fab_in)) & 1)) {
11428       PerlMem_free(vmsin);
11429       PerlMem_free(vmsout);
11430       PerlMem_free(esa);
11431       PerlMem_free(rsa);
11432       set_vaxc_errno(sts);
11433       switch (sts) {
11434         case RMS$_FNF: case RMS$_DNF:
11435           set_errno(ENOENT); break;
11436         case RMS$_DIR:
11437           set_errno(ENOTDIR); break;
11438         case RMS$_DEV:
11439           set_errno(ENODEV); break;
11440         case RMS$_SYN:
11441           set_errno(EINVAL); break;
11442         case RMS$_PRV:
11443           set_errno(EACCES); break;
11444         default:
11445           set_errno(EVMSERR);
11446       }
11447       return 0;
11448     }
11449
11450     nam_out = nam;
11451     fab_out = fab_in;
11452     fab_out.fab$w_ifi = 0;
11453     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11454     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11455     fab_out.fab$l_fop = FAB$M_SQO;
11456     rms_bind_fab_nam(fab_out, nam_out);
11457     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11458     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11459     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11460     esa_out = PerlMem_malloc(VMS_MAXRSS);
11461     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11462     rms_set_rsa(nam_out, NULL, 0);
11463     rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11464
11465     if (preserve_dates == 0) {  /* Act like DCL COPY */
11466       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11467       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
11468       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11469         PerlMem_free(vmsin);
11470         PerlMem_free(vmsout);
11471         PerlMem_free(esa);
11472         PerlMem_free(rsa);
11473         PerlMem_free(esa_out);
11474         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11475         set_vaxc_errno(sts);
11476         return 0;
11477       }
11478       fab_out.fab$l_xab = (void *) &xabdat;
11479       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11480         preserve_dates = 1;
11481     }
11482     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
11483       preserve_dates =0;      /* bitmask from this point forward   */
11484
11485     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11486     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11487       PerlMem_free(vmsin);
11488       PerlMem_free(vmsout);
11489       PerlMem_free(esa);
11490       PerlMem_free(rsa);
11491       PerlMem_free(esa_out);
11492       set_vaxc_errno(sts);
11493       switch (sts) {
11494         case RMS$_DNF:
11495           set_errno(ENOENT); break;
11496         case RMS$_DIR:
11497           set_errno(ENOTDIR); break;
11498         case RMS$_DEV:
11499           set_errno(ENODEV); break;
11500         case RMS$_SYN:
11501           set_errno(EINVAL); break;
11502         case RMS$_PRV:
11503           set_errno(EACCES); break;
11504         default:
11505           set_errno(EVMSERR);
11506       }
11507       return 0;
11508     }
11509     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
11510     if (preserve_dates & 2) {
11511       /* sys$close() will process xabrdt, not xabdat */
11512       xabrdt = cc$rms_xabrdt;
11513 #ifndef __GNUC__
11514       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11515 #else
11516       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11517        * is unsigned long[2], while DECC & VAXC use a struct */
11518       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11519 #endif
11520       fab_out.fab$l_xab = (void *) &xabrdt;
11521     }
11522
11523     ubf = PerlMem_malloc(32256);
11524     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11525     rab_in = cc$rms_rab;
11526     rab_in.rab$l_fab = &fab_in;
11527     rab_in.rab$l_rop = RAB$M_BIO;
11528     rab_in.rab$l_ubf = ubf;
11529     rab_in.rab$w_usz = 32256;
11530     if (!((sts = sys$connect(&rab_in)) & 1)) {
11531       sys$close(&fab_in); sys$close(&fab_out);
11532       PerlMem_free(vmsin);
11533       PerlMem_free(vmsout);
11534       PerlMem_free(esa);
11535       PerlMem_free(ubf);
11536       PerlMem_free(rsa);
11537       PerlMem_free(esa_out);
11538       set_errno(EVMSERR); set_vaxc_errno(sts);
11539       return 0;
11540     }
11541
11542     rab_out = cc$rms_rab;
11543     rab_out.rab$l_fab = &fab_out;
11544     rab_out.rab$l_rbf = ubf;
11545     if (!((sts = sys$connect(&rab_out)) & 1)) {
11546       sys$close(&fab_in); sys$close(&fab_out);
11547       PerlMem_free(vmsin);
11548       PerlMem_free(vmsout);
11549       PerlMem_free(esa);
11550       PerlMem_free(ubf);
11551       PerlMem_free(rsa);
11552       PerlMem_free(esa_out);
11553       set_errno(EVMSERR); set_vaxc_errno(sts);
11554       return 0;
11555     }
11556
11557     while ((sts = sys$read(&rab_in))) {  /* always true  */
11558       if (sts == RMS$_EOF) break;
11559       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11560       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11561         sys$close(&fab_in); sys$close(&fab_out);
11562         PerlMem_free(vmsin);
11563         PerlMem_free(vmsout);
11564         PerlMem_free(esa);
11565         PerlMem_free(ubf);
11566         PerlMem_free(rsa);
11567         PerlMem_free(esa_out);
11568         set_errno(EVMSERR); set_vaxc_errno(sts);
11569         return 0;
11570       }
11571     }
11572
11573
11574     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
11575     sys$close(&fab_in);  sys$close(&fab_out);
11576     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11577     if (!(sts & 1)) {
11578       PerlMem_free(vmsin);
11579       PerlMem_free(vmsout);
11580       PerlMem_free(esa);
11581       PerlMem_free(ubf);
11582       PerlMem_free(rsa);
11583       PerlMem_free(esa_out);
11584       set_errno(EVMSERR); set_vaxc_errno(sts);
11585       return 0;
11586     }
11587
11588     PerlMem_free(vmsin);
11589     PerlMem_free(vmsout);
11590     PerlMem_free(esa);
11591     PerlMem_free(ubf);
11592     PerlMem_free(rsa);
11593     PerlMem_free(esa_out);
11594     return 1;
11595
11596 }  /* end of rmscopy() */
11597 /*}}}*/
11598
11599
11600 /***  The following glue provides 'hooks' to make some of the routines
11601  * from this file available from Perl.  These routines are sufficiently
11602  * basic, and are required sufficiently early in the build process,
11603  * that's it's nice to have them available to miniperl as well as the
11604  * full Perl, so they're set up here instead of in an extension.  The
11605  * Perl code which handles importation of these names into a given
11606  * package lives in [.VMS]Filespec.pm in @INC.
11607  */
11608
11609 void
11610 rmsexpand_fromperl(pTHX_ CV *cv)
11611 {
11612   dXSARGS;
11613   char *fspec, *defspec = NULL, *rslt;
11614   STRLEN n_a;
11615   int fs_utf8, dfs_utf8;
11616
11617   fs_utf8 = 0;
11618   dfs_utf8 = 0;
11619   if (!items || items > 2)
11620     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11621   fspec = SvPV(ST(0),n_a);
11622   fs_utf8 = SvUTF8(ST(0));
11623   if (!fspec || !*fspec) XSRETURN_UNDEF;
11624   if (items == 2) {
11625     defspec = SvPV(ST(1),n_a);
11626     dfs_utf8 = SvUTF8(ST(1));
11627   }
11628   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11629   ST(0) = sv_newmortal();
11630   if (rslt != NULL) {
11631     sv_usepvn(ST(0),rslt,strlen(rslt));
11632     if (fs_utf8) {
11633         SvUTF8_on(ST(0));
11634     }
11635   }
11636   XSRETURN(1);
11637 }
11638
11639 void
11640 vmsify_fromperl(pTHX_ CV *cv)
11641 {
11642   dXSARGS;
11643   char *vmsified;
11644   STRLEN n_a;
11645   int utf8_fl;
11646
11647   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11648   utf8_fl = SvUTF8(ST(0));
11649   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11650   ST(0) = sv_newmortal();
11651   if (vmsified != NULL) {
11652     sv_usepvn(ST(0),vmsified,strlen(vmsified));
11653     if (utf8_fl) {
11654         SvUTF8_on(ST(0));
11655     }
11656   }
11657   XSRETURN(1);
11658 }
11659
11660 void
11661 unixify_fromperl(pTHX_ CV *cv)
11662 {
11663   dXSARGS;
11664   char *unixified;
11665   STRLEN n_a;
11666   int utf8_fl;
11667
11668   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11669   utf8_fl = SvUTF8(ST(0));
11670   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11671   ST(0) = sv_newmortal();
11672   if (unixified != NULL) {
11673     sv_usepvn(ST(0),unixified,strlen(unixified));
11674     if (utf8_fl) {
11675         SvUTF8_on(ST(0));
11676     }
11677   }
11678   XSRETURN(1);
11679 }
11680
11681 void
11682 fileify_fromperl(pTHX_ CV *cv)
11683 {
11684   dXSARGS;
11685   char *fileified;
11686   STRLEN n_a;
11687   int utf8_fl;
11688
11689   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11690   utf8_fl = SvUTF8(ST(0));
11691   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11692   ST(0) = sv_newmortal();
11693   if (fileified != NULL) {
11694     sv_usepvn(ST(0),fileified,strlen(fileified));
11695     if (utf8_fl) {
11696         SvUTF8_on(ST(0));
11697     }
11698   }
11699   XSRETURN(1);
11700 }
11701
11702 void
11703 pathify_fromperl(pTHX_ CV *cv)
11704 {
11705   dXSARGS;
11706   char *pathified;
11707   STRLEN n_a;
11708   int utf8_fl;
11709
11710   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11711   utf8_fl = SvUTF8(ST(0));
11712   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11713   ST(0) = sv_newmortal();
11714   if (pathified != NULL) {
11715     sv_usepvn(ST(0),pathified,strlen(pathified));
11716     if (utf8_fl) {
11717         SvUTF8_on(ST(0));
11718     }
11719   }
11720   XSRETURN(1);
11721 }
11722
11723 void
11724 vmspath_fromperl(pTHX_ CV *cv)
11725 {
11726   dXSARGS;
11727   char *vmspath;
11728   STRLEN n_a;
11729   int utf8_fl;
11730
11731   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11732   utf8_fl = SvUTF8(ST(0));
11733   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11734   ST(0) = sv_newmortal();
11735   if (vmspath != NULL) {
11736     sv_usepvn(ST(0),vmspath,strlen(vmspath));
11737     if (utf8_fl) {
11738         SvUTF8_on(ST(0));
11739     }
11740   }
11741   XSRETURN(1);
11742 }
11743
11744 void
11745 unixpath_fromperl(pTHX_ CV *cv)
11746 {
11747   dXSARGS;
11748   char *unixpath;
11749   STRLEN n_a;
11750   int utf8_fl;
11751
11752   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11753   utf8_fl = SvUTF8(ST(0));
11754   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11755   ST(0) = sv_newmortal();
11756   if (unixpath != NULL) {
11757     sv_usepvn(ST(0),unixpath,strlen(unixpath));
11758     if (utf8_fl) {
11759         SvUTF8_on(ST(0));
11760     }
11761   }
11762   XSRETURN(1);
11763 }
11764
11765 void
11766 candelete_fromperl(pTHX_ CV *cv)
11767 {
11768   dXSARGS;
11769   char *fspec, *fsp;
11770   SV *mysv;
11771   IO *io;
11772   STRLEN n_a;
11773
11774   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11775
11776   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11777   Newx(fspec, VMS_MAXRSS, char);
11778   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11779   if (SvTYPE(mysv) == SVt_PVGV) {
11780     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11781       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11782       ST(0) = &PL_sv_no;
11783       Safefree(fspec);
11784       XSRETURN(1);
11785     }
11786     fsp = fspec;
11787   }
11788   else {
11789     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11790       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11791       ST(0) = &PL_sv_no;
11792       Safefree(fspec);
11793       XSRETURN(1);
11794     }
11795   }
11796
11797   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11798   Safefree(fspec);
11799   XSRETURN(1);
11800 }
11801
11802 void
11803 rmscopy_fromperl(pTHX_ CV *cv)
11804 {
11805   dXSARGS;
11806   char *inspec, *outspec, *inp, *outp;
11807   int date_flag;
11808   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11809                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11810   unsigned long int sts;
11811   SV *mysv;
11812   IO *io;
11813   STRLEN n_a;
11814
11815   if (items < 2 || items > 3)
11816     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11817
11818   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11819   Newx(inspec, VMS_MAXRSS, char);
11820   if (SvTYPE(mysv) == SVt_PVGV) {
11821     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11822       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11823       ST(0) = &PL_sv_no;
11824       Safefree(inspec);
11825       XSRETURN(1);
11826     }
11827     inp = inspec;
11828   }
11829   else {
11830     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11831       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11832       ST(0) = &PL_sv_no;
11833       Safefree(inspec);
11834       XSRETURN(1);
11835     }
11836   }
11837   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11838   Newx(outspec, VMS_MAXRSS, char);
11839   if (SvTYPE(mysv) == SVt_PVGV) {
11840     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11841       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11842       ST(0) = &PL_sv_no;
11843       Safefree(inspec);
11844       Safefree(outspec);
11845       XSRETURN(1);
11846     }
11847     outp = outspec;
11848   }
11849   else {
11850     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11851       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11852       ST(0) = &PL_sv_no;
11853       Safefree(inspec);
11854       Safefree(outspec);
11855       XSRETURN(1);
11856     }
11857   }
11858   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11859
11860   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11861   Safefree(inspec);
11862   Safefree(outspec);
11863   XSRETURN(1);
11864 }
11865
11866 /* The mod2fname is limited to shorter filenames by design, so it should
11867  * not be modified to support longer EFS pathnames
11868  */
11869 void
11870 mod2fname(pTHX_ CV *cv)
11871 {
11872   dXSARGS;
11873   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11874        workbuff[NAM$C_MAXRSS*1 + 1];
11875   int total_namelen = 3, counter, num_entries;
11876   /* ODS-5 ups this, but we want to be consistent, so... */
11877   int max_name_len = 39;
11878   AV *in_array = (AV *)SvRV(ST(0));
11879
11880   num_entries = av_len(in_array);
11881
11882   /* All the names start with PL_. */
11883   strcpy(ultimate_name, "PL_");
11884
11885   /* Clean up our working buffer */
11886   Zero(work_name, sizeof(work_name), char);
11887
11888   /* Run through the entries and build up a working name */
11889   for(counter = 0; counter <= num_entries; counter++) {
11890     /* If it's not the first name then tack on a __ */
11891     if (counter) {
11892       strcat(work_name, "__");
11893     }
11894     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11895                            PL_na));
11896   }
11897
11898   /* Check to see if we actually have to bother...*/
11899   if (strlen(work_name) + 3 <= max_name_len) {
11900     strcat(ultimate_name, work_name);
11901   } else {
11902     /* It's too darned big, so we need to go strip. We use the same */
11903     /* algorithm as xsubpp does. First, strip out doubled __ */
11904     char *source, *dest, last;
11905     dest = workbuff;
11906     last = 0;
11907     for (source = work_name; *source; source++) {
11908       if (last == *source && last == '_') {
11909         continue;
11910       }
11911       *dest++ = *source;
11912       last = *source;
11913     }
11914     /* Go put it back */
11915     strcpy(work_name, workbuff);
11916     /* Is it still too big? */
11917     if (strlen(work_name) + 3 > max_name_len) {
11918       /* Strip duplicate letters */
11919       last = 0;
11920       dest = workbuff;
11921       for (source = work_name; *source; source++) {
11922         if (last == toupper(*source)) {
11923         continue;
11924         }
11925         *dest++ = *source;
11926         last = toupper(*source);
11927       }
11928       strcpy(work_name, workbuff);
11929     }
11930
11931     /* Is it *still* too big? */
11932     if (strlen(work_name) + 3 > max_name_len) {
11933       /* Too bad, we truncate */
11934       work_name[max_name_len - 2] = 0;
11935     }
11936     strcat(ultimate_name, work_name);
11937   }
11938
11939   /* Okay, return it */
11940   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11941   XSRETURN(1);
11942 }
11943
11944 void
11945 hushexit_fromperl(pTHX_ CV *cv)
11946 {
11947     dXSARGS;
11948
11949     if (items > 0) {
11950         VMSISH_HUSHED = SvTRUE(ST(0));
11951     }
11952     ST(0) = boolSV(VMSISH_HUSHED);
11953     XSRETURN(1);
11954 }
11955
11956
11957 PerlIO *
11958 Perl_vms_start_glob
11959    (pTHX_ SV *tmpglob,
11960     IO *io)
11961 {
11962     PerlIO *fp;
11963     struct vs_str_st *rslt;
11964     char *vmsspec;
11965     char *rstr;
11966     char *begin, *cp;
11967     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11968     PerlIO *tmpfp;
11969     STRLEN i;
11970     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11971     struct dsc$descriptor_vs rsdsc;
11972     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11973     unsigned long hasver = 0, isunix = 0;
11974     unsigned long int lff_flags = 0;
11975     int rms_sts;
11976
11977 #ifdef VMS_LONGNAME_SUPPORT
11978     lff_flags = LIB$M_FIL_LONG_NAMES;
11979 #endif
11980     /* The Newx macro will not allow me to assign a smaller array
11981      * to the rslt pointer, so we will assign it to the begin char pointer
11982      * and then copy the value into the rslt pointer.
11983      */
11984     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11985     rslt = (struct vs_str_st *)begin;
11986     rslt->length = 0;
11987     rstr = &rslt->str[0];
11988     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11989     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11990     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11991     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11992
11993     Newx(vmsspec, VMS_MAXRSS, char);
11994
11995         /* We could find out if there's an explicit dev/dir or version
11996            by peeking into lib$find_file's internal context at
11997            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11998            but that's unsupported, so I don't want to do it now and
11999            have it bite someone in the future. */
12000         /* Fix-me: vms_split_path() is the only way to do this, the
12001            existing method will fail with many legal EFS or UNIX specifications
12002          */
12003
12004     cp = SvPV(tmpglob,i);
12005
12006     for (; i; i--) {
12007         if (cp[i] == ';') hasver = 1;
12008         if (cp[i] == '.') {
12009             if (sts) hasver = 1;
12010             else sts = 1;
12011         }
12012         if (cp[i] == '/') {
12013             hasdir = isunix = 1;
12014             break;
12015         }
12016         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12017             hasdir = 1;
12018             break;
12019         }
12020     }
12021     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12022         int found = 0;
12023         Stat_t st;
12024         int stat_sts;
12025         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12026         if (!stat_sts && S_ISDIR(st.st_mode)) {
12027             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12028             ok = (wilddsc.dsc$a_pointer != NULL);
12029             /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12030             hasdir = 1;
12031         }
12032         else {
12033             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12034             ok = (wilddsc.dsc$a_pointer != NULL);
12035         }
12036         if (ok)
12037             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12038
12039         /* If not extended character set, replace ? with % */
12040         /* With extended character set, ? is a wildcard single character */
12041         if (!decc_efs_case_preserve) {
12042             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12043                 if (*cp == '?') *cp = '%';
12044         }
12045         sts = SS$_NORMAL;
12046         while (ok && $VMS_STATUS_SUCCESS(sts)) {
12047          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12048          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12049
12050             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12051                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
12052             if (!$VMS_STATUS_SUCCESS(sts))
12053                 break;
12054
12055             found++;
12056
12057             /* with varying string, 1st word of buffer contains result length */
12058             rstr[rslt->length] = '\0';
12059
12060              /* Find where all the components are */
12061              v_sts = vms_split_path
12062                        (rstr,
12063                         &v_spec,
12064                         &v_len,
12065                         &r_spec,
12066                         &r_len,
12067                         &d_spec,
12068                         &d_len,
12069                         &n_spec,
12070                         &n_len,
12071                         &e_spec,
12072                         &e_len,
12073                         &vs_spec,
12074                         &vs_len);
12075
12076             /* If no version on input, truncate the version on output */
12077             if (!hasver && (vs_len > 0)) {
12078                 *vs_spec = '\0';
12079                 vs_len = 0;
12080
12081                 /* No version & a null extension on UNIX handling */
12082                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12083                     e_len = 0;
12084                     *e_spec = '\0';
12085                 }
12086             }
12087
12088             if (!decc_efs_case_preserve) {
12089                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12090             }
12091
12092             if (hasdir) {
12093                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12094                 begin = rstr;
12095             }
12096             else {
12097                 /* Start with the name */
12098                 begin = n_spec;
12099             }
12100             strcat(begin,"\n");
12101             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12102         }
12103         if (cxt) (void)lib$find_file_end(&cxt);
12104
12105         if (!found) {
12106             /* Be POSIXish: return the input pattern when no matches */
12107             begin = SvPVX(tmpglob);
12108             strcat(begin,"\n");
12109             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12110         }
12111
12112         if (ok && sts != RMS$_NMF &&
12113             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12114         if (!ok) {
12115             if (!(sts & 1)) {
12116                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12117             }
12118             PerlIO_close(tmpfp);
12119             fp = NULL;
12120         }
12121         else {
12122             PerlIO_rewind(tmpfp);
12123             IoTYPE(io) = IoTYPE_RDONLY;
12124             IoIFP(io) = fp = tmpfp;
12125             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
12126         }
12127     }
12128     Safefree(vmsspec);
12129     Safefree(rslt);
12130     return fp;
12131 }
12132
12133
12134 #ifdef HAS_SYMLINK
12135 static char *
12136 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
12137
12138 void
12139 vms_realpath_fromperl(pTHX_ CV *cv)
12140 {
12141   dXSARGS;
12142   char *fspec, *rslt_spec, *rslt;
12143   STRLEN n_a;
12144
12145   if (!items || items != 1)
12146     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12147
12148   fspec = SvPV(ST(0),n_a);
12149   if (!fspec || !*fspec) XSRETURN_UNDEF;
12150
12151   Newx(rslt_spec, VMS_MAXRSS + 1, char);
12152   rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12153   ST(0) = sv_newmortal();
12154   if (rslt != NULL)
12155     sv_usepvn(ST(0),rslt,strlen(rslt));
12156   else
12157     Safefree(rslt_spec);
12158   XSRETURN(1);
12159 }
12160 #endif
12161
12162 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12163 int do_vms_case_tolerant(void);
12164
12165 void
12166 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12167 {
12168   dXSARGS;
12169   ST(0) = boolSV(do_vms_case_tolerant());
12170   XSRETURN(1);
12171 }
12172 #endif
12173
12174 void
12175 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12176                           struct interp_intern *dst)
12177 {
12178     memcpy(dst,src,sizeof(struct interp_intern));
12179 }
12180
12181 void
12182 Perl_sys_intern_clear(pTHX)
12183 {
12184 }
12185
12186 void
12187 Perl_sys_intern_init(pTHX)
12188 {
12189     unsigned int ix = RAND_MAX;
12190     double x;
12191
12192     VMSISH_HUSHED = 0;
12193
12194     /* fix me later to track running under GNV */
12195     /* this allows some limited testing */
12196     MY_POSIX_EXIT = decc_filename_unix_report;
12197
12198     x = (float)ix;
12199     MY_INV_RAND_MAX = 1./x;
12200 }
12201
12202 void
12203 init_os_extras(void)
12204 {
12205   dTHX;
12206   char* file = __FILE__;
12207   if (decc_disable_to_vms_logname_translation) {
12208     no_translate_barewords = TRUE;
12209   } else {
12210     no_translate_barewords = FALSE;
12211   }
12212
12213   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
12214   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
12215   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
12216   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
12217   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
12218   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
12219   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
12220   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
12221   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
12222   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
12223   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
12224 #ifdef HAS_SYMLINK
12225   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
12226 #endif
12227 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12228   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
12229 #endif
12230
12231   store_pipelocs(aTHX);         /* will redo any earlier attempts */
12232
12233   return;
12234 }
12235
12236 #ifdef HAS_SYMLINK
12237
12238 #if __CRTL_VER == 80200000
12239 /* This missed getting in to the DECC SDK for 8.2 */
12240 char *realpath(const char *file_name, char * resolved_name, ...);
12241 #endif
12242
12243 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
12244 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
12245  * The perl fallback routine to provide realpath() is not as efficient
12246  * on OpenVMS.
12247  */
12248 static char *
12249 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12250 {
12251     return realpath(filespec, outbuf);
12252 }
12253
12254 /*}}}*/
12255 /* External entry points */
12256 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12257 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
12258 #else
12259 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12260 { return NULL; }
12261 #endif
12262
12263
12264 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12265 /* case_tolerant */
12266
12267 /*{{{int do_vms_case_tolerant(void)*/
12268 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
12269  * controlled by a process setting.
12270  */
12271 int do_vms_case_tolerant(void)
12272 {
12273     return vms_process_case_tolerant;
12274 }
12275 /*}}}*/
12276 /* External entry points */
12277 int Perl_vms_case_tolerant(void)
12278 { return do_vms_case_tolerant(); }
12279 #else
12280 int Perl_vms_case_tolerant(void)
12281 { return vms_process_case_tolerant; }
12282 #endif
12283
12284
12285  /* Start of DECC RTL Feature handling */
12286
12287 static int sys_trnlnm
12288    (const char * logname,
12289     char * value,
12290     int value_len)
12291 {
12292     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
12293     const unsigned long attr = LNM$M_CASE_BLIND;
12294     struct dsc$descriptor_s name_dsc;
12295     int status;
12296     unsigned short result;
12297     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
12298                                 {0, 0, 0, 0}};
12299
12300     name_dsc.dsc$w_length = strlen(logname);
12301     name_dsc.dsc$a_pointer = (char *)logname;
12302     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12303     name_dsc.dsc$b_class = DSC$K_CLASS_S;
12304
12305     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
12306
12307     if ($VMS_STATUS_SUCCESS(status)) {
12308
12309          /* Null terminate and return the string */
12310         /*--------------------------------------*/
12311         value[result] = 0;
12312     }
12313
12314     return status;
12315 }
12316
12317 static int sys_crelnm
12318    (const char * logname,
12319     const char * value)
12320 {
12321     int ret_val;
12322     const char * proc_table = "LNM$PROCESS_TABLE";
12323     struct dsc$descriptor_s proc_table_dsc;
12324     struct dsc$descriptor_s logname_dsc;
12325     struct itmlst_3 item_list[2];
12326
12327     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
12328     proc_table_dsc.dsc$w_length = strlen(proc_table);
12329     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12330     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
12331
12332     logname_dsc.dsc$a_pointer = (char *) logname;
12333     logname_dsc.dsc$w_length = strlen(logname);
12334     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12335     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
12336
12337     item_list[0].buflen = strlen(value);
12338     item_list[0].itmcode = LNM$_STRING;
12339     item_list[0].bufadr = (char *)value;
12340     item_list[0].retlen = NULL;
12341
12342     item_list[1].buflen = 0;
12343     item_list[1].itmcode = 0;
12344
12345     ret_val = sys$crelnm
12346                        (NULL,
12347                         (const struct dsc$descriptor_s *)&proc_table_dsc,
12348                         (const struct dsc$descriptor_s *)&logname_dsc,
12349                         NULL,
12350                         (const struct item_list_3 *) item_list);
12351
12352     return ret_val;
12353 }
12354
12355 /* C RTL Feature settings */
12356
12357 static int set_features
12358    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
12359     int (* cli_routine)(void),  /* Not documented */
12360     void *image_info)           /* Not documented */
12361 {
12362     int status;
12363     int s;
12364     int dflt;
12365     char* str;
12366     char val_str[10];
12367 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12368     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12369     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12370     unsigned long case_perm;
12371     unsigned long case_image;
12372 #endif
12373
12374     /* Allow an exception to bring Perl into the VMS debugger */
12375     vms_debug_on_exception = 0;
12376     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12377     if ($VMS_STATUS_SUCCESS(status)) {
12378        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12379          vms_debug_on_exception = 1;
12380        else
12381          vms_debug_on_exception = 0;
12382     }
12383
12384     /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
12385     vms_vtf7_filenames = 0;
12386     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12387     if ($VMS_STATUS_SUCCESS(status)) {
12388        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12389          vms_vtf7_filenames = 1;
12390        else
12391          vms_vtf7_filenames = 0;
12392     }
12393
12394     /* Dectect running under GNV Bash or other UNIX like shell */
12395 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12396     gnv_unix_shell = 0;
12397     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12398     if ($VMS_STATUS_SUCCESS(status)) {
12399        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12400          gnv_unix_shell = 1;
12401          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12402          set_feature_default("DECC$EFS_CHARSET", 1);
12403          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12404          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12405          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12406          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12407        }
12408        else
12409          gnv_unix_shell = 0;
12410     }
12411 #endif
12412
12413     /* hacks to see if known bugs are still present for testing */
12414
12415     /* Readdir is returning filenames in VMS syntax always */
12416     decc_bug_readdir_efs1 = 1;
12417     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12418     if ($VMS_STATUS_SUCCESS(status)) {
12419        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12420          decc_bug_readdir_efs1 = 1;
12421        else
12422          decc_bug_readdir_efs1 = 0;
12423     }
12424
12425     /* PCP mode requires creating /dev/null special device file */
12426     decc_bug_devnull = 0;
12427     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12428     if ($VMS_STATUS_SUCCESS(status)) {
12429        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12430           decc_bug_devnull = 1;
12431        else
12432           decc_bug_devnull = 0;
12433     }
12434
12435     /* fgetname returning a VMS name in UNIX mode */
12436     decc_bug_fgetname = 1;
12437     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12438     if ($VMS_STATUS_SUCCESS(status)) {
12439       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12440         decc_bug_fgetname = 1;
12441       else
12442         decc_bug_fgetname = 0;
12443     }
12444
12445     /* UNIX directory names with no paths are broken in a lot of places */
12446     decc_dir_barename = 1;
12447     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12448     if ($VMS_STATUS_SUCCESS(status)) {
12449       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12450         decc_dir_barename = 1;
12451       else
12452         decc_dir_barename = 0;
12453     }
12454
12455 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12456     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12457     if (s >= 0) {
12458         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12459         if (decc_disable_to_vms_logname_translation < 0)
12460             decc_disable_to_vms_logname_translation = 0;
12461     }
12462
12463     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12464     if (s >= 0) {
12465         decc_efs_case_preserve = decc$feature_get_value(s, 1);
12466         if (decc_efs_case_preserve < 0)
12467             decc_efs_case_preserve = 0;
12468     }
12469
12470     s = decc$feature_get_index("DECC$EFS_CHARSET");
12471     if (s >= 0) {
12472         decc_efs_charset = decc$feature_get_value(s, 1);
12473         if (decc_efs_charset < 0)
12474             decc_efs_charset = 0;
12475     }
12476
12477     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12478     if (s >= 0) {
12479         decc_filename_unix_report = decc$feature_get_value(s, 1);
12480         if (decc_filename_unix_report > 0)
12481             decc_filename_unix_report = 1;
12482         else
12483             decc_filename_unix_report = 0;
12484     }
12485
12486     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12487     if (s >= 0) {
12488         decc_filename_unix_only = decc$feature_get_value(s, 1);
12489         if (decc_filename_unix_only > 0) {
12490             decc_filename_unix_only = 1;
12491         }
12492         else {
12493             decc_filename_unix_only = 0;
12494         }
12495     }
12496
12497     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12498     if (s >= 0) {
12499         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12500         if (decc_filename_unix_no_version < 0)
12501             decc_filename_unix_no_version = 0;
12502     }
12503
12504     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12505     if (s >= 0) {
12506         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12507         if (decc_readdir_dropdotnotype < 0)
12508             decc_readdir_dropdotnotype = 0;
12509     }
12510
12511     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12512     if ($VMS_STATUS_SUCCESS(status)) {
12513         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12514         if (s >= 0) {
12515             dflt = decc$feature_get_value(s, 4);
12516             if (dflt > 0) {
12517                 decc_disable_posix_root = decc$feature_get_value(s, 1);
12518                 if (decc_disable_posix_root <= 0) {
12519                     decc$feature_set_value(s, 1, 1);
12520                     decc_disable_posix_root = 1;
12521                 }
12522             }
12523             else {
12524                 /* Traditionally Perl assumes this is off */
12525                 decc_disable_posix_root = 1;
12526                 decc$feature_set_value(s, 1, 1);
12527             }
12528         }
12529     }
12530
12531 #if __CRTL_VER >= 80200000
12532     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12533     if (s >= 0) {
12534         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12535         if (decc_posix_compliant_pathnames < 0)
12536             decc_posix_compliant_pathnames = 0;
12537         if (decc_posix_compliant_pathnames > 4)
12538             decc_posix_compliant_pathnames = 0;
12539     }
12540
12541 #endif
12542 #else
12543     status = sys_trnlnm
12544         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12545     if ($VMS_STATUS_SUCCESS(status)) {
12546         val_str[0] = _toupper(val_str[0]);
12547         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12548            decc_disable_to_vms_logname_translation = 1;
12549         }
12550     }
12551
12552 #ifndef __VAX
12553     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12554     if ($VMS_STATUS_SUCCESS(status)) {
12555         val_str[0] = _toupper(val_str[0]);
12556         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12557            decc_efs_case_preserve = 1;
12558         }
12559     }
12560 #endif
12561
12562     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12563     if ($VMS_STATUS_SUCCESS(status)) {
12564         val_str[0] = _toupper(val_str[0]);
12565         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12566            decc_filename_unix_report = 1;
12567         }
12568     }
12569     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12570     if ($VMS_STATUS_SUCCESS(status)) {
12571         val_str[0] = _toupper(val_str[0]);
12572         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12573            decc_filename_unix_only = 1;
12574            decc_filename_unix_report = 1;
12575         }
12576     }
12577     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12578     if ($VMS_STATUS_SUCCESS(status)) {
12579         val_str[0] = _toupper(val_str[0]);
12580         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12581            decc_filename_unix_no_version = 1;
12582         }
12583     }
12584     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12585     if ($VMS_STATUS_SUCCESS(status)) {
12586         val_str[0] = _toupper(val_str[0]);
12587         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12588            decc_readdir_dropdotnotype = 1;
12589         }
12590     }
12591 #endif
12592
12593 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12594
12595      /* Report true case tolerance */
12596     /*----------------------------*/
12597     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12598     if (!$VMS_STATUS_SUCCESS(status))
12599         case_perm = PPROP$K_CASE_BLIND;
12600     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12601     if (!$VMS_STATUS_SUCCESS(status))
12602         case_image = PPROP$K_CASE_BLIND;
12603     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12604         (case_image == PPROP$K_CASE_SENSITIVE))
12605         vms_process_case_tolerant = 0;
12606
12607 #endif
12608
12609
12610     /* CRTL can be initialized past this point, but not before. */
12611 /*    DECC$CRTL_INIT(); */
12612
12613     return SS$_NORMAL;
12614 }
12615
12616 #ifdef __DECC
12617 #pragma nostandard
12618 #pragma extern_model save
12619 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12620         const __align (LONGWORD) int spare[8] = {0};
12621
12622 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
12623 #if __DECC_VER >= 60560002
12624 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
12625 #else
12626 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
12627 #endif
12628 #endif /* __DECC */
12629
12630 const long vms_cc_features = (const long)set_features;
12631
12632 /*
12633 ** Force a reference to LIB$INITIALIZE to ensure it
12634 ** exists in the image.
12635 */
12636 int lib$initialize(void);
12637 #ifdef __DECC
12638 #pragma extern_model strict_refdef
12639 #endif
12640     int lib_init_ref = (int) lib$initialize;
12641
12642 #ifdef __DECC
12643 #pragma extern_model restore
12644 #pragma standard
12645 #endif
12646
12647 /*  End of vms.c */