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         /* Don't escape again if following character is
 525          * already something we escape.
 526          */
 527         if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
 528             *outspec = *inspec;
 529             *output_cnt = 1;
 530             return 1;
 531             break;
 532         }
 533         /* But otherwise fall through and escape it. */
 534     case '=':
 535         /* Assume that this is to be escaped */
 536         outspec[0] = '^';
 537         outspec[1] = *inspec;
 538         *output_cnt = 2;
 539         return 1;
 540         break;
 541     case ' ': /* space */
 542         /* Assume that this is to be escaped */
 543         outspec[0] = '^';
 544         outspec[1] = '_';
 545         *output_cnt = 2;
 546         return 1;
 547         break;
 548     default:
 549         *outspec = *inspec;
 550         *output_cnt = 1;
 551         return 1;
 552         break;
 553     }
 554 }
 555
 556
 557 /* This handles the expansion of a '^' prefix to the proper character
 558  * in a UNIX file specification.
 559  *
 560  * The output count variable contains the number of characters added
 561  * to the output string.
 562  *
 563  * The return value is the number of characters read from the input
 564  * string
 565  */
 566 static int copy_expand_vms_filename_escape
 567   (char *outspec, const char *inspec, int *output_cnt)
 568 {
 569 int count;
 570 int scnt;
 571
 572     count = 0;
 573     *output_cnt = 0;
 574     if (*inspec == '^') {
 575         inspec++;
 576         switch (*inspec) {
 577         /* Spaces and non-trailing dots should just be passed through,
 578          * but eat the escape character.
 579          */
 580         case '.':
 581             *outspec = *inspec;
 582             count += 2;
 583             (*output_cnt)++;
 584             break;
 585         case '_': /* space */
 586             *outspec = ' ';
 587             count += 2;
 588             (*output_cnt)++;
 589             break;
 590         case '^':
 591             /* Hmm.  Better leave the escape escaped. */
 592             outspec[0] = '^';
 593             outspec[1] = '^';
 594             count += 2;
 595             (*output_cnt) += 2;
 596             break;
 597         case 'U': /* Unicode - FIX-ME this is wrong. */
 598             inspec++;
 599             count++;
 600             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 601             if (scnt == 4) {
 602                 unsigned int c1, c2;
 603                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 604                 outspec[0] == c1 & 0xff;
 605                 outspec[1] == c2 & 0xff;
 606                 if (scnt > 1) {
 607                     (*output_cnt) += 2;
 608                     count += 4;
 609                 }
 610             }
 611             else {
 612                 /* Error - do best we can to continue */
 613                 *outspec = 'U';
 614                 outspec++;
 615                 (*output_cnt++);
 616                 *outspec = *inspec;
 617                 count++;
 618                 (*output_cnt++);
 619             }
 620             break;
 621         default:
 622             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 623             if (scnt == 2) {
 624                 /* Hex encoded */
 625                 unsigned int c1;
 626                 scnt = sscanf(inspec, "%2x", &c1);
 627                 outspec[0] = c1 & 0xff;
 628                 if (scnt > 0) {
 629                     (*output_cnt++);
 630                     count += 2;
 631                 }
 632             }
 633             else {
 634                 *outspec = *inspec;
 635                 count++;
 636                 (*output_cnt++);
 637             }
 638         }
 639     }
 640     else {
 641         *outspec = *inspec;
 642         count++;
 643         (*output_cnt)++;
 644     }
 645     return count;
 646 }
 647
 648 #ifdef sys$filescan
 649 #undef sys$filescan
 650 int sys$filescan
 651    (const struct dsc$descriptor_s * srcstr,
 652     struct filescan_itmlst_2 * valuelist,
 653     unsigned long * fldflags,
 654     struct dsc$descriptor_s *auxout,
 655     unsigned short * retlen);
 656 #endif
 657
 658 /* vms_split_path - Verify that the input file specification is a
 659  * VMS format file specification, and provide pointers to the components of
 660  * it.  With EFS format filenames, this is virtually the only way to
 661  * parse a VMS path specification into components.
 662  *
 663  * If the sum of the components do not add up to the length of the
 664  * string, then the passed file specification is probably a UNIX style
 665  * path.
 666  */
 667 static int vms_split_path
 668    (const char * path,
 669     char * * volume,
 670     int * vol_len,
 671     char * * root,
 672     int * root_len,
 673     char * * dir,
 674     int * dir_len,
 675     char * * name,
 676     int * name_len,
 677     char * * ext,
 678     int * ext_len,
 679     char * * version,
 680     int * ver_len)
 681 {
 682 struct dsc$descriptor path_desc;
 683 int status;
 684 unsigned long flags;
 685 int ret_stat;
 686 struct filescan_itmlst_2 item_list[9];
 687 const int filespec = 0;
 688 const int nodespec = 1;
 689 const int devspec = 2;
 690 const int rootspec = 3;
 691 const int dirspec = 4;
 692 const int namespec = 5;
 693 const int typespec = 6;
 694 const int verspec = 7;
 695
 696     /* Assume the worst for an easy exit */
 697     ret_stat = -1;
 698     *volume = NULL;
 699     *vol_len = 0;
 700     *root = NULL;
 701     *root_len = 0;
 702     *dir = NULL;
 703     *dir_len;
 704     *name = NULL;
 705     *name_len = 0;
 706     *ext = NULL;
 707     *ext_len = 0;
 708     *version = NULL;
 709     *ver_len = 0;
 710
 711     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 712     path_desc.dsc$w_length = strlen(path);
 713     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 714     path_desc.dsc$b_class = DSC$K_CLASS_S;
 715
 716     /* Get the total length, if it is shorter than the string passed
 717      * then this was probably not a VMS formatted file specification
 718      */
 719     item_list[filespec].itmcode = FSCN$_FILESPEC;
 720     item_list[filespec].length = 0;
 721     item_list[filespec].component = NULL;
 722
 723     /* If the node is present, then it gets considered as part of the
 724      * volume name to hopefully make things simple.
 725      */
 726     item_list[nodespec].itmcode = FSCN$_NODE;
 727     item_list[nodespec].length = 0;
 728     item_list[nodespec].component = NULL;
 729
 730     item_list[devspec].itmcode = FSCN$_DEVICE;
 731     item_list[devspec].length = 0;
 732     item_list[devspec].component = NULL;
 733
 734     /* root is a special case,  adding it to either the directory or
 735      * the device components will probalby complicate things for the
 736      * callers of this routine, so leave it separate.
 737      */
 738     item_list[rootspec].itmcode = FSCN$_ROOT;
 739     item_list[rootspec].length = 0;
 740     item_list[rootspec].component = NULL;
 741
 742     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 743     item_list[dirspec].length = 0;
 744     item_list[dirspec].component = NULL;
 745
 746     item_list[namespec].itmcode = FSCN$_NAME;
 747     item_list[namespec].length = 0;
 748     item_list[namespec].component = NULL;
 749
 750     item_list[typespec].itmcode = FSCN$_TYPE;
 751     item_list[typespec].length = 0;
 752     item_list[typespec].component = NULL;
 753
 754     item_list[verspec].itmcode = FSCN$_VERSION;
 755     item_list[verspec].length = 0;
 756     item_list[verspec].component = NULL;
 757
 758     item_list[8].itmcode = 0;
 759     item_list[8].length = 0;
 760     item_list[8].component = NULL;
 761
 762     status = sys$filescan
 763        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 764         &flags, NULL, NULL);
 765     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 766
 767     /* If we parsed it successfully these two lengths should be the same */
 768     if (path_desc.dsc$w_length != item_list[filespec].length)
 769         return ret_stat;
 770
 771     /* If we got here, then it is a VMS file specification */
 772     ret_stat = 0;
 773
 774     /* set the volume name */
 775     if (item_list[nodespec].length > 0) {
 776         *volume = item_list[nodespec].component;
 777         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 778     }
 779     else {
 780         *volume = item_list[devspec].component;
 781         *vol_len = item_list[devspec].length;
 782     }
 783
 784     *root = item_list[rootspec].component;
 785     *root_len = item_list[rootspec].length;
 786
 787     *dir = item_list[dirspec].component;
 788     *dir_len = item_list[dirspec].length;
 789
 790     /* Now fun with versions and EFS file specifications
 791      * The parser can not tell the difference when a "." is a version
 792      * delimiter or a part of the file specification.
 793      */
 794     if ((decc_efs_charset) &&
 795         (item_list[verspec].length > 0) &&
 796         (item_list[verspec].component[0] == '.')) {
 797         *name = item_list[namespec].component;
 798         *name_len = item_list[namespec].length + item_list[typespec].length;
 799         *ext = item_list[verspec].component;
 800         *ext_len = item_list[verspec].length;
 801         *version = NULL;
 802         *ver_len = 0;
 803     }
 804     else {
 805         *name = item_list[namespec].component;
 806         *name_len = item_list[namespec].length;
 807         *ext = item_list[typespec].component;
 808         *ext_len = item_list[typespec].length;
 809         *version = item_list[verspec].component;
 810         *ver_len = item_list[verspec].length;
 811     }
 812     return ret_stat;
 813 }
 814
 815
 816 /* my_maxidx
 817  * Routine to retrieve the maximum equivalence index for an input
 818  * logical name.  Some calls to this routine have no knowledge if
 819  * the variable is a logical or not.  So on error we return a max
 820  * index of zero.
 821  */
 822 /*{{{int my_maxidx(const char *lnm) */
 823 static int
 824 my_maxidx(const char *lnm)
 825 {
 826     int status;
 827     int midx;
 828     int attr = LNM$M_CASE_BLIND;
 829     struct dsc$descriptor lnmdsc;
 830     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 831                                 {0, 0, 0, 0}};
 832
 833     lnmdsc.dsc$w_length = strlen(lnm);
 834     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 835     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 836     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 837
 838     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 839     if ((status & 1) == 0)
 840        midx = 0;
 841
 842     return (midx);
 843 }
 844 /*}}}*/
 845
 846 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 847 int
 848 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 849   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 850 {
 851     const char *cp1;
 852     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 853     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 854     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 855     int midx;
 856     unsigned char acmode;
 857     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 858                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 859     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 860                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 861                                  {0, 0, 0, 0}};
 862     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 863 #if defined(PERL_IMPLICIT_CONTEXT)
 864     pTHX = NULL;
 865     if (PL_curinterp) {
 866       aTHX = PERL_GET_INTERP;
 867     } else {
 868       aTHX = NULL;
 869     }
 870 #endif
 871
 872     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 873       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 874     }
 875     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 876       *cp2 = _toupper(*cp1);
 877       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 878         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 879         return 0;
 880       }
 881     }
 882     lnmdsc.dsc$w_length = cp1 - lnm;
 883     lnmdsc.dsc$a_pointer = uplnm;
 884     uplnm[lnmdsc.dsc$w_length] = '\0';
 885     secure = flags & PERL__TRNENV_SECURE;
 886     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 887     if (!tabvec || !*tabvec) tabvec = env_tables;
 888
 889     for (curtab = 0; tabvec[curtab]; curtab++) {
 890       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 891         if (!ivenv && !secure) {
 892           char *eq, *end;
 893           int i;
 894           if (!environ) {
 895             ivenv = 1;
 896             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 897             continue;
 898           }
 899           retsts = SS$_NOLOGNAM;
 900           for (i = 0; environ[i]; i++) {
 901             if ((eq = strchr(environ[i],'=')) &&
 902                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 903                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 904               eq++;
 905               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 906               if (!eqvlen) continue;
 907               retsts = SS$_NORMAL;
 908               break;
 909             }
 910           }
 911           if (retsts != SS$_NOLOGNAM) break;
 912         }
 913       }
 914       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 915                !str$case_blind_compare(&tmpdsc,&clisym)) {
 916         if (!ivsym && !secure) {
 917           unsigned short int deflen = LNM$C_NAMLENGTH;
 918           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 919           /* dynamic dsc to accomodate possible long value */
 920           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 921           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 922           if (retsts & 1) {
 923             if (eqvlen > MAX_DCL_SYMBOL) {
 924               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 925               eqvlen = MAX_DCL_SYMBOL;
 926               /* Special hack--we might be called before the interpreter's */
 927               /* fully initialized, in which case either thr or PL_curcop */
 928               /* might be bogus. We have to check, since ckWARN needs them */
 929               /* both to be valid if running threaded */
 930                 if (ckWARN(WARN_MISC)) {
 931                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 932                 }
 933             }
 934             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 935           }
 936           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 937           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 938           if (retsts == LIB$_NOSUCHSYM) continue;
 939           break;
 940         }
 941       }
 942       else if (!ivlnm) {
 943         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 944           midx = my_maxidx(lnm);
 945           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 946             lnmlst[1].bufadr = cp2;
 947             eqvlen = 0;
 948             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 949             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 950             if (retsts == SS$_NOLOGNAM) break;
 951             /* PPFs have a prefix */
 952             if (
 953 #if INTSIZE == 4
 954                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 955 #endif
 956                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 957                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 958                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 959                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 960                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 961               memmove(eqv,eqv+4,eqvlen-4);
 962               eqvlen -= 4;
 963             }
 964             cp2 += eqvlen;
 965             *cp2 = '\0';
 966           }
 967           if ((retsts == SS$_IVLOGNAM) ||
 968               (retsts == SS$_NOLOGNAM)) { continue; }
 969         }
 970         else {
 971           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 972           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 973           if (retsts == SS$_NOLOGNAM) continue;
 974           eqv[eqvlen] = '\0';
 975         }
 976         eqvlen = strlen(eqv);
 977         break;
 978       }
 979     }
 980     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 981     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 982              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 983              retsts == SS$_NOLOGNAM) {
 984       set_errno(EINVAL);  set_vaxc_errno(retsts);
 985     }
 986     else _ckvmssts(retsts);
 987     return 0;
 988 }  /* end of vmstrnenv */
 989 /*}}}*/
 990
 991 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 992 /* Define as a function so we can access statics. */
 993 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 994 {
 995   return vmstrnenv(lnm,eqv,idx,fildev,
 996 #ifdef SECURE_INTERNAL_GETENV
 997                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 998 #else
 999                    0
1000 #endif
1001                                                                               );
1002 }
1003 /*}}}*/
1004
1005 /* my_getenv
1006  * Note: Uses Perl temp to store result so char * can be returned to
1007  * caller; this pointer will be invalidated at next Perl statement
1008  * transition.
1009  * We define this as a function rather than a macro in terms of my_getenv_len()
1010  * so that it'll work when PL_curinterp is undefined (and we therefore can't
1011  * allocate SVs).
1012  */
1013 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1014 char *
1015 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1016 {
1017     const char *cp1;
1018     static char *__my_getenv_eqv = NULL;
1019     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1020     unsigned long int idx = 0;
1021     int trnsuccess, success, secure, saverr, savvmserr;
1022     int midx, flags;
1023     SV *tmpsv;
1024
1025     midx = my_maxidx(lnm) + 1;
1026
1027     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1028       /* Set up a temporary buffer for the return value; Perl will
1029        * clean it up at the next statement transition */
1030       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1031       if (!tmpsv) return NULL;
1032       eqv = SvPVX(tmpsv);
1033     }
1034     else {
1035       /* Assume no interpreter ==> single thread */
1036       if (__my_getenv_eqv != NULL) {
1037         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1038       }
1039       else {
1040         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1041       }
1042       eqv = __my_getenv_eqv;
1043     }
1044
1045     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1046     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1047       int len;
1048       getcwd(eqv,LNM$C_NAMLENGTH);
1049
1050       len = strlen(eqv);
1051
1052       /* Get rid of "000000/ in rooted filespecs */
1053       if (len > 7) {
1054         char * zeros;
1055         zeros = strstr(eqv, "/000000/");
1056         if (zeros != NULL) {
1057           int mlen;
1058           mlen = len - (zeros - eqv) - 7;
1059           memmove(zeros, &zeros[7], mlen);
1060           len = len - 7;
1061           eqv[len] = '\0';
1062         }
1063       }
1064       return eqv;
1065     }
1066     else {
1067       /* Impose security constraints only if tainting */
1068       if (sys) {
1069         /* Impose security constraints only if tainting */
1070         secure = PL_curinterp ? PL_tainting : will_taint;
1071         saverr = errno;  savvmserr = vaxc$errno;
1072       }
1073       else {
1074         secure = 0;
1075       }
1076
1077       flags =
1078 #ifdef SECURE_INTERNAL_GETENV
1079               secure ? PERL__TRNENV_SECURE : 0
1080 #else
1081               0
1082 #endif
1083       ;
1084
1085       /* For the getenv interface we combine all the equivalence names
1086        * of a search list logical into one value to acquire a maximum
1087        * value length of 255*128 (assuming %ENV is using logicals).
1088        */
1089       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1090
1091       /* If the name contains a semicolon-delimited index, parse it
1092        * off and make sure we only retrieve the equivalence name for
1093        * that index.  */
1094       if ((cp2 = strchr(lnm,';')) != NULL) {
1095         strcpy(uplnm,lnm);
1096         uplnm[cp2-lnm] = '\0';
1097         idx = strtoul(cp2+1,NULL,0);
1098         lnm = uplnm;
1099         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1100       }
1101
1102       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1103
1104       /* Discard NOLOGNAM on internal calls since we're often looking
1105        * for an optional name, and this "error" often shows up as the
1106        * (bogus) exit status for a die() call later on.  */
1107       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1108       return success ? eqv : Nullch;
1109     }
1110
1111 }  /* end of my_getenv() */
1112 /*}}}*/
1113
1114
1115 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1116 char *
1117 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1118 {
1119     const char *cp1;
1120     char *buf, *cp2;
1121     unsigned long idx = 0;
1122     int midx, flags;
1123     static char *__my_getenv_len_eqv = NULL;
1124     int secure, saverr, savvmserr;
1125     SV *tmpsv;
1126
1127     midx = my_maxidx(lnm) + 1;
1128
1129     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1130       /* Set up a temporary buffer for the return value; Perl will
1131        * clean it up at the next statement transition */
1132       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1133       if (!tmpsv) return NULL;
1134       buf = SvPVX(tmpsv);
1135     }
1136     else {
1137       /* Assume no interpreter ==> single thread */
1138       if (__my_getenv_len_eqv != NULL) {
1139         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1140       }
1141       else {
1142         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1143       }
1144       buf = __my_getenv_len_eqv;
1145     }
1146
1147     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1148     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1149     char * zeros;
1150
1151       getcwd(buf,LNM$C_NAMLENGTH);
1152       *len = strlen(buf);
1153
1154       /* Get rid of "000000/ in rooted filespecs */
1155       if (*len > 7) {
1156       zeros = strstr(buf, "/000000/");
1157       if (zeros != NULL) {
1158         int mlen;
1159         mlen = *len - (zeros - buf) - 7;
1160         memmove(zeros, &zeros[7], mlen);
1161         *len = *len - 7;
1162         buf[*len] = '\0';
1163         }
1164       }
1165       return buf;
1166     }
1167     else {
1168       if (sys) {
1169         /* Impose security constraints only if tainting */
1170         secure = PL_curinterp ? PL_tainting : will_taint;
1171         saverr = errno;  savvmserr = vaxc$errno;
1172       }
1173       else {
1174         secure = 0;
1175       }
1176
1177       flags =
1178 #ifdef SECURE_INTERNAL_GETENV
1179               secure ? PERL__TRNENV_SECURE : 0
1180 #else
1181               0
1182 #endif
1183       ;
1184
1185       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1186
1187       if ((cp2 = strchr(lnm,';')) != NULL) {
1188         strcpy(buf,lnm);
1189         buf[cp2-lnm] = '\0';
1190         idx = strtoul(cp2+1,NULL,0);
1191         lnm = buf;
1192         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1193       }
1194
1195       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1196
1197       /* Get rid of "000000/ in rooted filespecs */
1198       if (*len > 7) {
1199       char * zeros;
1200         zeros = strstr(buf, "/000000/");
1201         if (zeros != NULL) {
1202           int mlen;
1203           mlen = *len - (zeros - buf) - 7;
1204           memmove(zeros, &zeros[7], mlen);
1205           *len = *len - 7;
1206           buf[*len] = '\0';
1207         }
1208       }
1209
1210       /* Discard NOLOGNAM on internal calls since we're often looking
1211        * for an optional name, and this "error" often shows up as the
1212        * (bogus) exit status for a die() call later on.  */
1213       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1214       return *len ? buf : Nullch;
1215     }
1216
1217 }  /* end of my_getenv_len() */
1218 /*}}}*/
1219
1220 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1221
1222 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1223
1224 /*{{{ void prime_env_iter() */
1225 void
1226 prime_env_iter(void)
1227 /* Fill the %ENV associative array with all logical names we can
1228  * find, in preparation for iterating over it.
1229  */
1230 {
1231   static int primed = 0;
1232   HV *seenhv = NULL, *envhv;
1233   SV *sv = NULL;
1234   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1235   unsigned short int chan;
1236 #ifndef CLI$M_TRUSTED
1237 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1238 #endif
1239   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1240   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1241   long int i;
1242   bool have_sym = FALSE, have_lnm = FALSE;
1243   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1244   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1245   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1246   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1247   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1248 #if defined(PERL_IMPLICIT_CONTEXT)
1249   pTHX;
1250 #endif
1251 #if defined(USE_ITHREADS)
1252   static perl_mutex primenv_mutex;
1253   MUTEX_INIT(&primenv_mutex);
1254 #endif
1255
1256 #if defined(PERL_IMPLICIT_CONTEXT)
1257     /* We jump through these hoops because we can be called at */
1258     /* platform-specific initialization time, which is before anything is */
1259     /* set up--we can't even do a plain dTHX since that relies on the */
1260     /* interpreter structure to be initialized */
1261     if (PL_curinterp) {
1262       aTHX = PERL_GET_INTERP;
1263     } else {
1264       aTHX = NULL;
1265     }
1266 #endif
1267
1268   if (primed || !PL_envgv) return;
1269   MUTEX_LOCK(&primenv_mutex);
1270   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1271   envhv = GvHVn(PL_envgv);
1272   /* Perform a dummy fetch as an lval to insure that the hash table is
1273    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1274   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1275
1276   for (i = 0; env_tables[i]; i++) {
1277      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1278          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1279      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1280   }
1281   if (have_sym || have_lnm) {
1282     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1283     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1284     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1285     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1286   }
1287
1288   for (i--; i >= 0; i--) {
1289     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1290       char *start;
1291       int j;
1292       for (j = 0; environ[j]; j++) {
1293         if (!(start = strchr(environ[j],'='))) {
1294           if (ckWARN(WARN_INTERNAL))
1295             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1296         }
1297         else {
1298           start++;
1299           sv = newSVpv(start,0);
1300           SvTAINTED_on(sv);
1301           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1302         }
1303       }
1304       continue;
1305     }
1306     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1307              !str$case_blind_compare(&tmpdsc,&clisym)) {
1308       strcpy(cmd,"Show Symbol/Global *");
1309       cmddsc.dsc$w_length = 20;
1310       if (env_tables[i]->dsc$w_length == 12 &&
1311           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1312           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1313       flags = defflags | CLI$M_NOLOGNAM;
1314     }
1315     else {
1316       strcpy(cmd,"Show Logical *");
1317       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1318         strcat(cmd," /Table=");
1319         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1320         cmddsc.dsc$w_length = strlen(cmd);
1321       }
1322       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1323       flags = defflags | CLI$M_NOCLISYM;
1324     }
1325
1326     /* Create a new subprocess to execute each command, to exclude the
1327      * remote possibility that someone could subvert a mbx or file used
1328      * to write multiple commands to a single subprocess.
1329      */
1330     do {
1331       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1332                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1333       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1334       defflags &= ~CLI$M_TRUSTED;
1335     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1336     _ckvmssts(retsts);
1337     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1338     if (seenhv) SvREFCNT_dec(seenhv);
1339     seenhv = newHV();
1340     while (1) {
1341       char *cp1, *cp2, *key;
1342       unsigned long int sts, iosb[2], retlen, keylen;
1343       register U32 hash;
1344
1345       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1346       if (sts & 1) sts = iosb[0] & 0xffff;
1347       if (sts == SS$_ENDOFFILE) {
1348         int wakect = 0;
1349         while (substs == 0) { sys$hiber(); wakect++;}
1350         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1351         _ckvmssts(substs);
1352         break;
1353       }
1354       _ckvmssts(sts);
1355       retlen = iosb[0] >> 16;
1356       if (!retlen) continue;  /* blank line */
1357       buf[retlen] = '\0';
1358       if (iosb[1] != subpid) {
1359         if (iosb[1]) {
1360           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1361         }
1362         continue;
1363       }
1364       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1365         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1366
1367       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1368       if (*cp1 == '(' || /* Logical name table name */
1369           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1370       if (*cp1 == '"') cp1++;
1371       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1372       key = cp1;  keylen = cp2 - cp1;
1373       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1374       while (*cp2 && *cp2 != '=') cp2++;
1375       while (*cp2 && *cp2 == '=') cp2++;
1376       while (*cp2 && *cp2 == ' ') cp2++;
1377       if (*cp2 == '"') {  /* String translation; may embed "" */
1378         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1379         cp2++;  cp1--; /* Skip "" surrounding translation */
1380       }
1381       else {  /* Numeric translation */
1382         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1383         cp1--;  /* stop on last non-space char */
1384       }
1385       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1386         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1387         continue;
1388       }
1389       PERL_HASH(hash,key,keylen);
1390
1391       if (cp1 == cp2 && *cp2 == '.') {
1392         /* A single dot usually means an unprintable character, such as a null
1393          * to indicate a zero-length value.  Get the actual value to make sure.
1394          */
1395         char lnm[LNM$C_NAMLENGTH+1];
1396         char eqv[MAX_DCL_SYMBOL+1];
1397         int trnlen;
1398         strncpy(lnm, key, keylen);
1399         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1400         sv = newSVpvn(eqv, strlen(eqv));
1401       }
1402       else {
1403         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1404       }
1405
1406       SvTAINTED_on(sv);
1407       hv_store(envhv,key,keylen,sv,hash);
1408       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1409     }
1410     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1411       /* get the PPFs for this process, not the subprocess */
1412       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1413       char eqv[LNM$C_NAMLENGTH+1];
1414       int trnlen, i;
1415       for (i = 0; ppfs[i]; i++) {
1416         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1417         sv = newSVpv(eqv,trnlen);
1418         SvTAINTED_on(sv);
1419         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1420       }
1421     }
1422   }
1423   primed = 1;
1424   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1425   if (buf) Safefree(buf);
1426   if (seenhv) SvREFCNT_dec(seenhv);
1427   MUTEX_UNLOCK(&primenv_mutex);
1428   return;
1429
1430 }  /* end of prime_env_iter */
1431 /*}}}*/
1432
1433
1434 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1435 /* Define or delete an element in the same "environment" as
1436  * vmstrnenv().  If an element is to be deleted, it's removed from
1437  * the first place it's found.  If it's to be set, it's set in the
1438  * place designated by the first element of the table vector.
1439  * Like setenv() returns 0 for success, non-zero on error.
1440  */
1441 int
1442 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1443 {
1444     const char *cp1;
1445     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1446     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1447     int nseg = 0, j;
1448     unsigned long int retsts, usermode = PSL$C_USER;
1449     struct itmlst_3 *ile, *ilist;
1450     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1451                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1452                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1453     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1454     $DESCRIPTOR(local,"_LOCAL");
1455
1456     if (!lnm) {
1457         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1458         return SS$_IVLOGNAM;
1459     }
1460
1461     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1462       *cp2 = _toupper(*cp1);
1463       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1464         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1465         return SS$_IVLOGNAM;
1466       }
1467     }
1468     lnmdsc.dsc$w_length = cp1 - lnm;
1469     if (!tabvec || !*tabvec) tabvec = env_tables;
1470
1471     if (!eqv) {  /* we're deleting n element */
1472       for (curtab = 0; tabvec[curtab]; curtab++) {
1473         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1474         int i;
1475           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1476             if ((cp1 = strchr(environ[i],'=')) &&
1477                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1478                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1479 #ifdef HAS_SETENV
1480               return setenv(lnm,"",1) ? vaxc$errno : 0;
1481             }
1482           }
1483           ivenv = 1; retsts = SS$_NOLOGNAM;
1484 #else
1485               if (ckWARN(WARN_INTERNAL))
1486                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1487               ivenv = 1; retsts = SS$_NOSUCHPGM;
1488               break;
1489             }
1490           }
1491 #endif
1492         }
1493         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1494                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1495           unsigned int symtype;
1496           if (tabvec[curtab]->dsc$w_length == 12 &&
1497               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1498               !str$case_blind_compare(&tmpdsc,&local))
1499             symtype = LIB$K_CLI_LOCAL_SYM;
1500           else symtype = LIB$K_CLI_GLOBAL_SYM;
1501           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1502           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1503           if (retsts == LIB$_NOSUCHSYM) continue;
1504           break;
1505         }
1506         else if (!ivlnm) {
1507           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1508           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1509           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1510           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1511           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1512         }
1513       }
1514     }
1515     else {  /* we're defining a value */
1516       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1517 #ifdef HAS_SETENV
1518         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1519 #else
1520         if (ckWARN(WARN_INTERNAL))
1521           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1522         retsts = SS$_NOSUCHPGM;
1523 #endif
1524       }
1525       else {
1526         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1527         eqvdsc.dsc$w_length  = strlen(eqv);
1528         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1529             !str$case_blind_compare(&tmpdsc,&clisym)) {
1530           unsigned int symtype;
1531           if (tabvec[0]->dsc$w_length == 12 &&
1532               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1533                !str$case_blind_compare(&tmpdsc,&local))
1534             symtype = LIB$K_CLI_LOCAL_SYM;
1535           else symtype = LIB$K_CLI_GLOBAL_SYM;
1536           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1537         }
1538         else {
1539           if (!*eqv) eqvdsc.dsc$w_length = 1;
1540           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1541
1542             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1543             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1544               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1545                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1546               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1547               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1548             }
1549
1550             Newx(ilist,nseg+1,struct itmlst_3);
1551             ile = ilist;
1552             if (!ile) {
1553               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1554               return SS$_INSFMEM;
1555             }
1556             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1557
1558             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1559               ile->itmcode = LNM$_STRING;
1560               ile->bufadr = c;
1561               if ((j+1) == nseg) {
1562                 ile->buflen = strlen(c);
1563                 /* in case we are truncating one that's too long */
1564                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1565               }
1566               else {
1567                 ile->buflen = LNM$C_NAMLENGTH;
1568               }
1569             }
1570
1571             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1572             Safefree (ilist);
1573           }
1574           else {
1575             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1576           }
1577         }
1578       }
1579     }
1580     if (!(retsts & 1)) {
1581       switch (retsts) {
1582         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1583         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1584           set_errno(EVMSERR); break;
1585         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1586         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1587           set_errno(EINVAL); break;
1588         case SS$_NOPRIV:
1589           set_errno(EACCES); break;
1590         default:
1591           _ckvmssts(retsts);
1592           set_errno(EVMSERR);
1593        }
1594        set_vaxc_errno(retsts);
1595        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1596     }
1597     else {
1598       /* We reset error values on success because Perl does an hv_fetch()
1599        * before each hv_store(), and if the thing we're setting didn't
1600        * previously exist, we've got a leftover error message.  (Of course,
1601        * this fails in the face of
1602        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1603        * in that the error reported in $! isn't spurious,
1604        * but it's right more often than not.)
1605        */
1606       set_errno(0); set_vaxc_errno(retsts);
1607       return 0;
1608     }
1609
1610 }  /* end of vmssetenv() */
1611 /*}}}*/
1612
1613 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1614 /* This has to be a function since there's a prototype for it in proto.h */
1615 void
1616 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1617 {
1618     if (lnm && *lnm) {
1619       int len = strlen(lnm);
1620       if  (len == 7) {
1621         char uplnm[8];
1622         int i;
1623         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1624         if (!strcmp(uplnm,"DEFAULT")) {
1625           if (eqv && *eqv) my_chdir(eqv);
1626           return;
1627         }
1628     }
1629 #ifndef RTL_USES_UTC
1630     if (len == 6 || len == 2) {
1631       char uplnm[7];
1632       int i;
1633       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1634       uplnm[len] = '\0';
1635       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1636       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1637     }
1638 #endif
1639   }
1640   (void) vmssetenv(lnm,eqv,NULL);
1641 }
1642 /*}}}*/
1643
1644 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1645 /*  vmssetuserlnm
1646  *  sets a user-mode logical in the process logical name table
1647  *  used for redirection of sys$error
1648  */
1649 void
1650 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1651 {
1652     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1653     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1654     unsigned long int iss, attr = LNM$M_CONFINE;
1655     unsigned char acmode = PSL$C_USER;
1656     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1657                                  {0, 0, 0, 0}};
1658     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1659     d_name.dsc$w_length = strlen(name);
1660
1661     lnmlst[0].buflen = strlen(eqv);
1662     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1663
1664     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1665     if (!(iss&1)) lib$signal(iss);
1666 }
1667 /*}}}*/
1668
1669
1670 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1671 /* my_crypt - VMS password hashing
1672  * my_crypt() provides an interface compatible with the Unix crypt()
1673  * C library function, and uses sys$hash_password() to perform VMS
1674  * password hashing.  The quadword hashed password value is returned
1675  * as a NUL-terminated 8 character string.  my_crypt() does not change
1676  * the case of its string arguments; in order to match the behavior
1677  * of LOGINOUT et al., alphabetic characters in both arguments must
1678  *  be upcased by the caller.
1679  *
1680  * - fix me to call ACM services when available
1681  */
1682 char *
1683 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1684 {
1685 #   ifndef UAI$C_PREFERRED_ALGORITHM
1686 #     define UAI$C_PREFERRED_ALGORITHM 127
1687 #   endif
1688     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1689     unsigned short int salt = 0;
1690     unsigned long int sts;
1691     struct const_dsc {
1692         unsigned short int dsc$w_length;
1693         unsigned char      dsc$b_type;
1694         unsigned char      dsc$b_class;
1695         const char *       dsc$a_pointer;
1696     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1697        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1698     struct itmlst_3 uailst[3] = {
1699         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1700         { sizeof salt, UAI$_SALT,    &salt, 0},
1701         { 0,           0,            NULL,  NULL}};
1702     static char hash[9];
1703
1704     usrdsc.dsc$w_length = strlen(usrname);
1705     usrdsc.dsc$a_pointer = usrname;
1706     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1707       switch (sts) {
1708         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1709           set_errno(EACCES);
1710           break;
1711         case RMS$_RNF:
1712           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1713           break;
1714         default:
1715           set_errno(EVMSERR);
1716       }
1717       set_vaxc_errno(sts);
1718       if (sts != RMS$_RNF) return NULL;
1719     }
1720
1721     txtdsc.dsc$w_length = strlen(textpasswd);
1722     txtdsc.dsc$a_pointer = textpasswd;
1723     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1724       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1725     }
1726
1727     return (char *) hash;
1728
1729 }  /* end of my_crypt() */
1730 /*}}}*/
1731
1732
1733 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1734 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1735 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1736
1737 /* fixup barenames that are directories for internal use.
1738  * There have been problems with the consistent handling of UNIX
1739  * style directory names when routines are presented with a name that
1740  * has no directory delimitors at all.  So this routine will eventually
1741  * fix the issue.
1742  */
1743 static char * fixup_bare_dirnames(const char * name)
1744 {
1745   if (decc_disable_to_vms_logname_translation) {
1746 /* fix me */
1747   }
1748   return NULL;
1749 }
1750
1751 /* mp_do_kill_file
1752  * A little hack to get around a bug in some implemenation of remove()
1753  * that do not know how to delete a directory
1754  *
1755  * Delete any file to which user has control access, regardless of whether
1756  * delete access is explicitly allowed.
1757  * Limitations: User must have write access to parent directory.
1758  *              Does not block signals or ASTs; if interrupted in midstream
1759  *              may leave file with an altered ACL.
1760  * HANDLE WITH CARE!
1761  */
1762 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1763 static int
1764 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1765 {
1766     char *vmsname, *rspec;
1767     char *remove_name;
1768     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1769     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1770     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1771     struct myacedef {
1772       unsigned char myace$b_length;
1773       unsigned char myace$b_type;
1774       unsigned short int myace$w_flags;
1775       unsigned long int myace$l_access;
1776       unsigned long int myace$l_ident;
1777     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1778                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1779       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1780      struct itmlst_3
1781        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1782                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1783        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1784        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1785        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1786        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1787
1788     /* Expand the input spec using RMS, since the CRTL remove() and
1789      * system services won't do this by themselves, so we may miss
1790      * a file "hiding" behind a logical name or search list. */
1791     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1792     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1793
1794     if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1795       PerlMem_free(vmsname);
1796       return -1;
1797     }
1798
1799     if (decc_posix_compliant_pathnames) {
1800       /* In POSIX mode, we prefer to remove the UNIX name */
1801       rspec = vmsname;
1802       remove_name = (char *)name;
1803     }
1804     else {
1805       rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1806       if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1807       if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1808         PerlMem_free(rspec);
1809         PerlMem_free(vmsname);
1810         return -1;
1811       }
1812       PerlMem_free(vmsname);
1813       remove_name = rspec;
1814     }
1815
1816 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1817     if (dirflag != 0) {
1818         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1819           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1820           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1821
1822           do_pathify_dirspec(name, remove_name, 0, NULL);
1823           if (!rmdir(remove_name)) {
1824
1825             PerlMem_free(remove_name);
1826             PerlMem_free(rspec);
1827             return 0;   /* Can we just get rid of it? */
1828           }
1829         }
1830         else {
1831           if (!rmdir(remove_name)) {
1832             PerlMem_free(rspec);
1833             return 0;   /* Can we just get rid of it? */
1834           }
1835         }
1836     }
1837     else
1838 #endif
1839       if (!remove(remove_name)) {
1840         PerlMem_free(rspec);
1841         return 0;   /* Can we just get rid of it? */
1842       }
1843
1844     /* If not, can changing protections help? */
1845     if (vaxc$errno != RMS$_PRV) {
1846       PerlMem_free(rspec);
1847       return -1;
1848     }
1849
1850     /* No, so we get our own UIC to use as a rights identifier,
1851      * and the insert an ACE at the head of the ACL which allows us
1852      * to delete the file.
1853      */
1854     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1855     fildsc.dsc$w_length = strlen(rspec);
1856     fildsc.dsc$a_pointer = rspec;
1857     cxt = 0;
1858     newace.myace$l_ident = oldace.myace$l_ident;
1859     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1860       switch (aclsts) {
1861         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1862           set_errno(ENOENT); break;
1863         case RMS$_DIR:
1864           set_errno(ENOTDIR); break;
1865         case RMS$_DEV:
1866           set_errno(ENODEV); break;
1867         case RMS$_SYN: case SS$_INVFILFOROP:
1868           set_errno(EINVAL); break;
1869         case RMS$_PRV:
1870           set_errno(EACCES); break;
1871         default:
1872           _ckvmssts(aclsts);
1873       }
1874       set_vaxc_errno(aclsts);
1875       PerlMem_free(rspec);
1876       return -1;
1877     }
1878     /* Grab any existing ACEs with this identifier in case we fail */
1879     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1880     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1881                     || fndsts == SS$_NOMOREACE ) {
1882       /* Add the new ACE . . . */
1883       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1884         goto yourroom;
1885
1886 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1887       if (dirflag != 0)
1888         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1889           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1890           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1891
1892           do_pathify_dirspec(name, remove_name, 0, NULL);
1893           rmsts = rmdir(remove_name);
1894           PerlMem_free(remove_name);
1895         }
1896         else {
1897         rmsts = rmdir(remove_name);
1898         }
1899       else
1900 #endif
1901         rmsts = remove(remove_name);
1902       if (rmsts) {
1903         /* We blew it - dir with files in it, no write priv for
1904          * parent directory, etc.  Put things back the way they were. */
1905         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1906           goto yourroom;
1907         if (fndsts & 1) {
1908           addlst[0].bufadr = &oldace;
1909           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1910             goto yourroom;
1911         }
1912       }
1913     }
1914
1915     yourroom:
1916     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1917     /* We just deleted it, so of course it's not there.  Some versions of
1918      * VMS seem to return success on the unlock operation anyhow (after all
1919      * the unlock is successful), but others don't.
1920      */
1921     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1922     if (aclsts & 1) aclsts = fndsts;
1923     if (!(aclsts & 1)) {
1924       set_errno(EVMSERR);
1925       set_vaxc_errno(aclsts);
1926       PerlMem_free(rspec);
1927       return -1;
1928     }
1929
1930     PerlMem_free(rspec);
1931     return rmsts;
1932
1933 }  /* end of kill_file() */
1934 /*}}}*/
1935
1936
1937 /*{{{int do_rmdir(char *name)*/
1938 int
1939 Perl_do_rmdir(pTHX_ const char *name)
1940 {
1941     char dirfile[NAM$C_MAXRSS+1];
1942     int retval;
1943     Stat_t st;
1944
1945     if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1946     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1947     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1948     return retval;
1949
1950 }  /* end of do_rmdir */
1951 /*}}}*/
1952
1953 /* kill_file
1954  * Delete any file to which user has control access, regardless of whether
1955  * delete access is explicitly allowed.
1956  * Limitations: User must have write access to parent directory.
1957  *              Does not block signals or ASTs; if interrupted in midstream
1958  *              may leave file with an altered ACL.
1959  * HANDLE WITH CARE!
1960  */
1961 /*{{{int kill_file(char *name)*/
1962 int
1963 Perl_kill_file(pTHX_ const char *name)
1964 {
1965     char rspec[NAM$C_MAXRSS+1];
1966     char *tspec;
1967     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1968     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1969     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1970     struct myacedef {
1971       unsigned char myace$b_length;
1972       unsigned char myace$b_type;
1973       unsigned short int myace$w_flags;
1974       unsigned long int myace$l_access;
1975       unsigned long int myace$l_ident;
1976     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1977                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1978       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1979      struct itmlst_3
1980        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1981                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1982        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1983        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1984        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1985        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1986
1987     /* Expand the input spec using RMS, since the CRTL remove() and
1988      * system services won't do this by themselves, so we may miss
1989      * a file "hiding" behind a logical name or search list. */
1990     tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1991     if (tspec == NULL) return -1;
1992     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1993     /* If not, can changing protections help? */
1994     if (vaxc$errno != RMS$_PRV) return -1;
1995
1996     /* No, so we get our own UIC to use as a rights identifier,
1997      * and the insert an ACE at the head of the ACL which allows us
1998      * to delete the file.
1999      */
2000     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
2001     fildsc.dsc$w_length = strlen(rspec);
2002     fildsc.dsc$a_pointer = rspec;
2003     cxt = 0;
2004     newace.myace$l_ident = oldace.myace$l_ident;
2005     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
2006       switch (aclsts) {
2007         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
2008           set_errno(ENOENT); break;
2009         case RMS$_DIR:
2010           set_errno(ENOTDIR); break;
2011         case RMS$_DEV:
2012           set_errno(ENODEV); break;
2013         case RMS$_SYN: case SS$_INVFILFOROP:
2014           set_errno(EINVAL); break;
2015         case RMS$_PRV:
2016           set_errno(EACCES); break;
2017         default:
2018           _ckvmssts(aclsts);
2019       }
2020       set_vaxc_errno(aclsts);
2021       return -1;
2022     }
2023     /* Grab any existing ACEs with this identifier in case we fail */
2024     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2025     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2026                     || fndsts == SS$_NOMOREACE ) {
2027       /* Add the new ACE . . . */
2028       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2029         goto yourroom;
2030       if ((rmsts = remove(name))) {
2031         /* We blew it - dir with files in it, no write priv for
2032          * parent directory, etc.  Put things back the way they were. */
2033         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2034           goto yourroom;
2035         if (fndsts & 1) {
2036           addlst[0].bufadr = &oldace;
2037           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2038             goto yourroom;
2039         }
2040       }
2041     }
2042
2043     yourroom:
2044     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2045     /* We just deleted it, so of course it's not there.  Some versions of
2046      * VMS seem to return success on the unlock operation anyhow (after all
2047      * the unlock is successful), but others don't.
2048      */
2049     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2050     if (aclsts & 1) aclsts = fndsts;
2051     if (!(aclsts & 1)) {
2052       set_errno(EVMSERR);
2053       set_vaxc_errno(aclsts);
2054       return -1;
2055     }
2056
2057     return rmsts;
2058
2059 }  /* end of kill_file() */
2060 /*}}}*/
2061
2062
2063 /*{{{int my_mkdir(char *,Mode_t)*/
2064 int
2065 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2066 {
2067   STRLEN dirlen = strlen(dir);
2068
2069   /* zero length string sometimes gives ACCVIO */
2070   if (dirlen == 0) return -1;
2071
2072   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2073    * null file name/type.  However, it's commonplace under Unix,
2074    * so we'll allow it for a gain in portability.
2075    */
2076   if (dir[dirlen-1] == '/') {
2077     char *newdir = savepvn(dir,dirlen-1);
2078     int ret = mkdir(newdir,mode);
2079     Safefree(newdir);
2080     return ret;
2081   }
2082   else return mkdir(dir,mode);
2083 }  /* end of my_mkdir */
2084 /*}}}*/
2085
2086 /*{{{int my_chdir(char *)*/
2087 int
2088 Perl_my_chdir(pTHX_ const char *dir)
2089 {
2090   STRLEN dirlen = strlen(dir);
2091
2092   /* zero length string sometimes gives ACCVIO */
2093   if (dirlen == 0) return -1;
2094   const char *dir1;
2095
2096   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2097    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2098    * so that existing scripts do not need to be changed.
2099    */
2100   dir1 = dir;
2101   while ((dirlen > 0) && (*dir1 == ' ')) {
2102     dir1++;
2103     dirlen--;
2104   }
2105
2106   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2107    * that implies
2108    * null file name/type.  However, it's commonplace under Unix,
2109    * so we'll allow it for a gain in portability.
2110    *
2111    * - Preview- '/' will be valid soon on VMS
2112    */
2113   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2114     char *newdir = savepvn(dir1,dirlen-1);
2115     int ret = chdir(newdir);
2116     Safefree(newdir);
2117     return ret;
2118   }
2119   else return chdir(dir1);
2120 }  /* end of my_chdir */
2121 /*}}}*/
2122
2123
2124 /*{{{FILE *my_tmpfile()*/
2125 FILE *
2126 my_tmpfile(void)
2127 {
2128   FILE *fp;
2129   char *cp;
2130
2131   if ((fp = tmpfile())) return fp;
2132
2133   cp = PerlMem_malloc(L_tmpnam+24);
2134   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2135
2136   if (decc_filename_unix_only == 0)
2137     strcpy(cp,"Sys$Scratch:");
2138   else
2139     strcpy(cp,"/tmp/");
2140   tmpnam(cp+strlen(cp));
2141   strcat(cp,".Perltmp");
2142   fp = fopen(cp,"w+","fop=dlt");
2143   PerlMem_free(cp);
2144   return fp;
2145 }
2146 /*}}}*/
2147
2148
2149 #ifndef HOMEGROWN_POSIX_SIGNALS
2150 /*
2151  * The C RTL's sigaction fails to check for invalid signal numbers so we
2152  * help it out a bit.  The docs are correct, but the actual routine doesn't
2153  * do what the docs say it will.
2154  */
2155 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2156 int
2157 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2158                    struct sigaction* oact)
2159 {
2160   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2161         SETERRNO(EINVAL, SS$_INVARG);
2162         return -1;
2163   }
2164   return sigaction(sig, act, oact);
2165 }
2166 /*}}}*/
2167 #endif
2168
2169 #ifdef KILL_BY_SIGPRC
2170 #include <errnodef.h>
2171
2172 /* We implement our own kill() using the undocumented system service
2173    sys$sigprc for one of two reasons:
2174
2175    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2176    target process to do a sys$exit, which usually can't be handled
2177    gracefully...certainly not by Perl and the %SIG{} mechanism.
2178
2179    2.) If the kill() in the CRTL can't be called from a signal
2180    handler without disappearing into the ether, i.e., the signal
2181    it purportedly sends is never trapped. Still true as of VMS 7.3.
2182
2183    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2184    in the target process rather than calling sys$exit.
2185
2186    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2187    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2188    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2189    with condition codes C$_SIG0+nsig*8, catching the exception on the
2190    target process and resignaling with appropriate arguments.
2191
2192    But we don't have that VMS 7.0+ exception handler, so if you
2193    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2194
2195    Also note that SIGTERM is listed in the docs as being "unimplemented",
2196    yet always seems to be signaled with a VMS condition code of 4 (and
2197    correctly handled for that code).  So we hardwire it in.
2198
2199    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2200    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2201    than signalling with an unrecognized (and unhandled by CRTL) code.
2202 */
2203
2204 #define _MY_SIG_MAX 28
2205
2206 static unsigned int
2207 Perl_sig_to_vmscondition_int(int sig)
2208 {
2209     static unsigned int sig_code[_MY_SIG_MAX+1] =
2210     {
2211         0,                  /*  0 ZERO     */
2212         SS$_HANGUP,         /*  1 SIGHUP   */
2213         SS$_CONTROLC,       /*  2 SIGINT   */
2214         SS$_CONTROLY,       /*  3 SIGQUIT  */
2215         SS$_RADRMOD,        /*  4 SIGILL   */
2216         SS$_BREAK,          /*  5 SIGTRAP  */
2217         SS$_OPCCUS,         /*  6 SIGABRT  */
2218         SS$_COMPAT,         /*  7 SIGEMT   */
2219 #ifdef __VAX
2220         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2221 #else
2222         SS$_HPARITH,        /*  8 SIGFPE AXP */
2223 #endif
2224         SS$_ABORT,          /*  9 SIGKILL  */
2225         SS$_ACCVIO,         /* 10 SIGBUS   */
2226         SS$_ACCVIO,         /* 11 SIGSEGV  */
2227         SS$_BADPARAM,       /* 12 SIGSYS   */
2228         SS$_NOMBX,          /* 13 SIGPIPE  */
2229         SS$_ASTFLT,         /* 14 SIGALRM  */
2230         4,                  /* 15 SIGTERM  */
2231         0,                  /* 16 SIGUSR1  */
2232         0,                  /* 17 SIGUSR2  */
2233         0,                  /* 18 */
2234         0,                  /* 19 */
2235         0,                  /* 20 SIGCHLD  */
2236         0,                  /* 21 SIGCONT  */
2237         0,                  /* 22 SIGSTOP  */
2238         0,                  /* 23 SIGTSTP  */
2239         0,                  /* 24 SIGTTIN  */
2240         0,                  /* 25 SIGTTOU  */
2241         0,                  /* 26 */
2242         0,                  /* 27 */
2243         0                   /* 28 SIGWINCH  */
2244     };
2245
2246 #if __VMS_VER >= 60200000
2247     static int initted = 0;
2248     if (!initted) {
2249         initted = 1;
2250         sig_code[16] = C$_SIGUSR1;
2251         sig_code[17] = C$_SIGUSR2;
2252 #if __CRTL_VER >= 70000000
2253         sig_code[20] = C$_SIGCHLD;
2254 #endif
2255 #if __CRTL_VER >= 70300000
2256         sig_code[28] = C$_SIGWINCH;
2257 #endif
2258     }
2259 #endif
2260
2261     if (sig < _SIG_MIN) return 0;
2262     if (sig > _MY_SIG_MAX) return 0;
2263     return sig_code[sig];
2264 }
2265
2266 unsigned int
2267 Perl_sig_to_vmscondition(int sig)
2268 {
2269 #ifdef SS$_DEBUG
2270     if (vms_debug_on_exception != 0)
2271         lib$signal(SS$_DEBUG);
2272 #endif
2273     return Perl_sig_to_vmscondition_int(sig);
2274 }
2275
2276
2277 int
2278 Perl_my_kill(int pid, int sig)
2279 {
2280     dTHX;
2281     int iss;
2282     unsigned int code;
2283     int sys$sigprc(unsigned int *pidadr,
2284                      struct dsc$descriptor_s *prcname,
2285                      unsigned int code);
2286
2287      /* sig 0 means validate the PID */
2288     /*------------------------------*/
2289     if (sig == 0) {
2290         const unsigned long int jpicode = JPI$_PID;
2291         pid_t ret_pid;
2292         int status;
2293         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2294         if ($VMS_STATUS_SUCCESS(status))
2295            return 0;
2296         switch (status) {
2297         case SS$_NOSUCHNODE:
2298         case SS$_UNREACHABLE:
2299         case SS$_NONEXPR:
2300            errno = ESRCH;
2301            break;
2302         case SS$_NOPRIV:
2303            errno = EPERM;
2304            break;
2305         default:
2306            errno = EVMSERR;
2307         }
2308         vaxc$errno=status;
2309         return -1;
2310     }
2311
2312     code = Perl_sig_to_vmscondition_int(sig);
2313
2314     if (!code) {
2315         SETERRNO(EINVAL, SS$_BADPARAM);
2316         return -1;
2317     }
2318
2319     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2320      * signals are to be sent to multiple processes.
2321      *  pid = 0 - all processes in group except ones that the system exempts
2322      *  pid = -1 - all processes except ones that the system exempts
2323      *  pid = -n - all processes in group (abs(n)) except ...
2324      * For now, just report as not supported.
2325      */
2326
2327     if (pid <= 0) {
2328         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2329         return -1;
2330     }
2331
2332     iss = sys$sigprc((unsigned int *)&pid,0,code);
2333     if (iss&1) return 0;
2334
2335     switch (iss) {
2336       case SS$_NOPRIV:
2337         set_errno(EPERM);  break;
2338       case SS$_NONEXPR:
2339       case SS$_NOSUCHNODE:
2340       case SS$_UNREACHABLE:
2341         set_errno(ESRCH);  break;
2342       case SS$_INSFMEM:
2343         set_errno(ENOMEM); break;
2344       default:
2345         _ckvmssts(iss);
2346         set_errno(EVMSERR);
2347     }
2348     set_vaxc_errno(iss);
2349
2350     return -1;
2351 }
2352 #endif
2353
2354 /* Routine to convert a VMS status code to a UNIX status code.
2355 ** More tricky than it appears because of conflicting conventions with
2356 ** existing code.
2357 **
2358 ** VMS status codes are a bit mask, with the least significant bit set for
2359 ** success.
2360 **
2361 ** Special UNIX status of EVMSERR indicates that no translation is currently
2362 ** available, and programs should check the VMS status code.
2363 **
2364 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2365 ** decoding.
2366 */
2367
2368 #ifndef C_FACILITY_NO
2369 #define C_FACILITY_NO 0x350000
2370 #endif
2371 #ifndef DCL_IVVERB
2372 #define DCL_IVVERB 0x38090
2373 #endif
2374
2375 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2376 {
2377 int facility;
2378 int fac_sp;
2379 int msg_no;
2380 int msg_status;
2381 int unix_status;
2382
2383   /* Assume the best or the worst */
2384   if (vms_status & STS$M_SUCCESS)
2385     unix_status = 0;
2386   else
2387     unix_status = EVMSERR;
2388
2389   msg_status = vms_status & ~STS$M_CONTROL;
2390
2391   facility = vms_status & STS$M_FAC_NO;
2392   fac_sp = vms_status & STS$M_FAC_SP;
2393   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2394
2395   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2396     switch(msg_no) {
2397     case SS$_NORMAL:
2398         unix_status = 0;
2399         break;
2400     case SS$_ACCVIO:
2401         unix_status = EFAULT;
2402         break;
2403     case SS$_DEVOFFLINE:
2404         unix_status = EBUSY;
2405         break;
2406     case SS$_CLEARED:
2407         unix_status = ENOTCONN;
2408         break;
2409     case SS$_IVCHAN:
2410     case SS$_IVLOGNAM:
2411     case SS$_BADPARAM:
2412     case SS$_IVLOGTAB:
2413     case SS$_NOLOGNAM:
2414     case SS$_NOLOGTAB:
2415     case SS$_INVFILFOROP:
2416     case SS$_INVARG:
2417     case SS$_NOSUCHID:
2418     case SS$_IVIDENT:
2419         unix_status = EINVAL;
2420         break;
2421     case SS$_UNSUPPORTED:
2422         unix_status = ENOTSUP;
2423         break;
2424     case SS$_FILACCERR:
2425     case SS$_NOGRPPRV:
2426     case SS$_NOSYSPRV:
2427         unix_status = EACCES;
2428         break;
2429     case SS$_DEVICEFULL:
2430         unix_status = ENOSPC;
2431         break;
2432     case SS$_NOSUCHDEV:
2433         unix_status = ENODEV;
2434         break;
2435     case SS$_NOSUCHFILE:
2436     case SS$_NOSUCHOBJECT:
2437         unix_status = ENOENT;
2438         break;
2439     case SS$_ABORT:                                 /* Fatal case */
2440     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2441     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2442         unix_status = EINTR;
2443         break;
2444     case SS$_BUFFEROVF:
2445         unix_status = E2BIG;
2446         break;
2447     case SS$_INSFMEM:
2448         unix_status = ENOMEM;
2449         break;
2450     case SS$_NOPRIV:
2451         unix_status = EPERM;
2452         break;
2453     case SS$_NOSUCHNODE:
2454     case SS$_UNREACHABLE:
2455         unix_status = ESRCH;
2456         break;
2457     case SS$_NONEXPR:
2458         unix_status = ECHILD;
2459         break;
2460     default:
2461         if ((facility == 0) && (msg_no < 8)) {
2462           /* These are not real VMS status codes so assume that they are
2463           ** already UNIX status codes
2464           */
2465           unix_status = msg_no;
2466           break;
2467         }
2468     }
2469   }
2470   else {
2471     /* Translate a POSIX exit code to a UNIX exit code */
2472     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2473         unix_status = (msg_no & 0x07F8) >> 3;
2474     }
2475     else {
2476
2477          /* Documented traditional behavior for handling VMS child exits */
2478         /*--------------------------------------------------------------*/
2479         if (child_flag != 0) {
2480
2481              /* Success / Informational return 0 */
2482             /*----------------------------------*/
2483             if (msg_no & STS$K_SUCCESS)
2484                 return 0;
2485
2486              /* Warning returns 1 */
2487             /*-------------------*/
2488             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2489                 return 1;
2490
2491              /* Everything else pass through the severity bits */
2492             /*------------------------------------------------*/
2493             return (msg_no & STS$M_SEVERITY);
2494         }
2495
2496          /* Normal VMS status to ERRNO mapping attempt */
2497         /*--------------------------------------------*/
2498         switch(msg_status) {
2499         /* case RMS$_EOF: */ /* End of File */
2500         case RMS$_FNF:  /* File Not Found */
2501         case RMS$_DNF:  /* Dir Not Found */
2502                 unix_status = ENOENT;
2503                 break;
2504         case RMS$_RNF:  /* Record Not Found */
2505                 unix_status = ESRCH;
2506                 break;
2507         case RMS$_DIR:
2508                 unix_status = ENOTDIR;
2509                 break;
2510         case RMS$_DEV:
2511                 unix_status = ENODEV;
2512                 break;
2513         case RMS$_IFI:
2514         case RMS$_FAC:
2515         case RMS$_ISI:
2516                 unix_status = EBADF;
2517                 break;
2518         case RMS$_FEX:
2519                 unix_status = EEXIST;
2520                 break;
2521         case RMS$_SYN:
2522         case RMS$_FNM:
2523         case LIB$_INVSTRDES:
2524         case LIB$_INVARG:
2525         case LIB$_NOSUCHSYM:
2526         case LIB$_INVSYMNAM:
2527         case DCL_IVVERB:
2528                 unix_status = EINVAL;
2529                 break;
2530         case CLI$_BUFOVF:
2531         case RMS$_RTB:
2532         case CLI$_TKNOVF:
2533         case CLI$_RSLOVF:
2534                 unix_status = E2BIG;
2535                 break;
2536         case RMS$_PRV:  /* No privilege */
2537         case RMS$_ACC:  /* ACP file access failed */
2538         case RMS$_WLK:  /* Device write locked */
2539                 unix_status = EACCES;
2540                 break;
2541         /* case RMS$_NMF: */  /* No more files */
2542         }
2543     }
2544   }
2545
2546   return unix_status;
2547 }
2548
2549 /* Try to guess at what VMS error status should go with a UNIX errno
2550  * value.  This is hard to do as there could be many possible VMS
2551  * error statuses that caused the errno value to be set.
2552  */
2553
2554 int Perl_unix_status_to_vms(int unix_status)
2555 {
2556 int test_unix_status;
2557
2558      /* Trivial cases first */
2559     /*---------------------*/
2560     if (unix_status == EVMSERR)
2561         return vaxc$errno;
2562
2563      /* Is vaxc$errno sane? */
2564     /*---------------------*/
2565     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2566     if (test_unix_status == unix_status)
2567         return vaxc$errno;
2568
2569      /* If way out of range, must be VMS code already */
2570     /*-----------------------------------------------*/
2571     if (unix_status > EVMSERR)
2572         return unix_status;
2573
2574      /* If out of range, punt */
2575     /*-----------------------*/
2576     if (unix_status > __ERRNO_MAX)
2577         return SS$_ABORT;
2578
2579
2580      /* Ok, now we have to do it the hard way. */
2581     /*----------------------------------------*/
2582     switch(unix_status) {
2583     case 0:     return SS$_NORMAL;
2584     case EPERM: return SS$_NOPRIV;
2585     case ENOENT: return SS$_NOSUCHOBJECT;
2586     case ESRCH: return SS$_UNREACHABLE;
2587     case EINTR: return SS$_ABORT;
2588     /* case EIO: */
2589     /* case ENXIO:  */
2590     case E2BIG: return SS$_BUFFEROVF;
2591     /* case ENOEXEC */
2592     case EBADF: return RMS$_IFI;
2593     case ECHILD: return SS$_NONEXPR;
2594     /* case EAGAIN */
2595     case ENOMEM: return SS$_INSFMEM;
2596     case EACCES: return SS$_FILACCERR;
2597     case EFAULT: return SS$_ACCVIO;
2598     /* case ENOTBLK */
2599     case EBUSY: return SS$_DEVOFFLINE;
2600     case EEXIST: return RMS$_FEX;
2601     /* case EXDEV */
2602     case ENODEV: return SS$_NOSUCHDEV;
2603     case ENOTDIR: return RMS$_DIR;
2604     /* case EISDIR */
2605     case EINVAL: return SS$_INVARG;
2606     /* case ENFILE */
2607     /* case EMFILE */
2608     /* case ENOTTY */
2609     /* case ETXTBSY */
2610     /* case EFBIG */
2611     case ENOSPC: return SS$_DEVICEFULL;
2612     case ESPIPE: return LIB$_INVARG;
2613     /* case EROFS: */
2614     /* case EMLINK: */
2615     /* case EPIPE: */
2616     /* case EDOM */
2617     case ERANGE: return LIB$_INVARG;
2618     /* case EWOULDBLOCK */
2619     /* case EINPROGRESS */
2620     /* case EALREADY */
2621     /* case ENOTSOCK */
2622     /* case EDESTADDRREQ */
2623     /* case EMSGSIZE */
2624     /* case EPROTOTYPE */
2625     /* case ENOPROTOOPT */
2626     /* case EPROTONOSUPPORT */
2627     /* case ESOCKTNOSUPPORT */
2628     /* case EOPNOTSUPP */
2629     /* case EPFNOSUPPORT */
2630     /* case EAFNOSUPPORT */
2631     /* case EADDRINUSE */
2632     /* case EADDRNOTAVAIL */
2633     /* case ENETDOWN */
2634     /* case ENETUNREACH */
2635     /* case ENETRESET */
2636     /* case ECONNABORTED */
2637     /* case ECONNRESET */
2638     /* case ENOBUFS */
2639     /* case EISCONN */
2640     case ENOTCONN: return SS$_CLEARED;
2641     /* case ESHUTDOWN */
2642     /* case ETOOMANYREFS */
2643     /* case ETIMEDOUT */
2644     /* case ECONNREFUSED */
2645     /* case ELOOP */
2646     /* case ENAMETOOLONG */
2647     /* case EHOSTDOWN */
2648     /* case EHOSTUNREACH */
2649     /* case ENOTEMPTY */
2650     /* case EPROCLIM */
2651     /* case EUSERS  */
2652     /* case EDQUOT  */
2653     /* case ENOMSG  */
2654     /* case EIDRM */
2655     /* case EALIGN */
2656     /* case ESTALE */
2657     /* case EREMOTE */
2658     /* case ENOLCK */
2659     /* case ENOSYS */
2660     /* case EFTYPE */
2661     /* case ECANCELED */
2662     /* case EFAIL */
2663     /* case EINPROG */
2664     case ENOTSUP:
2665         return SS$_UNSUPPORTED;
2666     /* case EDEADLK */
2667     /* case ENWAIT */
2668     /* case EILSEQ */
2669     /* case EBADCAT */
2670     /* case EBADMSG */
2671     /* case EABANDONED */
2672     default:
2673         return SS$_ABORT; /* punt */
2674     }
2675
2676   return SS$_ABORT; /* Should not get here */
2677 }
2678
2679
2680 /* default piping mailbox size */
2681 #define PERL_BUFSIZ        512
2682
2683
2684 static void
2685 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2686 {
2687   unsigned long int mbxbufsiz;
2688   static unsigned long int syssize = 0;
2689   unsigned long int dviitm = DVI$_DEVNAM;
2690   char csize[LNM$C_NAMLENGTH+1];
2691   int sts;
2692
2693   if (!syssize) {
2694     unsigned long syiitm = SYI$_MAXBUF;
2695     /*
2696      * Get the SYSGEN parameter MAXBUF
2697      *
2698      * If the logical 'PERL_MBX_SIZE' is defined
2699      * use the value of the logical instead of PERL_BUFSIZ, but
2700      * keep the size between 128 and MAXBUF.
2701      *
2702      */
2703     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2704   }
2705
2706   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2707       mbxbufsiz = atoi(csize);
2708   } else {
2709       mbxbufsiz = PERL_BUFSIZ;
2710   }
2711   if (mbxbufsiz < 128) mbxbufsiz = 128;
2712   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2713
2714   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2715
2716   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2717   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2718
2719 }  /* end of create_mbx() */
2720
2721
2722 /*{{{  my_popen and my_pclose*/
2723
2724 typedef struct _iosb           IOSB;
2725 typedef struct _iosb*         pIOSB;
2726 typedef struct _pipe           Pipe;
2727 typedef struct _pipe*         pPipe;
2728 typedef struct pipe_details    Info;
2729 typedef struct pipe_details*  pInfo;
2730 typedef struct _srqp            RQE;
2731 typedef struct _srqp*          pRQE;
2732 typedef struct _tochildbuf      CBuf;
2733 typedef struct _tochildbuf*    pCBuf;
2734
2735 struct _iosb {
2736     unsigned short status;
2737     unsigned short count;
2738     unsigned long  dvispec;
2739 };
2740
2741 #pragma member_alignment save
2742 #pragma nomember_alignment quadword
2743 struct _srqp {          /* VMS self-relative queue entry */
2744     unsigned long qptr[2];
2745 };
2746 #pragma member_alignment restore
2747 static RQE  RQE_ZERO = {0,0};
2748
2749 struct _tochildbuf {
2750     RQE             q;
2751     int             eof;
2752     unsigned short  size;
2753     char            *buf;
2754 };
2755
2756 struct _pipe {
2757     RQE            free;
2758     RQE            wait;
2759     int            fd_out;
2760     unsigned short chan_in;
2761     unsigned short chan_out;
2762     char          *buf;
2763     unsigned int   bufsize;
2764     IOSB           iosb;
2765     IOSB           iosb2;
2766     int           *pipe_done;
2767     int            retry;
2768     int            type;
2769     int            shut_on_empty;
2770     int            need_wake;
2771     pPipe         *home;
2772     pInfo          info;
2773     pCBuf          curr;
2774     pCBuf          curr2;
2775 #if defined(PERL_IMPLICIT_CONTEXT)
2776     void            *thx;           /* Either a thread or an interpreter */
2777                                     /* pointer, depending on how we're built */
2778 #endif
2779 };
2780
2781
2782 struct pipe_details
2783 {
2784     pInfo           next;
2785     PerlIO *fp;  /* file pointer to pipe mailbox */
2786     int useFILE; /* using stdio, not perlio */
2787     int pid;   /* PID of subprocess */
2788     int mode;  /* == 'r' if pipe open for reading */
2789     int done;  /* subprocess has completed */
2790     int waiting; /* waiting for completion/closure */
2791     int             closing;        /* my_pclose is closing this pipe */
2792     unsigned long   completion;     /* termination status of subprocess */
2793     pPipe           in;             /* pipe in to sub */
2794     pPipe           out;            /* pipe out of sub */
2795     pPipe           err;            /* pipe of sub's sys$error */
2796     int             in_done;        /* true when in pipe finished */
2797     int             out_done;
2798     int             err_done;
2799     unsigned short  xchan;          /* channel to debug xterm */
2800     unsigned short  xchan_valid;    /* channel is assigned */
2801 };
2802
2803 struct exit_control_block
2804 {
2805     struct exit_control_block *flink;
2806     unsigned long int   (*exit_routine)();
2807     unsigned long int arg_count;
2808     unsigned long int *status_address;
2809     unsigned long int exit_status;
2810 };
2811
2812 typedef struct _closed_pipes    Xpipe;
2813 typedef struct _closed_pipes*  pXpipe;
2814
2815 struct _closed_pipes {
2816     int             pid;            /* PID of subprocess */
2817     unsigned long   completion;     /* termination status of subprocess */
2818 };
2819 #define NKEEPCLOSED 50
2820 static Xpipe closed_list[NKEEPCLOSED];
2821 static int   closed_index = 0;
2822 static int   closed_num = 0;
2823
2824 #define RETRY_DELAY     "0 ::0.20"
2825 #define MAX_RETRY              50
2826
2827 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2828 static unsigned long mypid;
2829 static unsigned long delaytime[2];
2830
2831 static pInfo open_pipes = NULL;
2832 static $DESCRIPTOR(nl_desc, "NL:");
2833
2834 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2835
2836
2837
2838 static unsigned long int
2839 pipe_exit_routine(pTHX)
2840 {
2841     pInfo info;
2842     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2843     int sts, did_stuff, need_eof, j;
2844
2845    /*
2846     * Flush any pending i/o, but since we are in process run-down, be
2847     * careful about referencing PerlIO structures that may already have
2848     * been deallocated.  We may not even have an interpreter anymore.
2849     */
2850     info = open_pipes;
2851     while (info) {
2852         if (info->fp) {
2853            if (!info->useFILE
2854 #if defined(USE_ITHREADS)
2855              && my_perl
2856 #endif
2857              && PL_perlio_fd_refcnt)
2858                PerlIO_flush(info->fp);
2859            else
2860                fflush((FILE *)info->fp);
2861         }
2862         info = info->next;
2863     }
2864
2865     /*
2866      next we try sending an EOF...ignore if doesn't work, make sure we
2867      don't hang
2868     */
2869     did_stuff = 0;
2870     info = open_pipes;
2871
2872     while (info) {
2873       int need_eof;
2874       _ckvmssts_noperl(sys$setast(0));
2875       if (info->in && !info->in->shut_on_empty) {
2876         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2877                           0, 0, 0, 0, 0, 0));
2878         info->waiting = 1;
2879         did_stuff = 1;
2880       }
2881       _ckvmssts_noperl(sys$setast(1));
2882       info = info->next;
2883     }
2884
2885     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2886
2887     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2888         int nwait = 0;
2889
2890         info = open_pipes;
2891         while (info) {
2892           _ckvmssts_noperl(sys$setast(0));
2893           if (info->waiting && info->done)
2894                 info->waiting = 0;
2895           nwait += info->waiting;
2896           _ckvmssts_noperl(sys$setast(1));
2897           info = info->next;
2898         }
2899         if (!nwait) break;
2900         sleep(1);
2901     }
2902
2903     did_stuff = 0;
2904     info = open_pipes;
2905     while (info) {
2906       _ckvmssts_noperl(sys$setast(0));
2907       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2908         sts = sys$forcex(&info->pid,0,&abort);
2909         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2910         did_stuff = 1;
2911       }
2912       _ckvmssts_noperl(sys$setast(1));
2913       info = info->next;
2914     }
2915
2916     /* again, wait for effect */
2917
2918     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2919         int nwait = 0;
2920
2921         info = open_pipes;
2922         while (info) {
2923           _ckvmssts_noperl(sys$setast(0));
2924           if (info->waiting && info->done)
2925                 info->waiting = 0;
2926           nwait += info->waiting;
2927           _ckvmssts_noperl(sys$setast(1));
2928           info = info->next;
2929         }
2930         if (!nwait) break;
2931         sleep(1);
2932     }
2933
2934     info = open_pipes;
2935     while (info) {
2936       _ckvmssts_noperl(sys$setast(0));
2937       if (!info->done) {  /* We tried to be nice . . . */
2938         sts = sys$delprc(&info->pid,0);
2939         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2940         info->done = 1;  /* sys$delprc is as done as we're going to get. */
2941       }
2942       _ckvmssts_noperl(sys$setast(1));
2943       info = info->next;
2944     }
2945
2946     while(open_pipes) {
2947       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2948       else if (!(sts & 1)) retsts = sts;
2949     }
2950     return retsts;
2951 }
2952
2953 static struct exit_control_block pipe_exitblock =
2954        {(struct exit_control_block *) 0,
2955         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2956
2957 static void pipe_mbxtofd_ast(pPipe p);
2958 static void pipe_tochild1_ast(pPipe p);
2959 static void pipe_tochild2_ast(pPipe p);
2960
2961 static void
2962 popen_completion_ast(pInfo info)
2963 {
2964   pInfo i = open_pipes;
2965   int iss;
2966   int sts;
2967   pXpipe x;
2968
2969   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2970   closed_list[closed_index].pid = info->pid;
2971   closed_list[closed_index].completion = info->completion;
2972   closed_index++;
2973   if (closed_index == NKEEPCLOSED)
2974     closed_index = 0;
2975   closed_num++;
2976
2977   while (i) {
2978     if (i == info) break;
2979     i = i->next;
2980   }
2981   if (!i) return;       /* unlinked, probably freed too */
2982
2983   info->done = TRUE;
2984
2985 /*
2986     Writing to subprocess ...
2987             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2988
2989             chan_out may be waiting for "done" flag, or hung waiting
2990             for i/o completion to child...cancel the i/o.  This will
2991             put it into "snarf mode" (done but no EOF yet) that discards
2992             input.
2993
2994     Output from subprocess (stdout, stderr) needs to be flushed and
2995     shut down.   We try sending an EOF, but if the mbx is full the pipe
2996     routine should still catch the "shut_on_empty" flag, telling it to
2997     use immediate-style reads so that "mbx empty" -> EOF.
2998
2999
3000 */
3001   if (info->in && !info->in_done) {               /* only for mode=w */
3002         if (info->in->shut_on_empty && info->in->need_wake) {
3003             info->in->need_wake = FALSE;
3004             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3005         } else {
3006             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3007         }
3008   }
3009
3010   if (info->out && !info->out_done) {             /* were we also piping output? */
3011       info->out->shut_on_empty = TRUE;
3012       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3013       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3014       _ckvmssts_noperl(iss);
3015   }
3016
3017   if (info->err && !info->err_done) {        /* we were piping stderr */
3018         info->err->shut_on_empty = TRUE;
3019         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3020         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3021         _ckvmssts_noperl(iss);
3022   }
3023   _ckvmssts_noperl(sys$setef(pipe_ef));
3024
3025 }
3026
3027 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3028 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3029
3030 /*
3031     we actually differ from vmstrnenv since we use this to
3032     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3033     are pointing to the same thing
3034 */
3035
3036 static unsigned short
3037 popen_translate(pTHX_ char *logical, char *result)
3038 {
3039     int iss;
3040     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3041     $DESCRIPTOR(d_log,"");
3042     struct _il3 {
3043         unsigned short length;
3044         unsigned short code;
3045         char *         buffer_addr;
3046         unsigned short *retlenaddr;
3047     } itmlst[2];
3048     unsigned short l, ifi;
3049
3050     d_log.dsc$a_pointer = logical;
3051     d_log.dsc$w_length  = strlen(logical);
3052
3053     itmlst[0].code = LNM$_STRING;
3054     itmlst[0].length = 255;
3055     itmlst[0].buffer_addr = result;
3056     itmlst[0].retlenaddr = &l;
3057
3058     itmlst[1].code = 0;
3059     itmlst[1].length = 0;
3060     itmlst[1].buffer_addr = 0;
3061     itmlst[1].retlenaddr = 0;
3062
3063     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3064     if (iss == SS$_NOLOGNAM) {
3065         iss = SS$_NORMAL;
3066         l = 0;
3067     }
3068     if (!(iss&1)) lib$signal(iss);
3069     result[l] = '\0';
3070 /*
3071     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3072     strip it off and return the ifi, if any
3073 */
3074     ifi  = 0;
3075     if (result[0] == 0x1b && result[1] == 0x00) {
3076         memmove(&ifi,result+2,2);
3077         strcpy(result,result+4);
3078     }
3079     return ifi;     /* this is the RMS internal file id */
3080 }
3081
3082 static void pipe_infromchild_ast(pPipe p);
3083
3084 /*
3085     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3086     inside an AST routine without worrying about reentrancy and which Perl
3087     memory allocator is being used.
3088
3089     We read data and queue up the buffers, then spit them out one at a
3090     time to the output mailbox when the output mailbox is ready for one.
3091
3092 */
3093 #define INITIAL_TOCHILDQUEUE  2
3094
3095 static pPipe
3096 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3097 {
3098     pPipe p;
3099     pCBuf b;
3100     char mbx1[64], mbx2[64];
3101     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3102                                       DSC$K_CLASS_S, mbx1},
3103                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3104                                       DSC$K_CLASS_S, mbx2};
3105     unsigned int dviitm = DVI$_DEVBUFSIZ;
3106     int j, n;
3107
3108     n = sizeof(Pipe);
3109     _ckvmssts(lib$get_vm(&n, &p));
3110
3111     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3112     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3113     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3114
3115     p->buf           = 0;
3116     p->shut_on_empty = FALSE;
3117     p->need_wake     = FALSE;
3118     p->type          = 0;
3119     p->retry         = 0;
3120     p->iosb.status   = SS$_NORMAL;
3121     p->iosb2.status  = SS$_NORMAL;
3122     p->free          = RQE_ZERO;
3123     p->wait          = RQE_ZERO;
3124     p->curr          = 0;
3125     p->curr2         = 0;
3126     p->info          = 0;
3127 #ifdef PERL_IMPLICIT_CONTEXT
3128     p->thx           = aTHX;
3129 #endif
3130
3131     n = sizeof(CBuf) + p->bufsize;
3132
3133     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3134         _ckvmssts(lib$get_vm(&n, &b));
3135         b->buf = (char *) b + sizeof(CBuf);
3136         _ckvmssts(lib$insqhi(b, &p->free));
3137     }
3138
3139     pipe_tochild2_ast(p);
3140     pipe_tochild1_ast(p);
3141     strcpy(wmbx, mbx1);
3142     strcpy(rmbx, mbx2);
3143     return p;
3144 }
3145
3146 /*  reads the MBX Perl is writing, and queues */
3147
3148 static void
3149 pipe_tochild1_ast(pPipe p)
3150 {
3151     pCBuf b = p->curr;
3152     int iss = p->iosb.status;
3153     int eof = (iss == SS$_ENDOFFILE);
3154     int sts;
3155 #ifdef PERL_IMPLICIT_CONTEXT
3156     pTHX = p->thx;
3157 #endif
3158
3159     if (p->retry) {
3160         if (eof) {
3161             p->shut_on_empty = TRUE;
3162             b->eof     = TRUE;
3163             _ckvmssts(sys$dassgn(p->chan_in));
3164         } else  {
3165             _ckvmssts(iss);
3166         }
3167
3168         b->eof  = eof;
3169         b->size = p->iosb.count;
3170         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3171         if (p->need_wake) {
3172             p->need_wake = FALSE;
3173             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3174         }
3175     } else {
3176         p->retry = 1;   /* initial call */
3177     }
3178
3179     if (eof) {                  /* flush the free queue, return when done */
3180         int n = sizeof(CBuf) + p->bufsize;
3181         while (1) {
3182             iss = lib$remqti(&p->free, &b);
3183             if (iss == LIB$_QUEWASEMP) return;
3184             _ckvmssts(iss);
3185             _ckvmssts(lib$free_vm(&n, &b));
3186         }
3187     }
3188
3189     iss = lib$remqti(&p->free, &b);
3190     if (iss == LIB$_QUEWASEMP) {
3191         int n = sizeof(CBuf) + p->bufsize;
3192         _ckvmssts(lib$get_vm(&n, &b));
3193         b->buf = (char *) b + sizeof(CBuf);
3194     } else {
3195        _ckvmssts(iss);
3196     }
3197
3198     p->curr = b;
3199     iss = sys$qio(0,p->chan_in,
3200              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3201              &p->iosb,
3202              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3203     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3204     _ckvmssts(iss);
3205 }
3206
3207
3208 /* writes queued buffers to output, waits for each to complete before
3209    doing the next */
3210
3211 static void
3212 pipe_tochild2_ast(pPipe p)
3213 {
3214     pCBuf b = p->curr2;
3215     int iss = p->iosb2.status;
3216     int n = sizeof(CBuf) + p->bufsize;
3217     int done = (p->info && p->info->done) ||
3218               iss == SS$_CANCEL || iss == SS$_ABORT;
3219 #if defined(PERL_IMPLICIT_CONTEXT)
3220     pTHX = p->thx;
3221 #endif
3222
3223     do {
3224         if (p->type) {         /* type=1 has old buffer, dispose */
3225             if (p->shut_on_empty) {
3226                 _ckvmssts(lib$free_vm(&n, &b));
3227             } else {
3228                 _ckvmssts(lib$insqhi(b, &p->free));
3229             }
3230             p->type = 0;
3231         }
3232
3233         iss = lib$remqti(&p->wait, &b);
3234         if (iss == LIB$_QUEWASEMP) {
3235             if (p->shut_on_empty) {
3236                 if (done) {
3237                     _ckvmssts(sys$dassgn(p->chan_out));
3238                     *p->pipe_done = TRUE;
3239                     _ckvmssts(sys$setef(pipe_ef));
3240                 } else {
3241                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3242                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3243                 }
3244                 return;
3245             }
3246             p->need_wake = TRUE;
3247             return;
3248         }
3249         _ckvmssts(iss);
3250         p->type = 1;
3251     } while (done);
3252
3253
3254     p->curr2 = b;
3255     if (b->eof) {
3256         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3257             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3258     } else {
3259         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3260             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3261     }
3262
3263     return;
3264
3265 }
3266
3267
3268 static pPipe
3269 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3270 {
3271     pPipe p;
3272     char mbx1[64], mbx2[64];
3273     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3274                                       DSC$K_CLASS_S, mbx1},
3275                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3276                                       DSC$K_CLASS_S, mbx2};
3277     unsigned int dviitm = DVI$_DEVBUFSIZ;
3278
3279     int n = sizeof(Pipe);
3280     _ckvmssts(lib$get_vm(&n, &p));
3281     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3282     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3283
3284     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3285     n = p->bufsize * sizeof(char);
3286     _ckvmssts(lib$get_vm(&n, &p->buf));
3287     p->shut_on_empty = FALSE;
3288     p->info   = 0;
3289     p->type   = 0;
3290     p->iosb.status = SS$_NORMAL;
3291 #if defined(PERL_IMPLICIT_CONTEXT)
3292     p->thx = aTHX;
3293 #endif
3294     pipe_infromchild_ast(p);
3295
3296     strcpy(wmbx, mbx1);
3297     strcpy(rmbx, mbx2);
3298     return p;
3299 }
3300
3301 static void
3302 pipe_infromchild_ast(pPipe p)
3303 {
3304     int iss = p->iosb.status;
3305     int eof = (iss == SS$_ENDOFFILE);
3306     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3307     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3308 #if defined(PERL_IMPLICIT_CONTEXT)
3309     pTHX = p->thx;
3310 #endif
3311
3312     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3313         _ckvmssts(sys$dassgn(p->chan_out));
3314         p->chan_out = 0;
3315     }
3316
3317     /* read completed:
3318             input shutdown if EOF from self (done or shut_on_empty)
3319             output shutdown if closing flag set (my_pclose)
3320             send data/eof from child or eof from self
3321             otherwise, re-read (snarf of data from child)
3322     */
3323
3324     if (p->type == 1) {
3325         p->type = 0;
3326         if (myeof && p->chan_in) {                  /* input shutdown */
3327             _ckvmssts(sys$dassgn(p->chan_in));
3328             p->chan_in = 0;
3329         }
3330
3331         if (p->chan_out) {
3332             if (myeof || kideof) {      /* pass EOF to parent */
3333                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3334                               pipe_infromchild_ast, p,
3335                               0, 0, 0, 0, 0, 0));
3336                 return;
3337             } else if (eof) {       /* eat EOF --- fall through to read*/
3338
3339             } else {                /* transmit data */
3340                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3341                               pipe_infromchild_ast,p,
3342                               p->buf, p->iosb.count, 0, 0, 0, 0));
3343                 return;
3344             }
3345         }
3346     }
3347
3348     /*  everything shut? flag as done */
3349
3350     if (!p->chan_in && !p->chan_out) {
3351         *p->pipe_done = TRUE;
3352         _ckvmssts(sys$setef(pipe_ef));
3353         return;
3354     }
3355
3356     /* write completed (or read, if snarfing from child)
3357             if still have input active,
3358                queue read...immediate mode if shut_on_empty so we get EOF if empty
3359             otherwise,
3360                check if Perl reading, generate EOFs as needed
3361     */
3362
3363     if (p->type == 0) {
3364         p->type = 1;
3365         if (p->chan_in) {
3366             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3367                           pipe_infromchild_ast,p,
3368                           p->buf, p->bufsize, 0, 0, 0, 0);
3369             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3370             _ckvmssts(iss);
3371         } else {           /* send EOFs for extra reads */
3372             p->iosb.status = SS$_ENDOFFILE;
3373             p->iosb.dvispec = 0;
3374             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3375                       0, 0, 0,
3376                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3377         }
3378     }
3379 }
3380
3381 static pPipe
3382 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3383 {
3384     pPipe p;
3385     char mbx[64];
3386     unsigned long dviitm = DVI$_DEVBUFSIZ;
3387     struct stat s;
3388     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3389                                       DSC$K_CLASS_S, mbx};
3390     int n = sizeof(Pipe);
3391
3392     /* things like terminals and mbx's don't need this filter */
3393     if (fd && fstat(fd,&s) == 0) {
3394         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3395         char device[65];
3396         unsigned short dev_len;
3397         struct dsc$descriptor_s d_dev;
3398         char * cptr;
3399         struct item_list_3 items[3];
3400         int status;
3401         unsigned short dvi_iosb[4];
3402
3403         cptr = getname(fd, out, 1);
3404         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3405         d_dev.dsc$a_pointer = out;
3406         d_dev.dsc$w_length = strlen(out);
3407         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3408         d_dev.dsc$b_class = DSC$K_CLASS_S;
3409
3410         items[0].len = 4;
3411         items[0].code = DVI$_DEVCHAR;
3412         items[0].bufadr = &devchar;
3413         items[0].retadr = NULL;
3414         items[1].len = 64;
3415         items[1].code = DVI$_FULLDEVNAM;
3416         items[1].bufadr = device;
3417         items[1].retadr = &dev_len;
3418         items[2].len = 0;
3419         items[2].code = 0;
3420
3421         status = sys$getdviw
3422                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3423         _ckvmssts(status);
3424         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3425             device[dev_len] = 0;
3426
3427             if (!(devchar & DEV$M_DIR)) {
3428                 strcpy(out, device);
3429                 return 0;
3430             }
3431         }
3432     }
3433
3434     _ckvmssts(lib$get_vm(&n, &p));
3435     p->fd_out = dup(fd);
3436     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3437     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3438     n = (p->bufsize+1) * sizeof(char);
3439     _ckvmssts(lib$get_vm(&n, &p->buf));
3440     p->shut_on_empty = FALSE;
3441     p->retry = 0;
3442     p->info  = 0;
3443     strcpy(out, mbx);
3444
3445     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3446                   pipe_mbxtofd_ast, p,
3447                   p->buf, p->bufsize, 0, 0, 0, 0));
3448
3449     return p;
3450 }
3451
3452 static void
3453 pipe_mbxtofd_ast(pPipe p)
3454 {
3455     int iss = p->iosb.status;
3456     int done = p->info->done;
3457     int iss2;
3458     int eof = (iss == SS$_ENDOFFILE);
3459     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3460     int err = !(iss&1) && !eof;
3461 #if defined(PERL_IMPLICIT_CONTEXT)
3462     pTHX = p->thx;
3463 #endif
3464
3465     if (done && myeof) {               /* end piping */
3466         close(p->fd_out);
3467         sys$dassgn(p->chan_in);
3468         *p->pipe_done = TRUE;
3469         _ckvmssts(sys$setef(pipe_ef));
3470         return;
3471     }
3472
3473     if (!err && !eof) {             /* good data to send to file */
3474         p->buf[p->iosb.count] = '\n';
3475         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3476         if (iss2 < 0) {
3477             p->retry++;
3478             if (p->retry < MAX_RETRY) {
3479                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3480                 return;
3481             }
3482         }
3483         p->retry = 0;
3484     } else if (err) {
3485         _ckvmssts(iss);
3486     }
3487
3488
3489     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3490           pipe_mbxtofd_ast, p,
3491           p->buf, p->bufsize, 0, 0, 0, 0);
3492     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3493     _ckvmssts(iss);
3494 }
3495
3496
3497 typedef struct _pipeloc     PLOC;
3498 typedef struct _pipeloc*   pPLOC;
3499
3500 struct _pipeloc {
3501     pPLOC   next;
3502     char    dir[NAM$C_MAXRSS+1];
3503 };
3504 static pPLOC  head_PLOC = 0;
3505
3506 void
3507 free_pipelocs(pTHX_ void *head)
3508 {
3509     pPLOC p, pnext;
3510     pPLOC *pHead = (pPLOC *)head;
3511
3512     p = *pHead;
3513     while (p) {
3514         pnext = p->next;
3515         PerlMem_free(p);
3516         p = pnext;
3517     }
3518     *pHead = 0;
3519 }
3520
3521 static void
3522 store_pipelocs(pTHX)
3523 {
3524     int    i;
3525     pPLOC  p;
3526     AV    *av = 0;
3527     SV    *dirsv;
3528     GV    *gv;
3529     char  *dir, *x;
3530     char  *unixdir;
3531     char  temp[NAM$C_MAXRSS+1];
3532     STRLEN n_a;
3533
3534     if (head_PLOC)
3535         free_pipelocs(aTHX_ &head_PLOC);
3536
3537 /*  the . directory from @INC comes last */
3538
3539     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3540     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3541     p->next = head_PLOC;
3542     head_PLOC = p;
3543     strcpy(p->dir,"./");
3544
3545 /*  get the directory from $^X */
3546
3547     unixdir = PerlMem_malloc(VMS_MAXRSS);
3548     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3549
3550 #ifdef PERL_IMPLICIT_CONTEXT
3551     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3552 #else
3553     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3554 #endif
3555         strcpy(temp, PL_origargv[0]);
3556         x = strrchr(temp,']');
3557         if (x == NULL) {
3558         x = strrchr(temp,'>');
3559           if (x == NULL) {
3560             /* It could be a UNIX path */
3561             x = strrchr(temp,'/');
3562           }
3563         }
3564         if (x)
3565           x[1] = '\0';
3566         else {
3567           /* Got a bare name, so use default directory */
3568           temp[0] = '.';
3569           temp[1] = '\0';
3570         }
3571
3572         if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3573             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3574             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3575             p->next = head_PLOC;
3576             head_PLOC = p;
3577             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3578             p->dir[NAM$C_MAXRSS] = '\0';
3579         }
3580     }
3581
3582 /*  reverse order of @INC entries, skip "." since entered above */
3583
3584 #ifdef PERL_IMPLICIT_CONTEXT
3585     if (aTHX)
3586 #endif
3587     if (PL_incgv) av = GvAVn(PL_incgv);
3588
3589     for (i = 0; av && i <= AvFILL(av); i++) {
3590         dirsv = *av_fetch(av,i,TRUE);
3591
3592         if (SvROK(dirsv)) continue;
3593         dir = SvPVx(dirsv,n_a);
3594         if (strcmp(dir,".") == 0) continue;
3595         if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3596             continue;
3597
3598         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3599         p->next = head_PLOC;
3600         head_PLOC = p;
3601         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3602         p->dir[NAM$C_MAXRSS] = '\0';
3603     }
3604
3605 /* most likely spot (ARCHLIB) put first in the list */
3606
3607 #ifdef ARCHLIB_EXP
3608     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3609         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3610         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3611         p->next = head_PLOC;
3612         head_PLOC = p;
3613         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3614         p->dir[NAM$C_MAXRSS] = '\0';
3615     }
3616 #endif
3617     PerlMem_free(unixdir);
3618 }
3619
3620 static I32
3621 Perl_cando_by_name_int
3622    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3623 #if !defined(PERL_IMPLICIT_CONTEXT)
3624 #define cando_by_name_int               Perl_cando_by_name_int
3625 #else
3626 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3627 #endif
3628
3629 static char *
3630 find_vmspipe(pTHX)
3631 {
3632     static int   vmspipe_file_status = 0;
3633     static char  vmspipe_file[NAM$C_MAXRSS+1];
3634
3635     /* already found? Check and use ... need read+execute permission */
3636
3637     if (vmspipe_file_status == 1) {
3638         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3639          && cando_by_name_int
3640            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3641             return vmspipe_file;
3642         }
3643         vmspipe_file_status = 0;
3644     }
3645
3646     /* scan through stored @INC, $^X */
3647
3648     if (vmspipe_file_status == 0) {
3649         char file[NAM$C_MAXRSS+1];
3650         pPLOC  p = head_PLOC;
3651
3652         while (p) {
3653             char * exp_res;
3654             int dirlen;
3655             strcpy(file, p->dir);
3656             dirlen = strlen(file);
3657             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3658             file[NAM$C_MAXRSS] = '\0';
3659             p = p->next;
3660
3661             exp_res = do_rmsexpand
3662                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3663             if (!exp_res) continue;
3664
3665             if (cando_by_name_int
3666                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3667              && cando_by_name_int
3668                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3669                 vmspipe_file_status = 1;
3670                 return vmspipe_file;
3671             }
3672         }
3673         vmspipe_file_status = -1;   /* failed, use tempfiles */
3674     }
3675
3676     return 0;
3677 }
3678
3679 static FILE *
3680 vmspipe_tempfile(pTHX)
3681 {
3682     char file[NAM$C_MAXRSS+1];
3683     FILE *fp;
3684     static int index = 0;
3685     Stat_t s0, s1;
3686     int cmp_result;
3687
3688     /* create a tempfile */
3689
3690     /* we can't go from   W, shr=get to  R, shr=get without
3691        an intermediate vulnerable state, so don't bother trying...
3692
3693        and lib$spawn doesn't shr=put, so have to close the write
3694
3695        So... match up the creation date/time and the FID to
3696        make sure we're dealing with the same file
3697
3698     */
3699
3700     index++;
3701     if (!decc_filename_unix_only) {
3702       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3703       fp = fopen(file,"w");
3704       if (!fp) {
3705         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3706         fp = fopen(file,"w");
3707         if (!fp) {
3708             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3709             fp = fopen(file,"w");
3710         }
3711       }
3712      }
3713      else {
3714       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3715       fp = fopen(file,"w");
3716       if (!fp) {
3717         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3718         fp = fopen(file,"w");
3719         if (!fp) {
3720           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3721           fp = fopen(file,"w");
3722         }
3723       }
3724     }
3725     if (!fp) return 0;  /* we're hosed */
3726
3727     fprintf(fp,"$! 'f$verify(0)'\n");
3728     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3729     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3730     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3731     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3732     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3733     fprintf(fp,"$ perl_del    = \"delete\"\n");
3734     fprintf(fp,"$ pif         = \"if\"\n");
3735     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3736     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3737     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3738     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3739     fprintf(fp,"$!  --- build command line to get max possible length\n");
3740     fprintf(fp,"$c=perl_popen_cmd0\n");
3741     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3742     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3743     fprintf(fp,"$x=perl_popen_cmd3\n");
3744     fprintf(fp,"$c=c+x\n");
3745     fprintf(fp,"$ perl_on\n");
3746     fprintf(fp,"$ 'c'\n");
3747     fprintf(fp,"$ perl_status = $STATUS\n");
3748     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3749     fprintf(fp,"$ perl_exit 'perl_status'\n");
3750     fsync(fileno(fp));
3751
3752     fgetname(fp, file, 1);
3753     fstat(fileno(fp), (struct stat *)&s0);
3754     fclose(fp);
3755
3756     if (decc_filename_unix_only)
3757         do_tounixspec(file, file, 0, NULL);
3758     fp = fopen(file,"r","shr=get");
3759     if (!fp) return 0;
3760     fstat(fileno(fp), (struct stat *)&s1);
3761
3762     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3763     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3764         fclose(fp);
3765         return 0;
3766     }
3767
3768     return fp;
3769 }
3770
3771
3772 #ifdef USE_VMS_DECTERM
3773
3774 static int vms_is_syscommand_xterm(void)
3775 {
3776     const static struct dsc$descriptor_s syscommand_dsc =
3777       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3778
3779     const static struct dsc$descriptor_s decwdisplay_dsc =
3780       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3781
3782     struct item_list_3 items[2];
3783     unsigned short dvi_iosb[4];
3784     unsigned long devchar;
3785     unsigned long devclass;
3786     int status;
3787
3788     /* Very simple check to guess if sys$command is a decterm? */
3789     /* First see if the DECW$DISPLAY: device exists */
3790     items[0].len = 4;
3791     items[0].code = DVI$_DEVCHAR;
3792     items[0].bufadr = &devchar;
3793     items[0].retadr = NULL;
3794     items[1].len = 0;
3795     items[1].code = 0;
3796
3797     status = sys$getdviw
3798         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3799
3800     if ($VMS_STATUS_SUCCESS(status)) {
3801         status = dvi_iosb[0];
3802     }
3803
3804     if (!$VMS_STATUS_SUCCESS(status)) {
3805         SETERRNO(EVMSERR, status);
3806         return -1;
3807     }
3808
3809     /* If it does, then for now assume that we are on a workstation */
3810     /* Now verify that SYS$COMMAND is a terminal */
3811     /* for creating the debugger DECTerm */
3812
3813     items[0].len = 4;
3814     items[0].code = DVI$_DEVCLASS;
3815     items[0].bufadr = &devclass;
3816     items[0].retadr = NULL;
3817     items[1].len = 0;
3818     items[1].code = 0;
3819
3820     status = sys$getdviw
3821         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3822
3823     if ($VMS_STATUS_SUCCESS(status)) {
3824         status = dvi_iosb[0];
3825     }
3826
3827     if (!$VMS_STATUS_SUCCESS(status)) {
3828         SETERRNO(EVMSERR, status);
3829         return -1;
3830     }
3831     else {
3832         if (devclass == DC$_TERM) {
3833             return 0;
3834         }
3835     }
3836     return -1;
3837 }
3838
3839 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3840 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3841 {
3842     int status;
3843     int ret_stat;
3844     char * ret_char;
3845     char device_name[65];
3846     unsigned short device_name_len;
3847     struct dsc$descriptor_s customization_dsc;
3848     struct dsc$descriptor_s device_name_dsc;
3849     const char * cptr;
3850     char * tptr;
3851     char customization[200];
3852     char title[40];
3853     pInfo info = NULL;
3854     char mbx1[64];
3855     unsigned short p_chan;
3856     int n;
3857     unsigned short iosb[4];
3858     struct item_list_3 items[2];
3859     const char * cust_str =
3860         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3861     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3862                                           DSC$K_CLASS_S, mbx1};
3863
3864     ret_char = strstr(cmd," xterm ");
3865     if (ret_char == NULL)
3866         return NULL;
3867     cptr = ret_char + 7;
3868     ret_char = strstr(cmd,"tty");
3869     if (ret_char == NULL)
3870         return NULL;
3871     ret_char = strstr(cmd,"sleep");
3872     if (ret_char == NULL)
3873         return NULL;
3874
3875     /* Are we on a workstation? */
3876     /* to do: capture the rows / columns and pass their properties */
3877     ret_stat = vms_is_syscommand_xterm();
3878     if (ret_stat < 0)
3879         return NULL;
3880
3881     /* Make the title: */
3882     ret_char = strstr(cptr,"-title");
3883     if (ret_char != NULL) {
3884         while ((*cptr != 0) && (*cptr != '\"')) {
3885             cptr++;
3886         }
3887         if (*cptr == '\"')
3888             cptr++;
3889         n = 0;
3890         while ((*cptr != 0) && (*cptr != '\"')) {
3891             title[n] = *cptr;
3892             n++;
3893             if (n == 39) {
3894                 title[39] == 0;
3895                 break;
3896             }
3897             cptr++;
3898         }
3899         title[n] = 0;
3900     }
3901     else {
3902             /* Default title */
3903             strcpy(title,"Perl Debug DECTerm");
3904     }
3905     sprintf(customization, cust_str, title);
3906
3907     customization_dsc.dsc$a_pointer = customization;
3908     customization_dsc.dsc$w_length = strlen(customization);
3909     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3910     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3911
3912     device_name_dsc.dsc$a_pointer = device_name;
3913     device_name_dsc.dsc$w_length = sizeof device_name -1;
3914     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3915     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3916
3917     device_name_len = 0;
3918
3919     /* Try to create the window */
3920      status = decw$term_port
3921        (NULL,
3922         NULL,
3923         &customization_dsc,
3924         &device_name_dsc,
3925         &device_name_len,
3926         NULL,
3927         NULL,
3928         NULL);
3929     if (!$VMS_STATUS_SUCCESS(status)) {
3930         SETERRNO(EVMSERR, status);
3931         return NULL;
3932     }
3933
3934     device_name[device_name_len] = '\0';
3935
3936     /* Need to set this up to look like a pipe for cleanup */
3937     n = sizeof(Info);
3938     status = lib$get_vm(&n, &info);
3939     if (!$VMS_STATUS_SUCCESS(status)) {
3940         SETERRNO(ENOMEM, status);
3941         return NULL;
3942     }
3943
3944     info->mode = *mode;
3945     info->done = FALSE;
3946     info->completion = 0;
3947     info->closing    = FALSE;
3948     info->in         = 0;
3949     info->out        = 0;
3950     info->err        = 0;
3951     info->fp         = Nullfp;
3952     info->useFILE    = 0;
3953     info->waiting    = 0;
3954     info->in_done    = TRUE;
3955     info->out_done   = TRUE;
3956     info->err_done   = TRUE;
3957
3958     /* Assign a channel on this so that it will persist, and not login */
3959     /* We stash this channel in the info structure for reference. */
3960     /* The created xterm self destructs when the last channel is removed */
3961     /* and it appears that perl5db.pl (perl debugger) does this routinely */
3962     /* So leave this assigned. */
3963     device_name_dsc.dsc$w_length = device_name_len;
3964     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
3965     if (!$VMS_STATUS_SUCCESS(status)) {
3966         SETERRNO(EVMSERR, status);
3967         return NULL;
3968     }
3969     info->xchan_valid = 1;
3970
3971     /* Now create a mailbox to be read by the application */
3972
3973     create_mbx(aTHX_ &p_chan, &d_mbx1);
3974
3975     /* write the name of the created terminal to the mailbox */
3976     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
3977             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
3978
3979     if (!$VMS_STATUS_SUCCESS(status)) {
3980         SETERRNO(EVMSERR, status);
3981         return NULL;
3982     }
3983
3984     info->fp  = PerlIO_open(mbx1, mode);
3985
3986     /* Done with this channel */
3987     sys$dassgn(p_chan);
3988
3989     /* If any errors, then clean up */
3990     if (!info->fp) {
3991         n = sizeof(Info);
3992         _ckvmssts(lib$free_vm(&n, &info));
3993         return NULL;
3994         }
3995
3996     /* All done */
3997     return info->fp;
3998 }
3999 #endif
4000
4001 static PerlIO *
4002 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4003 {
4004     static int handler_set_up = FALSE;
4005     unsigned long int sts, flags = CLI$M_NOWAIT;
4006     /* The use of a GLOBAL table (as was done previously) rendered
4007      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4008      * environment.  Hence we've switched to LOCAL symbol table.
4009      */
4010     unsigned int table = LIB$K_CLI_LOCAL_SYM;
4011     int j, wait = 0, n;
4012     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4013     char *in, *out, *err, mbx[512];
4014     FILE *tpipe = 0;
4015     char tfilebuf[NAM$C_MAXRSS+1];
4016     pInfo info = NULL;
4017     char cmd_sym_name[20];
4018     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4019                                       DSC$K_CLASS_S, symbol};
4020     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4021                                       DSC$K_CLASS_S, 0};
4022     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4023                                       DSC$K_CLASS_S, cmd_sym_name};
4024     struct dsc$descriptor_s *vmscmd;
4025     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4026     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4027     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4028
4029 #ifdef USE_VMS_DECTERM
4030     /* Check here for Xterm create request.  This means looking for
4031      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4032      *  is possible to create an xterm.
4033      */
4034     if (*in_mode == 'r') {
4035         PerlIO * xterm_fd;
4036
4037         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4038         if (xterm_fd != Nullfp)
4039             return xterm_fd;
4040     }
4041 #endif
4042
4043     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4044
4045     /* once-per-program initialization...
4046        note that the SETAST calls and the dual test of pipe_ef
4047        makes sure that only the FIRST thread through here does
4048        the initialization...all other threads wait until it's
4049        done.
4050
4051        Yeah, uglier than a pthread call, it's got all the stuff inline
4052        rather than in a separate routine.
4053     */
4054
4055     if (!pipe_ef) {
4056         _ckvmssts(sys$setast(0));
4057         if (!pipe_ef) {
4058             unsigned long int pidcode = JPI$_PID;
4059             $DESCRIPTOR(d_delay, RETRY_DELAY);
4060             _ckvmssts(lib$get_ef(&pipe_ef));
4061             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4062             _ckvmssts(sys$bintim(&d_delay, delaytime));
4063         }
4064         if (!handler_set_up) {
4065           _ckvmssts(sys$dclexh(&pipe_exitblock));
4066           handler_set_up = TRUE;
4067         }
4068         _ckvmssts(sys$setast(1));
4069     }
4070
4071     /* see if we can find a VMSPIPE.COM */
4072
4073     tfilebuf[0] = '@';
4074     vmspipe = find_vmspipe(aTHX);
4075     if (vmspipe) {
4076         strcpy(tfilebuf+1,vmspipe);
4077     } else {        /* uh, oh...we're in tempfile hell */
4078         tpipe = vmspipe_tempfile(aTHX);
4079         if (!tpipe) {       /* a fish popular in Boston */
4080             if (ckWARN(WARN_PIPE)) {
4081                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4082             }
4083         return Nullfp;
4084         }
4085         fgetname(tpipe,tfilebuf+1,1);
4086     }
4087     vmspipedsc.dsc$a_pointer = tfilebuf;
4088     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4089
4090     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4091     if (!(sts & 1)) {
4092       switch (sts) {
4093         case RMS$_FNF:  case RMS$_DNF:
4094           set_errno(ENOENT); break;
4095         case RMS$_DIR:
4096           set_errno(ENOTDIR); break;
4097         case RMS$_DEV:
4098           set_errno(ENODEV); break;
4099         case RMS$_PRV:
4100           set_errno(EACCES); break;
4101         case RMS$_SYN:
4102           set_errno(EINVAL); break;
4103         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4104           set_errno(E2BIG); break;
4105         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4106           _ckvmssts(sts); /* fall through */
4107         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4108           set_errno(EVMSERR);
4109       }
4110       set_vaxc_errno(sts);
4111       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4112         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4113       }
4114       *psts = sts;
4115       return Nullfp;
4116     }
4117     n = sizeof(Info);
4118     _ckvmssts(lib$get_vm(&n, &info));
4119
4120     strcpy(mode,in_mode);
4121     info->mode = *mode;
4122     info->done = FALSE;
4123     info->completion = 0;
4124     info->closing    = FALSE;
4125     info->in         = 0;
4126     info->out        = 0;
4127     info->err        = 0;
4128     info->fp         = Nullfp;
4129     info->useFILE    = 0;
4130     info->waiting    = 0;
4131     info->in_done    = TRUE;
4132     info->out_done   = TRUE;
4133     info->err_done   = TRUE;
4134     info->xchan      = 0;
4135     info->xchan_valid = 0;
4136
4137     in = PerlMem_malloc(VMS_MAXRSS);
4138     if (in == NULL) _ckvmssts(SS$_INSFMEM);
4139     out = PerlMem_malloc(VMS_MAXRSS);
4140     if (out == NULL) _ckvmssts(SS$_INSFMEM);
4141     err = PerlMem_malloc(VMS_MAXRSS);
4142     if (err == NULL) _ckvmssts(SS$_INSFMEM);
4143
4144     in[0] = out[0] = err[0] = '\0';
4145
4146     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4147         info->useFILE = 1;
4148         strcpy(p,p+1);
4149     }
4150     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4151         wait = 1;
4152         strcpy(p,p+1);
4153     }
4154
4155     if (*mode == 'r') {             /* piping from subroutine */
4156
4157         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4158         if (info->out) {
4159             info->out->pipe_done = &info->out_done;
4160             info->out_done = FALSE;
4161             info->out->info = info;
4162         }
4163         if (!info->useFILE) {
4164             info->fp  = PerlIO_open(mbx, mode);
4165         } else {
4166             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4167             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4168         }
4169
4170         if (!info->fp && info->out) {
4171             sys$cancel(info->out->chan_out);
4172
4173             while (!info->out_done) {
4174                 int done;
4175                 _ckvmssts(sys$setast(0));
4176                 done = info->out_done;
4177                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4178                 _ckvmssts(sys$setast(1));
4179                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4180             }
4181
4182             if (info->out->buf) {
4183                 n = info->out->bufsize * sizeof(char);
4184                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4185             }
4186             n = sizeof(Pipe);
4187             _ckvmssts(lib$free_vm(&n, &info->out));
4188             n = sizeof(Info);
4189             _ckvmssts(lib$free_vm(&n, &info));
4190             *psts = RMS$_FNF;
4191             return Nullfp;
4192         }
4193
4194         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4195         if (info->err) {
4196             info->err->pipe_done = &info->err_done;
4197             info->err_done = FALSE;
4198             info->err->info = info;
4199         }
4200
4201     } else if (*mode == 'w') {      /* piping to subroutine */
4202
4203         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4204         if (info->out) {
4205             info->out->pipe_done = &info->out_done;
4206             info->out_done = FALSE;
4207             info->out->info = info;
4208         }
4209
4210         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4211         if (info->err) {
4212             info->err->pipe_done = &info->err_done;
4213             info->err_done = FALSE;
4214             info->err->info = info;
4215         }
4216
4217         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4218         if (!info->useFILE) {
4219             info->fp  = PerlIO_open(mbx, mode);
4220         } else {
4221             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4222             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4223         }
4224
4225         if (info->in) {
4226             info->in->pipe_done = &info->in_done;
4227             info->in_done = FALSE;
4228             info->in->info = info;
4229         }
4230
4231         /* error cleanup */
4232         if (!info->fp && info->in) {
4233             info->done = TRUE;
4234             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4235                               0, 0, 0, 0, 0, 0, 0, 0));
4236
4237             while (!info->in_done) {
4238                 int done;
4239                 _ckvmssts(sys$setast(0));
4240                 done = info->in_done;
4241                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4242                 _ckvmssts(sys$setast(1));
4243                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4244             }
4245
4246             if (info->in->buf) {
4247                 n = info->in->bufsize * sizeof(char);
4248                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4249             }
4250             n = sizeof(Pipe);
4251             _ckvmssts(lib$free_vm(&n, &info->in));
4252             n = sizeof(Info);
4253             _ckvmssts(lib$free_vm(&n, &info));
4254             *psts = RMS$_FNF;
4255             return Nullfp;
4256         }
4257
4258
4259     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4260         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4261         if (info->out) {
4262             info->out->pipe_done = &info->out_done;
4263             info->out_done = FALSE;
4264             info->out->info = info;
4265         }
4266
4267         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4268         if (info->err) {
4269             info->err->pipe_done = &info->err_done;
4270             info->err_done = FALSE;
4271             info->err->info = info;
4272         }
4273     }
4274
4275     symbol[MAX_DCL_SYMBOL] = '\0';
4276
4277     strncpy(symbol, in, MAX_DCL_SYMBOL);
4278     d_symbol.dsc$w_length = strlen(symbol);
4279     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4280
4281     strncpy(symbol, err, MAX_DCL_SYMBOL);
4282     d_symbol.dsc$w_length = strlen(symbol);
4283     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4284
4285     strncpy(symbol, out, MAX_DCL_SYMBOL);
4286     d_symbol.dsc$w_length = strlen(symbol);
4287     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4288
4289     /* Done with the names for the pipes */
4290     PerlMem_free(err);
4291     PerlMem_free(out);
4292     PerlMem_free(in);
4293
4294     p = vmscmd->dsc$a_pointer;
4295     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4296     if (*p == '$') p++;                         /* remove leading $ */
4297     while (*p == ' ' || *p == '\t') p++;
4298
4299     for (j = 0; j < 4; j++) {
4300         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4301         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4302
4303     strncpy(symbol, p, MAX_DCL_SYMBOL);
4304     d_symbol.dsc$w_length = strlen(symbol);
4305     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4306
4307         if (strlen(p) > MAX_DCL_SYMBOL) {
4308             p += MAX_DCL_SYMBOL;
4309         } else {
4310             p += strlen(p);
4311         }
4312     }
4313     _ckvmssts(sys$setast(0));
4314     info->next=open_pipes;  /* prepend to list */
4315     open_pipes=info;
4316     _ckvmssts(sys$setast(1));
4317     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4318      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4319      * have SYS$COMMAND if we need it.
4320      */
4321     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4322                       0, &info->pid, &info->completion,
4323                       0, popen_completion_ast,info,0,0,0));
4324
4325     /* if we were using a tempfile, close it now */
4326
4327     if (tpipe) fclose(tpipe);
4328
4329     /* once the subprocess is spawned, it has copied the symbols and
4330        we can get rid of ours */
4331
4332     for (j = 0; j < 4; j++) {
4333         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4334         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4335     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4336     }
4337     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4338     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4339     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4340     vms_execfree(vmscmd);
4341
4342 #ifdef PERL_IMPLICIT_CONTEXT
4343     if (aTHX)
4344 #endif
4345     PL_forkprocess = info->pid;
4346
4347     if (wait) {
4348          int done = 0;
4349          while (!done) {
4350              _ckvmssts(sys$setast(0));
4351              done = info->done;
4352              if (!done) _ckvmssts(sys$clref(pipe_ef));
4353              _ckvmssts(sys$setast(1));
4354              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4355          }
4356         *psts = info->completion;
4357 /* Caller thinks it is open and tries to close it. */
4358 /* This causes some problems, as it changes the error status */
4359 /*        my_pclose(info->fp); */
4360     } else {
4361         *psts = SS$_NORMAL;
4362     }
4363     return info->fp;
4364 }  /* end of safe_popen */
4365
4366
4367 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4368 PerlIO *
4369 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4370 {
4371     int sts;
4372     TAINT_ENV();
4373     TAINT_PROPER("popen");
4374     PERL_FLUSHALL_FOR_CHILD;
4375     return safe_popen(aTHX_ cmd,mode,&sts);
4376 }
4377
4378 /*}}}*/
4379
4380 /*{{{  I32 my_pclose(PerlIO *fp)*/
4381 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4382 {
4383     pInfo info, last = NULL;
4384     unsigned long int retsts;
4385     int done, iss, n;
4386     int status;
4387
4388     for (info = open_pipes; info != NULL; last = info, info = info->next)
4389         if (info->fp == fp) break;
4390
4391     if (info == NULL) {  /* no such pipe open */
4392       set_errno(ECHILD); /* quoth POSIX */
4393       set_vaxc_errno(SS$_NONEXPR);
4394       return -1;
4395     }
4396
4397     /* If we were writing to a subprocess, insure that someone reading from
4398      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4399      * produce an EOF record in the mailbox.
4400      *
4401      *  well, at least sometimes it *does*, so we have to watch out for
4402      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4403      */
4404      if (info->fp) {
4405         if (!info->useFILE
4406 #if defined(USE_ITHREADS)
4407           && my_perl
4408 #endif
4409           && PL_perlio_fd_refcnt)
4410             PerlIO_flush(info->fp);
4411         else
4412             fflush((FILE *)info->fp);
4413     }
4414
4415     _ckvmssts(sys$setast(0));
4416      info->closing = TRUE;
4417      done = info->done && info->in_done && info->out_done && info->err_done;
4418      /* hanging on write to Perl's input? cancel it */
4419      if (info->mode == 'r' && info->out && !info->out_done) {
4420         if (info->out->chan_out) {
4421             _ckvmssts(sys$cancel(info->out->chan_out));
4422             if (!info->out->chan_in) {   /* EOF generation, need AST */
4423                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4424             }
4425         }
4426      }
4427      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4428          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4429                            0, 0, 0, 0, 0, 0));
4430     _ckvmssts(sys$setast(1));
4431     if (info->fp) {
4432      if (!info->useFILE
4433 #if defined(USE_ITHREADS)
4434          && my_perl
4435 #endif
4436          && PL_perlio_fd_refcnt)
4437         PerlIO_close(info->fp);
4438      else
4439         fclose((FILE *)info->fp);
4440     }
4441      /*
4442         we have to wait until subprocess completes, but ALSO wait until all
4443         the i/o completes...otherwise we'll be freeing the "info" structure
4444         that the i/o ASTs could still be using...
4445      */
4446
4447      while (!done) {
4448          _ckvmssts(sys$setast(0));
4449          done = info->done && info->in_done && info->out_done && info->err_done;
4450          if (!done) _ckvmssts(sys$clref(pipe_ef));
4451          _ckvmssts(sys$setast(1));
4452          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4453      }
4454      retsts = info->completion;
4455
4456     /* remove from list of open pipes */
4457     _ckvmssts(sys$setast(0));
4458     if (last) last->next = info->next;
4459     else open_pipes = info->next;
4460     _ckvmssts(sys$setast(1));
4461
4462     /* free buffers and structures */
4463
4464     if (info->in) {
4465         if (info->in->buf) {
4466             n = info->in->bufsize * sizeof(char);
4467             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4468         }
4469         n = sizeof(Pipe);
4470         _ckvmssts(lib$free_vm(&n, &info->in));
4471     }
4472     if (info->out) {
4473         if (info->out->buf) {
4474             n = info->out->bufsize * sizeof(char);
4475             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4476         }
4477         n = sizeof(Pipe);
4478         _ckvmssts(lib$free_vm(&n, &info->out));
4479     }
4480     if (info->err) {
4481         if (info->err->buf) {
4482             n = info->err->bufsize * sizeof(char);
4483             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4484         }
4485         n = sizeof(Pipe);
4486         _ckvmssts(lib$free_vm(&n, &info->err));
4487     }
4488     n = sizeof(Info);
4489     _ckvmssts(lib$free_vm(&n, &info));
4490
4491     return retsts;
4492
4493 }  /* end of my_pclose() */
4494
4495 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4496   /* Roll our own prototype because we want this regardless of whether
4497    * _VMS_WAIT is defined.
4498    */
4499   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4500 #endif
4501 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4502    created with popen(); otherwise partially emulate waitpid() unless
4503    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4504    Also check processes not considered by the CRTL waitpid().
4505  */
4506 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4507 Pid_t
4508 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4509 {
4510     pInfo info;
4511     int done;
4512     int sts;
4513     int j;
4514
4515     if (statusp) *statusp = 0;
4516
4517     for (info = open_pipes; info != NULL; info = info->next)
4518         if (info->pid == pid) break;
4519
4520     if (info != NULL) {  /* we know about this child */
4521       while (!info->done) {
4522           _ckvmssts(sys$setast(0));
4523           done = info->done;
4524           if (!done) _ckvmssts(sys$clref(pipe_ef));
4525           _ckvmssts(sys$setast(1));
4526           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4527       }
4528
4529       if (statusp) *statusp = info->completion;
4530       return pid;
4531     }
4532
4533     /* child that already terminated? */
4534
4535     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4536         if (closed_list[j].pid == pid) {
4537             if (statusp) *statusp = closed_list[j].completion;
4538             return pid;
4539         }
4540     }
4541
4542     /* fall through if this child is not one of our own pipe children */
4543
4544 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4545
4546       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4547        * in 7.2 did we get a version that fills in the VMS completion
4548        * status as Perl has always tried to do.
4549        */
4550
4551       sts = __vms_waitpid( pid, statusp, flags );
4552
4553       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4554          return sts;
4555
4556       /* If the real waitpid tells us the child does not exist, we
4557        * fall through here to implement waiting for a child that
4558        * was created by some means other than exec() (say, spawned
4559        * from DCL) or to wait for a process that is not a subprocess
4560        * of the current process.
4561        */
4562
4563 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4564
4565     {
4566       $DESCRIPTOR(intdsc,"0 00:00:01");
4567       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4568       unsigned long int pidcode = JPI$_PID, mypid;
4569       unsigned long int interval[2];
4570       unsigned int jpi_iosb[2];
4571       struct itmlst_3 jpilist[2] = {
4572           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4573           {                      0,         0,                 0, 0}
4574       };
4575
4576       if (pid <= 0) {
4577         /* Sorry folks, we don't presently implement rooting around for
4578            the first child we can find, and we definitely don't want to
4579            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4580          */
4581         set_errno(ENOTSUP);
4582         return -1;
4583       }
4584
4585       /* Get the owner of the child so I can warn if it's not mine. If the
4586        * process doesn't exist or I don't have the privs to look at it,
4587        * I can go home early.
4588        */
4589       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4590       if (sts & 1) sts = jpi_iosb[0];
4591       if (!(sts & 1)) {
4592         switch (sts) {
4593             case SS$_NONEXPR:
4594                 set_errno(ECHILD);
4595                 break;
4596             case SS$_NOPRIV:
4597                 set_errno(EACCES);
4598                 break;
4599             default:
4600                 _ckvmssts(sts);
4601         }
4602         set_vaxc_errno(sts);
4603         return -1;
4604       }
4605
4606       if (ckWARN(WARN_EXEC)) {
4607         /* remind folks they are asking for non-standard waitpid behavior */
4608         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4609         if (ownerpid != mypid)
4610           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4611                       "waitpid: process %x is not a child of process %x",
4612                       pid,mypid);
4613       }
4614
4615       /* simply check on it once a second until it's not there anymore. */
4616
4617       _ckvmssts(sys$bintim(&intdsc,interval));
4618       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4619             _ckvmssts(sys$schdwk(0,0,interval,0));
4620             _ckvmssts(sys$hiber());
4621       }
4622       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4623
4624       _ckvmssts(sts);
4625       return pid;
4626     }
4627 }  /* end of waitpid() */
4628 /*}}}*/
4629 /*}}}*/
4630 /*}}}*/
4631
4632 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4633 char *
4634 my_gconvert(double val, int ndig, int trail, char *buf)
4635 {
4636   static char __gcvtbuf[DBL_DIG+1];
4637   char *loc;
4638
4639   loc = buf ? buf : __gcvtbuf;
4640
4641 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4642   if (val < 1) {
4643     sprintf(loc,"%.*g",ndig,val);
4644     return loc;
4645   }
4646 #endif
4647
4648   if (val) {
4649     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4650     return gcvt(val,ndig,loc);
4651   }
4652   else {
4653     loc[0] = '0'; loc[1] = '\0';
4654     return loc;
4655   }
4656
4657 }
4658 /*}}}*/
4659
4660 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4661 static int rms_free_search_context(struct FAB * fab)
4662 {
4663 struct NAM * nam;
4664
4665     nam = fab->fab$l_nam;
4666     nam->nam$b_nop |= NAM$M_SYNCHK;
4667     nam->nam$l_rlf = NULL;
4668     fab->fab$b_dns = 0;
4669     return sys$parse(fab, NULL, NULL);
4670 }
4671
4672 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4673 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4674 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4675 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4676 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4677 #define rms_nam_esll(nam) nam.nam$b_esl
4678 #define rms_nam_esl(nam) nam.nam$b_esl
4679 #define rms_nam_name(nam) nam.nam$l_name
4680 #define rms_nam_namel(nam) nam.nam$l_name
4681 #define rms_nam_type(nam) nam.nam$l_type
4682 #define rms_nam_typel(nam) nam.nam$l_type
4683 #define rms_nam_ver(nam) nam.nam$l_ver
4684 #define rms_nam_verl(nam) nam.nam$l_ver
4685 #define rms_nam_rsll(nam) nam.nam$b_rsl
4686 #define rms_nam_rsl(nam) nam.nam$b_rsl
4687 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4688 #define rms_set_fna(fab, nam, name, size) \
4689         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4690 #define rms_get_fna(fab, nam) fab.fab$l_fna
4691 #define rms_set_dna(fab, nam, name, size) \
4692         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4693 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4694 #define rms_set_esa(fab, nam, name, size) \
4695         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4696 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4697         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4698 #define rms_set_rsa(nam, name, size) \
4699         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4700 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4701         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4702 #define rms_nam_name_type_l_size(nam) \
4703         (nam.nam$b_name + nam.nam$b_type)
4704 #else
4705 static int rms_free_search_context(struct FAB * fab)
4706 {
4707 struct NAML * nam;
4708
4709     nam = fab->fab$l_naml;
4710     nam->naml$b_nop |= NAM$M_SYNCHK;
4711     nam->naml$l_rlf = NULL;
4712     nam->naml$l_long_defname_size = 0;
4713
4714     fab->fab$b_dns = 0;
4715     return sys$parse(fab, NULL, NULL);
4716 }
4717
4718 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4719 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4720 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4721 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4722 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4723 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4724 #define rms_nam_esl(nam) nam.naml$b_esl
4725 #define rms_nam_name(nam) nam.naml$l_name
4726 #define rms_nam_namel(nam) nam.naml$l_long_name
4727 #define rms_nam_type(nam) nam.naml$l_type
4728 #define rms_nam_typel(nam) nam.naml$l_long_type
4729 #define rms_nam_ver(nam) nam.naml$l_ver
4730 #define rms_nam_verl(nam) nam.naml$l_long_ver
4731 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4732 #define rms_nam_rsl(nam) nam.naml$b_rsl
4733 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4734 #define rms_set_fna(fab, nam, name, size) \
4735         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4736         nam.naml$l_long_filename_size = size; \
4737         nam.naml$l_long_filename = name;}
4738 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4739 #define rms_set_dna(fab, nam, name, size) \
4740         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4741         nam.naml$l_long_defname_size = size; \
4742         nam.naml$l_long_defname = name; }
4743 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4744 #define rms_set_esa(fab, nam, name, size) \
4745         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4746         nam.naml$l_long_expand_alloc = size; \
4747         nam.naml$l_long_expand = name; }
4748 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4749         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4750         nam.naml$l_long_expand = l_name; \
4751         nam.naml$l_long_expand_alloc = l_size; }
4752 #define rms_set_rsa(nam, name, size) \
4753         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4754         nam.naml$l_long_result = name; \
4755         nam.naml$l_long_result_alloc = size; }
4756 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4757         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4758         nam.naml$l_long_result = l_name; \
4759         nam.naml$l_long_result_alloc = l_size; }
4760 #define rms_nam_name_type_l_size(nam) \
4761         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4762 #endif
4763
4764
4765 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4766 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4767  * to expand file specification.  Allows for a single default file
4768  * specification and a simple mask of options.  If outbuf is non-NULL,
4769  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4770  * the resultant file specification is placed.  If outbuf is NULL, the
4771  * resultant file specification is placed into a static buffer.
4772  * The third argument, if non-NULL, is taken to be a default file
4773  * specification string.  The fourth argument is unused at present.
4774  * rmesexpand() returns the address of the resultant string if
4775  * successful, and NULL on error.
4776  *
4777  * New functionality for previously unused opts value:
4778  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4779  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
4780  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4781  */
4782 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4783
4784 static char *
4785 mp_do_rmsexpand
4786    (pTHX_ const char *filespec,
4787     char *outbuf,
4788     int ts,
4789     const char *defspec,
4790     unsigned opts,
4791     int * fs_utf8,
4792     int * dfs_utf8)
4793 {
4794   static char __rmsexpand_retbuf[VMS_MAXRSS];
4795   char * vmsfspec, *tmpfspec;
4796   char * esa, *cp, *out = NULL;
4797   char * tbuf;
4798   char * esal = NULL;
4799   char * outbufl;
4800   struct FAB myfab = cc$rms_fab;
4801   rms_setup_nam(mynam);
4802   STRLEN speclen;
4803   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4804   int sts;
4805
4806   /* temp hack until UTF8 is actually implemented */
4807   if (fs_utf8 != NULL)
4808     *fs_utf8 = 0;
4809
4810   if (!filespec || !*filespec) {
4811     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4812     return NULL;
4813   }
4814   if (!outbuf) {
4815     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4816     else    outbuf = __rmsexpand_retbuf;
4817   }
4818
4819   vmsfspec = NULL;
4820   tmpfspec = NULL;
4821   outbufl = NULL;
4822
4823   isunix = 0;
4824   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4825     isunix = is_unix_filespec(filespec);
4826     if (isunix) {
4827       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4828       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4829       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4830         PerlMem_free(vmsfspec);
4831         if (out)
4832            Safefree(out);
4833         return NULL;
4834       }
4835       filespec = vmsfspec;
4836
4837       /* Unless we are forcing to VMS format, a UNIX input means
4838        * UNIX output, and that requires long names to be used
4839        */
4840       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4841         opts |= PERL_RMSEXPAND_M_LONG;
4842       else {
4843         isunix = 0;
4844       }
4845     }
4846   }
4847
4848   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4849   rms_bind_fab_nam(myfab, mynam);
4850
4851   if (defspec && *defspec) {
4852     int t_isunix;
4853     t_isunix = is_unix_filespec(defspec);
4854     if (t_isunix) {
4855       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4856       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4857       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4858         PerlMem_free(tmpfspec);
4859         if (vmsfspec != NULL)
4860             PerlMem_free(vmsfspec);
4861         if (out)
4862            Safefree(out);
4863         return NULL;
4864       }
4865       defspec = tmpfspec;
4866     }
4867     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4868   }
4869
4870   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4871   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4872 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4873   esal = PerlMem_malloc(VMS_MAXRSS);
4874   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4875 #endif
4876   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4877
4878   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4879     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4880   }
4881   else {
4882 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4883     outbufl = PerlMem_malloc(VMS_MAXRSS);
4884     if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4885     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4886 #else
4887     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4888 #endif
4889   }
4890
4891 #ifdef NAM$M_NO_SHORT_UPCASE
4892   if (decc_efs_case_preserve)
4893     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4894 #endif
4895
4896   /* First attempt to parse as an existing file */
4897   retsts = sys$parse(&myfab,0,0);
4898   if (!(retsts & STS$K_SUCCESS)) {
4899
4900     /* Could not find the file, try as syntax only if error is not fatal */
4901     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4902     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4903       retsts = sys$parse(&myfab,0,0);
4904       if (retsts & STS$K_SUCCESS) goto expanded;
4905     }
4906
4907      /* Still could not parse the file specification */
4908     /*----------------------------------------------*/
4909     sts = rms_free_search_context(&myfab); /* Free search context */
4910     if (out) Safefree(out);
4911     if (tmpfspec != NULL)
4912         PerlMem_free(tmpfspec);
4913     if (vmsfspec != NULL)
4914         PerlMem_free(vmsfspec);
4915     if (outbufl != NULL)
4916         PerlMem_free(outbufl);
4917     PerlMem_free(esa);
4918     if (esal != NULL)
4919         PerlMem_free(esal);
4920     set_vaxc_errno(retsts);
4921     if      (retsts == RMS$_PRV) set_errno(EACCES);
4922     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4923     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4924     else                         set_errno(EVMSERR);
4925     return NULL;
4926   }
4927   retsts = sys$search(&myfab,0,0);
4928   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4929     sts = rms_free_search_context(&myfab); /* Free search context */
4930     if (out) Safefree(out);
4931     if (tmpfspec != NULL)
4932         PerlMem_free(tmpfspec);
4933     if (vmsfspec != NULL)
4934         PerlMem_free(vmsfspec);
4935     if (outbufl != NULL)
4936         PerlMem_free(outbufl);
4937     PerlMem_free(esa);
4938     if (esal != NULL)
4939         PerlMem_free(esal);
4940     set_vaxc_errno(retsts);
4941     if      (retsts == RMS$_PRV) set_errno(EACCES);
4942     else                         set_errno(EVMSERR);
4943     return NULL;
4944   }
4945
4946   /* If the input filespec contained any lowercase characters,
4947    * downcase the result for compatibility with Unix-minded code. */
4948   expanded:
4949   if (!decc_efs_case_preserve) {
4950     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4951       if (islower(*tbuf)) { haslower = 1; break; }
4952   }
4953
4954    /* Is a long or a short name expected */
4955   /*------------------------------------*/
4956   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4957     if (rms_nam_rsll(mynam)) {
4958         tbuf = outbuf;
4959         speclen = rms_nam_rsll(mynam);
4960     }
4961     else {
4962         tbuf = esal; /* Not esa */
4963         speclen = rms_nam_esll(mynam);
4964     }
4965   }
4966   else {
4967     if (rms_nam_rsl(mynam)) {
4968         tbuf = outbuf;
4969         speclen = rms_nam_rsl(mynam);
4970     }
4971     else {
4972         tbuf = esa; /* Not esal */
4973         speclen = rms_nam_esl(mynam);
4974     }
4975   }
4976   tbuf[speclen] = '\0';
4977
4978   /* Trim off null fields added by $PARSE
4979    * If type > 1 char, must have been specified in original or default spec
4980    * (not true for version; $SEARCH may have added version of existing file).
4981    */
4982   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4983   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4984     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4985              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4986   }
4987   else {
4988     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4989              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4990   }
4991   if (trimver || trimtype) {
4992     if (defspec && *defspec) {
4993       char *defesal = NULL;
4994       defesal = PerlMem_malloc(VMS_MAXRSS + 1);
4995       if (defesal != NULL) {
4996         struct FAB deffab = cc$rms_fab;
4997         rms_setup_nam(defnam);
4998
4999         rms_bind_fab_nam(deffab, defnam);
5000
5001         /* Cast ok */
5002         rms_set_fna
5003             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5004
5005         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
5006
5007         rms_clear_nam_nop(defnam);
5008         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5009 #ifdef NAM$M_NO_SHORT_UPCASE
5010         if (decc_efs_case_preserve)
5011           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5012 #endif
5013         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5014           if (trimver) {
5015              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5016           }
5017           if (trimtype) {
5018             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5019           }
5020         }
5021         PerlMem_free(defesal);
5022       }
5023     }
5024     if (trimver) {
5025       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5026         if (*(rms_nam_verl(mynam)) != '\"')
5027           speclen = rms_nam_verl(mynam) - tbuf;
5028       }
5029       else {
5030         if (*(rms_nam_ver(mynam)) != '\"')
5031           speclen = rms_nam_ver(mynam) - tbuf;
5032       }
5033     }
5034     if (trimtype) {
5035       /* If we didn't already trim version, copy down */
5036       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5037         if (speclen > rms_nam_verl(mynam) - tbuf)
5038           memmove
5039            (rms_nam_typel(mynam),
5040             rms_nam_verl(mynam),
5041             speclen - (rms_nam_verl(mynam) - tbuf));
5042           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5043       }
5044       else {
5045         if (speclen > rms_nam_ver(mynam) - tbuf)
5046           memmove
5047            (rms_nam_type(mynam),
5048             rms_nam_ver(mynam),
5049             speclen - (rms_nam_ver(mynam) - tbuf));
5050           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5051       }
5052     }
5053   }
5054
5055    /* Done with these copies of the input files */
5056   /*-------------------------------------------*/
5057   if (vmsfspec != NULL)
5058         PerlMem_free(vmsfspec);
5059   if (tmpfspec != NULL)
5060         PerlMem_free(tmpfspec);
5061
5062   /* If we just had a directory spec on input, $PARSE "helpfully"
5063    * adds an empty name and type for us */
5064   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5065     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5066         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5067         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5068       speclen = rms_nam_namel(mynam) - tbuf;
5069   }
5070   else {
5071     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5072         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5073         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5074       speclen = rms_nam_name(mynam) - tbuf;
5075   }
5076
5077   /* Posix format specifications must have matching quotes */
5078   if (speclen < (VMS_MAXRSS - 1)) {
5079     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5080       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5081         tbuf[speclen] = '\"';
5082         speclen++;
5083       }
5084     }
5085   }
5086   tbuf[speclen] = '\0';
5087   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5088
5089   /* Have we been working with an expanded, but not resultant, spec? */
5090   /* Also, convert back to Unix syntax if necessary. */
5091
5092   if (!rms_nam_rsll(mynam)) {
5093     if (isunix) {
5094       if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
5095         if (out) Safefree(out);
5096         if (esal != NULL)
5097             PerlMem_free(esal);
5098         PerlMem_free(esa);
5099         if (outbufl != NULL)
5100             PerlMem_free(outbufl);
5101         return NULL;
5102       }
5103     }
5104     else strcpy(outbuf,esa);
5105   }
5106   else if (isunix) {
5107     tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5108     if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5109     if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
5110         if (out) Safefree(out);
5111         PerlMem_free(esa);
5112         if (esal != NULL)
5113             PerlMem_free(esal);
5114         PerlMem_free(tmpfspec);
5115         if (outbufl != NULL)
5116             PerlMem_free(outbufl);
5117         return NULL;
5118     }
5119     strcpy(outbuf,tmpfspec);
5120     PerlMem_free(tmpfspec);
5121   }
5122
5123   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5124   sts = rms_free_search_context(&myfab); /* Free search context */
5125   PerlMem_free(esa);
5126   if (esal != NULL)
5127      PerlMem_free(esal);
5128   if (outbufl != NULL)
5129      PerlMem_free(outbufl);
5130   return outbuf;
5131 }
5132 /*}}}*/
5133 /* External entry points */
5134 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5135 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5136 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5137 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5138 char *Perl_rmsexpand_utf8
5139   (pTHX_ const char *spec, char *buf, const char *def,
5140    unsigned opt, int * fs_utf8, int * dfs_utf8)
5141 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5142 char *Perl_rmsexpand_utf8_ts
5143   (pTHX_ const char *spec, char *buf, const char *def,
5144    unsigned opt, int * fs_utf8, int * dfs_utf8)
5145 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5146
5147
5148 /*
5149 ** The following routines are provided to make life easier when
5150 ** converting among VMS-style and Unix-style directory specifications.
5151 ** All will take input specifications in either VMS or Unix syntax. On
5152 ** failure, all return NULL.  If successful, the routines listed below
5153 ** return a pointer to a buffer containing the appropriately
5154 ** reformatted spec (and, therefore, subsequent calls to that routine
5155 ** will clobber the result), while the routines of the same names with
5156 ** a _ts suffix appended will return a pointer to a mallocd string
5157 ** containing the appropriately reformatted spec.
5158 ** In all cases, only explicit syntax is altered; no check is made that
5159 ** the resulting string is valid or that the directory in question
5160 ** actually exists.
5161 **
5162 **   fileify_dirspec() - convert a directory spec into the name of the
5163 **     directory file (i.e. what you can stat() to see if it's a dir).
5164 **     The style (VMS or Unix) of the result is the same as the style
5165 **     of the parameter passed in.
5166 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5167 **     what you prepend to a filename to indicate what directory it's in).
5168 **     The style (VMS or Unix) of the result is the same as the style
5169 **     of the parameter passed in.
5170 **   tounixpath() - convert a directory spec into a Unix-style path.
5171 **   tovmspath() - convert a directory spec into a VMS-style path.
5172 **   tounixspec() - convert any file spec into a Unix-style file spec.
5173 **   tovmsspec() - convert any file spec into a VMS-style spec.
5174 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5175 **
5176 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5177 ** Permission is given to distribute this code as part of the Perl
5178 ** standard distribution under the terms of the GNU General Public
5179 ** License or the Perl Artistic License.  Copies of each may be
5180 ** found in the Perl standard distribution.
5181  */
5182
5183 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5184 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5185 {
5186     static char __fileify_retbuf[VMS_MAXRSS];
5187     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5188     char *retspec, *cp1, *cp2, *lastdir;
5189     char *trndir, *vmsdir;
5190     unsigned short int trnlnm_iter_count;
5191     int sts;
5192     if (utf8_fl != NULL)
5193         *utf8_fl = 0;
5194
5195     if (!dir || !*dir) {
5196       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5197     }
5198     dirlen = strlen(dir);
5199     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5200     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5201       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5202         dir = "/sys$disk";
5203         dirlen = 9;
5204       }
5205       else
5206         dirlen = 1;
5207     }
5208     if (dirlen > (VMS_MAXRSS - 1)) {
5209       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5210       return NULL;
5211     }
5212     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5213     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5214     if (!strpbrk(dir+1,"/]>:")  &&
5215         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5216       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5217       trnlnm_iter_count = 0;
5218       while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5219         trnlnm_iter_count++;
5220         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5221       }
5222       dirlen = strlen(trndir);
5223     }
5224     else {
5225       strncpy(trndir,dir,dirlen);
5226       trndir[dirlen] = '\0';
5227     }
5228
5229     /* At this point we are done with *dir and use *trndir which is a
5230      * copy that can be modified.  *dir must not be modified.
5231      */
5232
5233     /* If we were handed a rooted logical name or spec, treat it like a
5234      * simple directory, so that
5235      *    $ Define myroot dev:[dir.]
5236      *    ... do_fileify_dirspec("myroot",buf,1) ...
5237      * does something useful.
5238      */
5239     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5240       trndir[--dirlen] = '\0';
5241       trndir[dirlen-1] = ']';
5242     }
5243     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5244       trndir[--dirlen] = '\0';
5245       trndir[dirlen-1] = '>';
5246     }
5247
5248     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5249       /* If we've got an explicit filename, we can just shuffle the string. */
5250       if (*(cp1+1)) hasfilename = 1;
5251       /* Similarly, we can just back up a level if we've got multiple levels
5252          of explicit directories in a VMS spec which ends with directories. */
5253       else {
5254         for (cp2 = cp1; cp2 > trndir; cp2--) {
5255           if (*cp2 == '.') {
5256             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5257 /* fix-me, can not scan EFS file specs backward like this */
5258               *cp2 = *cp1; *cp1 = '\0';
5259               hasfilename = 1;
5260               break;
5261             }
5262           }
5263           if (*cp2 == '[' || *cp2 == '<') break;
5264         }
5265       }
5266     }
5267
5268     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5269     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5270     cp1 = strpbrk(trndir,"]:>");
5271     if (hasfilename || !cp1) { /* Unix-style path or filename */
5272       if (trndir[0] == '.') {
5273         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5274           PerlMem_free(trndir);
5275           PerlMem_free(vmsdir);
5276           return do_fileify_dirspec("[]",buf,ts,NULL);
5277         }
5278         else if (trndir[1] == '.' &&
5279                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5280           PerlMem_free(trndir);
5281           PerlMem_free(vmsdir);
5282           return do_fileify_dirspec("[-]",buf,ts,NULL);
5283         }
5284       }
5285       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5286         dirlen -= 1;                 /* to last element */
5287         lastdir = strrchr(trndir,'/');
5288       }
5289       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5290         /* If we have "/." or "/..", VMSify it and let the VMS code
5291          * below expand it, rather than repeating the code to handle
5292          * relative components of a filespec here */
5293         do {
5294           if (*(cp1+2) == '.') cp1++;
5295           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5296             char * ret_chr;
5297             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5298                 PerlMem_free(trndir);
5299                 PerlMem_free(vmsdir);
5300                 return NULL;
5301             }
5302             if (strchr(vmsdir,'/') != NULL) {
5303               /* If do_tovmsspec() returned it, it must have VMS syntax
5304                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5305                * the time to check this here only so we avoid a recursion
5306                * loop; otherwise, gigo.
5307                */
5308               PerlMem_free(trndir);
5309               PerlMem_free(vmsdir);
5310               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5311               return NULL;
5312             }
5313             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5314                 PerlMem_free(trndir);
5315                 PerlMem_free(vmsdir);
5316                 return NULL;
5317             }
5318             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5319             PerlMem_free(trndir);
5320             PerlMem_free(vmsdir);
5321             return ret_chr;
5322           }
5323           cp1++;
5324         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5325         lastdir = strrchr(trndir,'/');
5326       }
5327       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5328         char * ret_chr;
5329         /* Ditto for specs that end in an MFD -- let the VMS code
5330          * figure out whether it's a real device or a rooted logical. */
5331
5332         /* This should not happen any more.  Allowing the fake /000000
5333          * in a UNIX pathname causes all sorts of problems when trying
5334          * to run in UNIX emulation.  So the VMS to UNIX conversions
5335          * now remove the fake /000000 directories.
5336          */
5337
5338         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5339         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5340             PerlMem_free(trndir);
5341             PerlMem_free(vmsdir);
5342             return NULL;
5343         }
5344         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5345             PerlMem_free(trndir);
5346             PerlMem_free(vmsdir);
5347             return NULL;
5348         }
5349         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5350         PerlMem_free(trndir);
5351         PerlMem_free(vmsdir);
5352         return ret_chr;
5353       }
5354       else {
5355
5356         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5357              !(lastdir = cp1 = strrchr(trndir,']')) &&
5358              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5359         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5360           int ver; char *cp3;
5361
5362           /* For EFS or ODS-5 look for the last dot */
5363           if (decc_efs_charset) {
5364               cp2 = strrchr(cp1,'.');
5365           }
5366           if (vms_process_case_tolerant) {
5367               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5368                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5369                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5370                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5371                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5372                             (ver || *cp3)))))) {
5373                   PerlMem_free(trndir);
5374                   PerlMem_free(vmsdir);
5375                   set_errno(ENOTDIR);
5376                   set_vaxc_errno(RMS$_DIR);
5377                   return NULL;
5378               }
5379           }
5380           else {
5381               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5382                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5383                   !*(cp2+3) || *(cp2+3) != 'R' ||
5384                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5385                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5386                             (ver || *cp3)))))) {
5387                  PerlMem_free(trndir);
5388                  PerlMem_free(vmsdir);
5389                  set_errno(ENOTDIR);
5390                  set_vaxc_errno(RMS$_DIR);
5391                  return NULL;
5392               }
5393           }
5394           dirlen = cp2 - trndir;
5395         }
5396       }
5397
5398       retlen = dirlen + 6;
5399       if (buf) retspec = buf;
5400       else if (ts) Newx(retspec,retlen+1,char);
5401       else retspec = __fileify_retbuf;
5402       memcpy(retspec,trndir,dirlen);
5403       retspec[dirlen] = '\0';
5404
5405       /* We've picked up everything up to the directory file name.
5406          Now just add the type and version, and we're set. */
5407       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5408         strcat(retspec,".dir;1");
5409       else
5410         strcat(retspec,".DIR;1");
5411       PerlMem_free(trndir);
5412       PerlMem_free(vmsdir);
5413       return retspec;
5414     }
5415     else {  /* VMS-style directory spec */
5416
5417       char *esa, term, *cp;
5418       unsigned long int sts, cmplen, haslower = 0;
5419       unsigned int nam_fnb;
5420       char * nam_type;
5421       struct FAB dirfab = cc$rms_fab;
5422       rms_setup_nam(savnam);
5423       rms_setup_nam(dirnam);
5424
5425       esa = PerlMem_malloc(VMS_MAXRSS + 1);
5426       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5427       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5428       rms_bind_fab_nam(dirfab, dirnam);
5429       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5430       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5431 #ifdef NAM$M_NO_SHORT_UPCASE
5432       if (decc_efs_case_preserve)
5433         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5434 #endif
5435
5436       for (cp = trndir; *cp; cp++)
5437         if (islower(*cp)) { haslower = 1; break; }
5438       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5439         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5440           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5441           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5442         }
5443         if (!sts) {
5444           PerlMem_free(esa);
5445           PerlMem_free(trndir);
5446           PerlMem_free(vmsdir);
5447           set_errno(EVMSERR);
5448           set_vaxc_errno(dirfab.fab$l_sts);
5449           return NULL;
5450         }
5451       }
5452       else {
5453         savnam = dirnam;
5454         /* Does the file really exist? */
5455         if (sys$search(&dirfab)& STS$K_SUCCESS) {
5456           /* Yes; fake the fnb bits so we'll check type below */
5457         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5458         }
5459         else { /* No; just work with potential name */
5460           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5461           else {
5462             int fab_sts;
5463             fab_sts = dirfab.fab$l_sts;
5464             sts = rms_free_search_context(&dirfab);
5465             PerlMem_free(esa);
5466             PerlMem_free(trndir);
5467             PerlMem_free(vmsdir);
5468             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
5469             return NULL;
5470           }
5471         }
5472       }
5473       esa[rms_nam_esll(dirnam)] = '\0';
5474       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5475         cp1 = strchr(esa,']');
5476         if (!cp1) cp1 = strchr(esa,'>');
5477         if (cp1) {  /* Should always be true */
5478           rms_nam_esll(dirnam) -= cp1 - esa - 1;
5479           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5480         }
5481       }
5482       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5483         /* Yep; check version while we're at it, if it's there. */
5484         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5485         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5486           /* Something other than .DIR[;1].  Bzzt. */
5487           sts = rms_free_search_context(&dirfab);
5488           PerlMem_free(esa);
5489           PerlMem_free(trndir);
5490           PerlMem_free(vmsdir);
5491           set_errno(ENOTDIR);
5492           set_vaxc_errno(RMS$_DIR);
5493           return NULL;
5494         }
5495       }
5496
5497       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5498         /* They provided at least the name; we added the type, if necessary, */
5499         if (buf) retspec = buf;                            /* in sys$parse() */
5500         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5501         else retspec = __fileify_retbuf;
5502         strcpy(retspec,esa);
5503         sts = rms_free_search_context(&dirfab);
5504         PerlMem_free(trndir);
5505         PerlMem_free(esa);
5506         PerlMem_free(vmsdir);
5507         return retspec;
5508       }
5509       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5510         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5511         *cp1 = '\0';
5512         rms_nam_esll(dirnam) -= 9;
5513       }
5514       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5515       if (cp1 == NULL) { /* should never happen */
5516         sts = rms_free_search_context(&dirfab);
5517         PerlMem_free(trndir);
5518         PerlMem_free(esa);
5519         PerlMem_free(vmsdir);
5520         return NULL;
5521       }
5522       term = *cp1;
5523       *cp1 = '\0';
5524       retlen = strlen(esa);
5525       cp1 = strrchr(esa,'.');
5526       /* ODS-5 directory specifications can have extra "." in them. */
5527       /* Fix-me, can not scan EFS file specifications backwards */
5528       while (cp1 != NULL) {
5529         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5530           break;
5531         else {
5532            cp1--;
5533            while ((cp1 > esa) && (*cp1 != '.'))
5534              cp1--;
5535         }
5536         if (cp1 == esa)
5537           cp1 = NULL;
5538       }
5539
5540       if ((cp1) != NULL) {
5541         /* There's more than one directory in the path.  Just roll back. */
5542         *cp1 = term;
5543         if (buf) retspec = buf;
5544         else if (ts) Newx(retspec,retlen+7,char);
5545         else retspec = __fileify_retbuf;
5546         strcpy(retspec,esa);
5547       }
5548       else {
5549         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5550           /* Go back and expand rooted logical name */
5551           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5552 #ifdef NAM$M_NO_SHORT_UPCASE
5553           if (decc_efs_case_preserve)
5554             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5555 #endif
5556           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5557             sts = rms_free_search_context(&dirfab);
5558             PerlMem_free(esa);
5559             PerlMem_free(trndir);
5560             PerlMem_free(vmsdir);
5561             set_errno(EVMSERR);
5562             set_vaxc_errno(dirfab.fab$l_sts);
5563             return NULL;
5564           }
5565           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5566           if (buf) retspec = buf;
5567           else if (ts) Newx(retspec,retlen+16,char);
5568           else retspec = __fileify_retbuf;
5569           cp1 = strstr(esa,"][");
5570           if (!cp1) cp1 = strstr(esa,"]<");
5571           dirlen = cp1 - esa;
5572           memcpy(retspec,esa,dirlen);
5573           if (!strncmp(cp1+2,"000000]",7)) {
5574             retspec[dirlen-1] = '\0';
5575             /* fix-me Not full ODS-5, just extra dots in directories for now */
5576             cp1 = retspec + dirlen - 1;
5577             while (cp1 > retspec)
5578             {
5579               if (*cp1 == '[')
5580                 break;
5581               if (*cp1 == '.') {
5582                 if (*(cp1-1) != '^')
5583                   break;
5584               }
5585               cp1--;
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           else {
5594             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5595             retspec[retlen] = '\0';
5596             /* Convert last '.' to ']' */
5597             cp1 = retspec+retlen-1;
5598             while (*cp != '[') {
5599               cp1--;
5600               if (*cp1 == '.') {
5601                 /* Do not trip on extra dots in ODS-5 directories */
5602                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5603                 break;
5604               }
5605             }
5606             if (*cp1 == '.') *cp1 = ']';
5607             else {
5608               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5609               memmove(cp1+1,"000000]",7);
5610             }
5611           }
5612         }
5613         else {  /* This is a top-level dir.  Add the MFD to the path. */
5614           if (buf) retspec = buf;
5615           else if (ts) Newx(retspec,retlen+16,char);
5616           else retspec = __fileify_retbuf;
5617           cp1 = esa;
5618           cp2 = retspec;
5619           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5620           strcpy(cp2,":[000000]");
5621           cp1 += 2;
5622           strcpy(cp2+9,cp1);
5623         }
5624       }
5625       sts = rms_free_search_context(&dirfab);
5626       /* We've set up the string up through the filename.  Add the
5627          type and version, and we're done. */
5628       strcat(retspec,".DIR;1");
5629
5630       /* $PARSE may have upcased filespec, so convert output to lower
5631        * case if input contained any lowercase characters. */
5632       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5633       PerlMem_free(trndir);
5634       PerlMem_free(esa);
5635       PerlMem_free(vmsdir);
5636       return retspec;
5637     }
5638 }  /* end of do_fileify_dirspec() */
5639 /*}}}*/
5640 /* External entry points */
5641 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5642 { return do_fileify_dirspec(dir,buf,0,NULL); }
5643 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5644 { return do_fileify_dirspec(dir,buf,1,NULL); }
5645 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5646 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5647 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5648 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5649
5650 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5651 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5652 {
5653     static char __pathify_retbuf[VMS_MAXRSS];
5654     unsigned long int retlen;
5655     char *retpath, *cp1, *cp2, *trndir;
5656     unsigned short int trnlnm_iter_count;
5657     STRLEN trnlen;
5658     int sts;
5659     if (utf8_fl != NULL)
5660         *utf8_fl = 0;
5661
5662     if (!dir || !*dir) {
5663       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5664     }
5665
5666     trndir = PerlMem_malloc(VMS_MAXRSS);
5667     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5668     if (*dir) strcpy(trndir,dir);
5669     else getcwd(trndir,VMS_MAXRSS - 1);
5670
5671     trnlnm_iter_count = 0;
5672     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5673            && my_trnlnm(trndir,trndir,0)) {
5674       trnlnm_iter_count++;
5675       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5676       trnlen = strlen(trndir);
5677
5678       /* Trap simple rooted lnms, and return lnm:[000000] */
5679       if (!strcmp(trndir+trnlen-2,".]")) {
5680         if (buf) retpath = buf;
5681         else if (ts) Newx(retpath,strlen(dir)+10,char);
5682         else retpath = __pathify_retbuf;
5683         strcpy(retpath,dir);
5684         strcat(retpath,":[000000]");
5685         PerlMem_free(trndir);
5686         return retpath;
5687       }
5688     }
5689
5690     /* At this point we do not work with *dir, but the copy in
5691      * *trndir that is modifiable.
5692      */
5693
5694     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5695       if (*trndir == '.' && (*(trndir+1) == '\0' ||
5696                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5697         retlen = 2 + (*(trndir+1) != '\0');
5698       else {
5699         if ( !(cp1 = strrchr(trndir,'/')) &&
5700              !(cp1 = strrchr(trndir,']')) &&
5701              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5702         if ((cp2 = strchr(cp1,'.')) != NULL &&
5703             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
5704              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
5705               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5706               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5707           int ver; char *cp3;
5708
5709           /* For EFS or ODS-5 look for the last dot */
5710           if (decc_efs_charset) {
5711             cp2 = strrchr(cp1,'.');
5712           }
5713           if (vms_process_case_tolerant) {
5714               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5715                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5716                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5717                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5718                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5719                             (ver || *cp3)))))) {
5720                 PerlMem_free(trndir);
5721                 set_errno(ENOTDIR);
5722                 set_vaxc_errno(RMS$_DIR);
5723                 return NULL;
5724               }
5725           }
5726           else {
5727               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5728                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5729                   !*(cp2+3) || *(cp2+3) != 'R' ||
5730                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5731                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5732                             (ver || *cp3)))))) {
5733                 PerlMem_free(trndir);
5734                 set_errno(ENOTDIR);
5735                 set_vaxc_errno(RMS$_DIR);
5736                 return NULL;
5737               }
5738           }
5739           retlen = cp2 - trndir + 1;
5740         }
5741         else {  /* No file type present.  Treat the filename as a directory. */
5742           retlen = strlen(trndir) + 1;
5743         }
5744       }
5745       if (buf) retpath = buf;
5746       else if (ts) Newx(retpath,retlen+1,char);
5747       else retpath = __pathify_retbuf;
5748       strncpy(retpath, trndir, retlen-1);
5749       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5750         retpath[retlen-1] = '/';      /* with '/', add it. */
5751         retpath[retlen] = '\0';
5752       }
5753       else retpath[retlen-1] = '\0';
5754     }
5755     else {  /* VMS-style directory spec */
5756       char *esa, *cp;
5757       unsigned long int sts, cmplen, haslower;
5758       struct FAB dirfab = cc$rms_fab;
5759       int dirlen;
5760       rms_setup_nam(savnam);
5761       rms_setup_nam(dirnam);
5762
5763       /* If we've got an explicit filename, we can just shuffle the string. */
5764       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5765              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
5766         if ((cp2 = strchr(cp1,'.')) != NULL) {
5767           int ver; char *cp3;
5768           if (vms_process_case_tolerant) {
5769               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5770                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5771                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5772                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5773                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5774                             (ver || *cp3)))))) {
5775                PerlMem_free(trndir);
5776                set_errno(ENOTDIR);
5777                set_vaxc_errno(RMS$_DIR);
5778                return NULL;
5779              }
5780           }
5781           else {
5782               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5783                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5784                   !*(cp2+3) || *(cp2+3) != 'R' ||
5785                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5786                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5787                             (ver || *cp3)))))) {
5788                PerlMem_free(trndir);
5789                set_errno(ENOTDIR);
5790                set_vaxc_errno(RMS$_DIR);
5791                return NULL;
5792              }
5793           }
5794         }
5795         else {  /* No file type, so just draw name into directory part */
5796           for (cp2 = cp1; *cp2; cp2++) ;
5797         }
5798         *cp2 = *cp1;
5799         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5800         *cp1 = '.';
5801         /* We've now got a VMS 'path'; fall through */
5802       }
5803
5804       dirlen = strlen(trndir);
5805       if (trndir[dirlen-1] == ']' ||
5806           trndir[dirlen-1] == '>' ||
5807           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5808         if (buf) retpath = buf;
5809         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5810         else retpath = __pathify_retbuf;
5811         strcpy(retpath,trndir);
5812         PerlMem_free(trndir);
5813         return retpath;
5814       }
5815       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5816       esa = PerlMem_malloc(VMS_MAXRSS);
5817       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5818       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5819       rms_bind_fab_nam(dirfab, dirnam);
5820       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5821 #ifdef NAM$M_NO_SHORT_UPCASE
5822       if (decc_efs_case_preserve)
5823           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5824 #endif
5825
5826       for (cp = trndir; *cp; cp++)
5827         if (islower(*cp)) { haslower = 1; break; }
5828
5829       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5830         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5831           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5832           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5833         }
5834         if (!sts) {
5835           PerlMem_free(trndir);
5836           PerlMem_free(esa);
5837           set_errno(EVMSERR);
5838           set_vaxc_errno(dirfab.fab$l_sts);
5839           return NULL;
5840         }
5841       }
5842       else {
5843         savnam = dirnam;
5844         /* Does the file really exist? */
5845         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5846           if (dirfab.fab$l_sts != RMS$_FNF) {
5847             int sts1;
5848             sts1 = rms_free_search_context(&dirfab);
5849             PerlMem_free(trndir);
5850             PerlMem_free(esa);
5851             set_errno(EVMSERR);
5852             set_vaxc_errno(dirfab.fab$l_sts);
5853             return NULL;
5854           }
5855           dirnam = savnam; /* No; just work with potential name */
5856         }
5857       }
5858       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5859         /* Yep; check version while we're at it, if it's there. */
5860         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5861         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5862           int sts2;
5863           /* Something other than .DIR[;1].  Bzzt. */
5864           sts2 = rms_free_search_context(&dirfab);
5865           PerlMem_free(trndir);
5866           PerlMem_free(esa);
5867           set_errno(ENOTDIR);
5868           set_vaxc_errno(RMS$_DIR);
5869           return NULL;
5870         }
5871       }
5872       /* OK, the type was fine.  Now pull any file name into the
5873          directory path. */
5874       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5875       else {
5876         cp1 = strrchr(esa,'>');
5877         *(rms_nam_typel(dirnam)) = '>';
5878       }
5879       *cp1 = '.';
5880       *(rms_nam_typel(dirnam) + 1) = '\0';
5881       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5882       if (buf) retpath = buf;
5883       else if (ts) Newx(retpath,retlen,char);
5884       else retpath = __pathify_retbuf;
5885       strcpy(retpath,esa);
5886       PerlMem_free(esa);
5887       sts = rms_free_search_context(&dirfab);
5888       /* $PARSE may have upcased filespec, so convert output to lower
5889        * case if input contained any lowercase characters. */
5890       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5891     }
5892
5893     PerlMem_free(trndir);
5894     return retpath;
5895 }  /* end of do_pathify_dirspec() */
5896 /*}}}*/
5897 /* External entry points */
5898 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5899 { return do_pathify_dirspec(dir,buf,0,NULL); }
5900 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5901 { return do_pathify_dirspec(dir,buf,1,NULL); }
5902 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5903 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5904 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5905 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5906
5907 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5908 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5909 {
5910   static char __tounixspec_retbuf[VMS_MAXRSS];
5911   char *dirend, *rslt, *cp1, *cp3, *tmp;
5912   const char *cp2;
5913   int devlen, dirlen, retlen = VMS_MAXRSS;
5914   int expand = 1; /* guarantee room for leading and trailing slashes */
5915   unsigned short int trnlnm_iter_count;
5916   int cmp_rslt;
5917   if (utf8_fl != NULL)
5918     *utf8_fl = 0;
5919
5920   if (spec == NULL) return NULL;
5921   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5922   if (buf) rslt = buf;
5923   else if (ts) {
5924     Newx(rslt, VMS_MAXRSS, char);
5925   }
5926   else rslt = __tounixspec_retbuf;
5927
5928   /* New VMS specific format needs translation
5929    * glob passes filenames with trailing '\n' and expects this preserved.
5930    */
5931   if (decc_posix_compliant_pathnames) {
5932     if (strncmp(spec, "\"^UP^", 5) == 0) {
5933       char * uspec;
5934       char *tunix;
5935       int tunix_len;
5936       int nl_flag;
5937
5938       tunix = PerlMem_malloc(VMS_MAXRSS);
5939       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5940       strcpy(tunix, spec);
5941       tunix_len = strlen(tunix);
5942       nl_flag = 0;
5943       if (tunix[tunix_len - 1] == '\n') {
5944         tunix[tunix_len - 1] = '\"';
5945         tunix[tunix_len] = '\0';
5946         tunix_len--;
5947         nl_flag = 1;
5948       }
5949       uspec = decc$translate_vms(tunix);
5950       PerlMem_free(tunix);
5951       if ((int)uspec > 0) {
5952         strcpy(rslt,uspec);
5953         if (nl_flag) {
5954           strcat(rslt,"\n");
5955         }
5956         else {
5957           /* If we can not translate it, makemaker wants as-is */
5958           strcpy(rslt, spec);
5959         }
5960         return rslt;
5961       }
5962     }
5963   }
5964
5965   cmp_rslt = 0; /* Presume VMS */
5966   cp1 = strchr(spec, '/');
5967   if (cp1 == NULL)
5968     cmp_rslt = 0;
5969
5970     /* Look for EFS ^/ */
5971     if (decc_efs_charset) {
5972       while (cp1 != NULL) {
5973         cp2 = cp1 - 1;
5974         if (*cp2 != '^') {
5975           /* Found illegal VMS, assume UNIX */
5976           cmp_rslt = 1;
5977           break;
5978         }
5979       cp1++;
5980       cp1 = strchr(cp1, '/');
5981     }
5982   }
5983
5984   /* Look for "." and ".." */
5985   if (decc_filename_unix_report) {
5986     if (spec[0] == '.') {
5987       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5988         cmp_rslt = 1;
5989       }
5990       else {
5991         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5992           cmp_rslt = 1;
5993         }
5994       }
5995     }
5996   }
5997   /* This is already UNIX or at least nothing VMS understands */
5998   if (cmp_rslt) {
5999     strcpy(rslt,spec);
6000     return rslt;
6001   }
6002
6003   cp1 = rslt;
6004   cp2 = spec;
6005   dirend = strrchr(spec,']');
6006   if (dirend == NULL) dirend = strrchr(spec,'>');
6007   if (dirend == NULL) dirend = strchr(spec,':');
6008   if (dirend == NULL) {
6009     strcpy(rslt,spec);
6010     return rslt;
6011   }
6012
6013   /* Special case 1 - sys$posix_root = / */
6014 #if __CRTL_VER >= 70000000
6015   if (!decc_disable_posix_root) {
6016     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6017       *cp1 = '/';
6018       cp1++;
6019       cp2 = cp2 + 15;
6020       }
6021   }
6022 #endif
6023
6024   /* Special case 2 - Convert NLA0: to /dev/null */
6025 #if __CRTL_VER < 70000000
6026   cmp_rslt = strncmp(spec,"NLA0:", 5);
6027   if (cmp_rslt != 0)
6028      cmp_rslt = strncmp(spec,"nla0:", 5);
6029 #else
6030   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6031 #endif
6032   if (cmp_rslt == 0) {
6033     strcpy(rslt, "/dev/null");
6034     cp1 = cp1 + 9;
6035     cp2 = cp2 + 5;
6036     if (spec[6] != '\0') {
6037       cp1[9] == '/';
6038       cp1++;
6039       cp2++;
6040     }
6041   }
6042
6043    /* Also handle special case "SYS$SCRATCH:" */
6044 #if __CRTL_VER < 70000000
6045   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6046   if (cmp_rslt != 0)
6047      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6048 #else
6049   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6050 #endif
6051   tmp = PerlMem_malloc(VMS_MAXRSS);
6052   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6053   if (cmp_rslt == 0) {
6054   int islnm;
6055
6056     islnm = my_trnlnm(tmp, "TMP", 0);
6057     if (!islnm) {
6058       strcpy(rslt, "/tmp");
6059       cp1 = cp1 + 4;
6060       cp2 = cp2 + 12;
6061       if (spec[12] != '\0') {
6062         cp1[4] == '/';
6063         cp1++;
6064         cp2++;
6065       }
6066     }
6067   }
6068
6069   if (*cp2 != '[' && *cp2 != '<') {
6070     *(cp1++) = '/';
6071   }
6072   else {  /* the VMS spec begins with directories */
6073     cp2++;
6074     if (*cp2 == ']' || *cp2 == '>') {
6075       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6076       PerlMem_free(tmp);
6077       return rslt;
6078     }
6079     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6080       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6081         if (ts) Safefree(rslt);
6082         PerlMem_free(tmp);
6083         return NULL;
6084       }
6085       trnlnm_iter_count = 0;
6086       do {
6087         cp3 = tmp;
6088         while (*cp3 != ':' && *cp3) cp3++;
6089         *(cp3++) = '\0';
6090         if (strchr(cp3,']') != NULL) break;
6091         trnlnm_iter_count++;
6092         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6093       } while (vmstrnenv(tmp,tmp,0,fildev,0));
6094       if (ts && !buf &&
6095           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6096         retlen = devlen + dirlen;
6097         Renew(rslt,retlen+1+2*expand,char);
6098         cp1 = rslt;
6099       }
6100       cp3 = tmp;
6101       *(cp1++) = '/';
6102       while (*cp3) {
6103         *(cp1++) = *(cp3++);
6104         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6105             PerlMem_free(tmp);
6106             return NULL; /* No room */
6107         }
6108       }
6109       *(cp1++) = '/';
6110     }
6111     if ((*cp2 == '^')) {
6112         /* EFS file escape, pass the next character as is */
6113         /* Fix me: HEX encoding for Unicode not implemented */
6114         cp2++;
6115     }
6116     else if ( *cp2 == '.') {
6117       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6118         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6119         cp2 += 3;
6120       }
6121       else cp2++;
6122     }
6123   }
6124   PerlMem_free(tmp);
6125   for (; cp2 <= dirend; cp2++) {
6126     if ((*cp2 == '^')) {
6127         /* EFS file escape, pass the next character as is */
6128         /* Fix me: HEX encoding for Unicode not implemented */
6129         *(cp1++) = *(++cp2);
6130         /* An escaped dot stays as is -- don't convert to slash */
6131         if (*cp2 == '.') cp2++;
6132     }
6133     if (*cp2 == ':') {
6134       *(cp1++) = '/';
6135       if (*(cp2+1) == '[') cp2++;
6136     }
6137     else if (*cp2 == ']' || *cp2 == '>') {
6138       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6139     }
6140     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6141       *(cp1++) = '/';
6142       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6143         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6144                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6145         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6146             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6147       }
6148       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6149         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6150         cp2 += 2;
6151       }
6152     }
6153     else if (*cp2 == '-') {
6154       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6155         while (*cp2 == '-') {
6156           cp2++;
6157           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6158         }
6159         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6160           if (ts) Safefree(rslt);                        /* filespecs like */
6161           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
6162           return NULL;
6163         }
6164       }
6165       else *(cp1++) = *cp2;
6166     }
6167     else *(cp1++) = *cp2;
6168   }
6169   while (*cp2) {
6170     if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++;  /* '^.' --> '.' */
6171     *(cp1++) = *(cp2++);
6172   }
6173   *cp1 = '\0';
6174
6175   /* This still leaves /000000/ when working with a
6176    * VMS device root or concealed root.
6177    */
6178   {
6179   int ulen;
6180   char * zeros;
6181
6182       ulen = strlen(rslt);
6183
6184       /* Get rid of "000000/ in rooted filespecs */
6185       if (ulen > 7) {
6186         zeros = strstr(rslt, "/000000/");
6187         if (zeros != NULL) {
6188           int mlen;
6189           mlen = ulen - (zeros - rslt) - 7;
6190           memmove(zeros, &zeros[7], mlen);
6191           ulen = ulen - 7;
6192           rslt[ulen] = '\0';
6193         }
6194       }
6195   }
6196
6197   return rslt;
6198
6199 }  /* end of do_tounixspec() */
6200 /*}}}*/
6201 /* External entry points */
6202 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6203   { return do_tounixspec(spec,buf,0, NULL); }
6204 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6205   { return do_tounixspec(spec,buf,1, NULL); }
6206 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6207   { return do_tounixspec(spec,buf,0, utf8_fl); }
6208 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6209   { return do_tounixspec(spec,buf,1, utf8_fl); }
6210
6211 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6212
6213 /*
6214  This procedure is used to identify if a path is based in either
6215  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6216  it returns the OpenVMS format directory for it.
6217
6218  It is expecting specifications of only '/' or '/xxxx/'
6219
6220  If a posix root does not exist, or 'xxxx' is not a directory
6221  in the posix root, it returns a failure.
6222
6223  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6224
6225  It is used only internally by posix_to_vmsspec_hardway().
6226  */
6227
6228 static int posix_root_to_vms
6229   (char *vmspath, int vmspath_len,
6230    const char *unixpath,
6231    const int * utf8_fl) {
6232 int sts;
6233 struct FAB myfab = cc$rms_fab;
6234 struct NAML mynam = cc$rms_naml;
6235 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6236  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6237 char *esa;
6238 char *vms_delim;
6239 int dir_flag;
6240 int unixlen;
6241
6242     dir_flag = 0;
6243     unixlen = strlen(unixpath);
6244     if (unixlen == 0) {
6245       vmspath[0] = '\0';
6246       return RMS$_FNF;
6247     }
6248
6249 #if __CRTL_VER >= 80200000
6250   /* If not a posix spec already, convert it */
6251   if (decc_posix_compliant_pathnames) {
6252     if (strncmp(unixpath,"\"^UP^",5) != 0) {
6253       sprintf(vmspath,"\"^UP^%s\"",unixpath);
6254     }
6255     else {
6256       /* This is already a VMS specification, no conversion */
6257       unixlen--;
6258       strncpy(vmspath,unixpath, vmspath_len);
6259     }
6260   }
6261   else
6262 #endif
6263   {
6264   int path_len;
6265   int i,j;
6266
6267      /* Check to see if this is under the POSIX root */
6268      if (decc_disable_posix_root) {
6269         return RMS$_FNF;
6270      }
6271
6272      /* Skip leading / */
6273      if (unixpath[0] == '/') {
6274         unixpath++;
6275         unixlen--;
6276      }
6277
6278
6279      strcpy(vmspath,"SYS$POSIX_ROOT:");
6280
6281      /* If this is only the / , or blank, then... */
6282      if (unixpath[0] == '\0') {
6283         /* by definition, this is the answer */
6284         return SS$_NORMAL;
6285      }
6286
6287      /* Need to look up a directory */
6288      vmspath[15] = '[';
6289      vmspath[16] = '\0';
6290
6291      /* Copy and add '^' escape characters as needed */
6292      j = 16;
6293      i = 0;
6294      while (unixpath[i] != 0) {
6295      int k;
6296
6297         j += copy_expand_unix_filename_escape
6298             (&vmspath[j], &unixpath[i], &k, utf8_fl);
6299         i += k;
6300      }
6301
6302      path_len = strlen(vmspath);
6303      if (vmspath[path_len - 1] == '/')
6304         path_len--;
6305      vmspath[path_len] = ']';
6306      path_len++;
6307      vmspath[path_len] = '\0';
6308
6309   }
6310   vmspath[vmspath_len] = 0;
6311   if (unixpath[unixlen - 1] == '/')
6312   dir_flag = 1;
6313   esa = PerlMem_malloc(VMS_MAXRSS);
6314   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6315   myfab.fab$l_fna = vmspath;
6316   myfab.fab$b_fns = strlen(vmspath);
6317   myfab.fab$l_naml = &mynam;
6318   mynam.naml$l_esa = NULL;
6319   mynam.naml$b_ess = 0;
6320   mynam.naml$l_long_expand = esa;
6321   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6322   mynam.naml$l_rsa = NULL;
6323   mynam.naml$b_rss = 0;
6324   if (decc_efs_case_preserve)
6325     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6326 #ifdef NAML$M_OPEN_SPECIAL
6327   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6328 #endif
6329
6330   /* Set up the remaining naml fields */
6331   sts = sys$parse(&myfab);
6332
6333   /* It failed! Try again as a UNIX filespec */
6334   if (!(sts & 1)) {
6335     PerlMem_free(esa);
6336     return sts;
6337   }
6338
6339    /* get the Device ID and the FID */
6340    sts = sys$search(&myfab);
6341    /* on any failure, returned the POSIX ^UP^ filespec */
6342    if (!(sts & 1)) {
6343       PerlMem_free(esa);
6344       return sts;
6345    }
6346    specdsc.dsc$a_pointer = vmspath;
6347    specdsc.dsc$w_length = vmspath_len;
6348
6349    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6350    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6351    sts = lib$fid_to_name
6352       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6353
6354   /* on any failure, returned the POSIX ^UP^ filespec */
6355   if (!(sts & 1)) {
6356      /* This can happen if user does not have permission to read directories */
6357      if (strncmp(unixpath,"\"^UP^",5) != 0)
6358        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6359      else
6360        strcpy(vmspath, unixpath);
6361   }
6362   else {
6363     vmspath[specdsc.dsc$w_length] = 0;
6364
6365     /* Are we expecting a directory? */
6366     if (dir_flag != 0) {
6367     int i;
6368     char *eptr;
6369
6370       eptr = NULL;
6371
6372       i = specdsc.dsc$w_length - 1;
6373       while (i > 0) {
6374       int zercnt;
6375         zercnt = 0;
6376         /* Version must be '1' */
6377         if (vmspath[i--] != '1')
6378           break;
6379         /* Version delimiter is one of ".;" */
6380         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6381           break;
6382         i--;
6383         if (vmspath[i--] != 'R')
6384           break;
6385         if (vmspath[i--] != 'I')
6386           break;
6387         if (vmspath[i--] != 'D')
6388           break;
6389         if (vmspath[i--] != '.')
6390           break;
6391         eptr = &vmspath[i+1];
6392         while (i > 0) {
6393           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6394             if (vmspath[i-1] != '^') {
6395               if (zercnt != 6) {
6396                 *eptr = vmspath[i];
6397                 eptr[1] = '\0';
6398                 vmspath[i] = '.';
6399                 break;
6400               }
6401               else {
6402                 /* Get rid of 6 imaginary zero directory filename */
6403                 vmspath[i+1] = '\0';
6404               }
6405             }
6406           }
6407           if (vmspath[i] == '0')
6408             zercnt++;
6409           else
6410             zercnt = 10;
6411           i--;
6412         }
6413         break;
6414       }
6415     }
6416   }
6417   PerlMem_free(esa);
6418   return sts;
6419 }
6420
6421 /* /dev/mumble needs to be handled special.
6422    /dev/null becomes NLA0:, And there is the potential for other stuff
6423    like /dev/tty which may need to be mapped to something.
6424 */
6425
6426 static int
6427 slash_dev_special_to_vms
6428    (const char * unixptr,
6429     char * vmspath,
6430     int vmspath_len)
6431 {
6432 char * nextslash;
6433 int len;
6434 int cmp;
6435 int islnm;
6436
6437     unixptr += 4;
6438     nextslash = strchr(unixptr, '/');
6439     len = strlen(unixptr);
6440     if (nextslash != NULL)
6441         len = nextslash - unixptr;
6442     cmp = strncmp("null", unixptr, 5);
6443     if (cmp == 0) {
6444         if (vmspath_len >= 6) {
6445             strcpy(vmspath, "_NLA0:");
6446             return SS$_NORMAL;
6447         }
6448     }
6449 }
6450
6451
6452 /* The built in routines do not understand perl's special needs, so
6453     doing a manual conversion from UNIX to VMS
6454
6455     If the utf8_fl is not null and points to a non-zero value, then
6456     treat 8 bit characters as UTF-8.
6457
6458     The sequence starting with '$(' and ending with ')' will be passed
6459     through with out interpretation instead of being escaped.
6460
6461   */
6462 static int posix_to_vmsspec_hardway
6463   (char *vmspath, int vmspath_len,
6464    const char *unixpath,
6465    int dir_flag,
6466    int * utf8_fl) {
6467
6468 char *esa;
6469 const char *unixptr;
6470 const char *unixend;
6471 char *vmsptr;
6472 const char *lastslash;
6473 const char *lastdot;
6474 int unixlen;
6475 int vmslen;
6476 int dir_start;
6477 int dir_dot;
6478 int quoted;
6479 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6480 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6481
6482   if (utf8_fl != NULL)
6483     *utf8_fl = 0;
6484
6485   unixptr = unixpath;
6486   dir_dot = 0;
6487
6488   /* Ignore leading "/" characters */
6489   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6490     unixptr++;
6491   }
6492   unixlen = strlen(unixptr);
6493
6494   /* Do nothing with blank paths */
6495   if (unixlen == 0) {
6496     vmspath[0] = '\0';
6497     return SS$_NORMAL;
6498   }
6499
6500   quoted = 0;
6501   /* This could have a "^UP^ on the front */
6502   if (strncmp(unixptr,"\"^UP^",5) == 0) {
6503     quoted = 1;
6504     unixptr+= 5;
6505     unixlen-= 5;
6506   }
6507
6508   lastslash = strrchr(unixptr,'/');
6509   lastdot = strrchr(unixptr,'.');
6510   unixend = strrchr(unixptr,'\"');
6511   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6512     unixend = unixptr + unixlen;
6513   }
6514
6515   /* last dot is last dot or past end of string */
6516   if (lastdot == NULL)
6517     lastdot = unixptr + unixlen;
6518
6519   /* if no directories, set last slash to beginning of string */
6520   if (lastslash == NULL) {
6521     lastslash = unixptr;
6522   }
6523   else {
6524     /* Watch out for trailing "." after last slash, still a directory */
6525     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6526       lastslash = unixptr + unixlen;
6527     }
6528
6529     /* Watch out for traiing ".." after last slash, still a directory */
6530     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6531       lastslash = unixptr + unixlen;
6532     }
6533
6534     /* dots in directories are aways escaped */
6535     if (lastdot < lastslash)
6536       lastdot = unixptr + unixlen;
6537   }
6538
6539   /* if (unixptr < lastslash) then we are in a directory */
6540
6541   dir_start = 0;
6542
6543   vmsptr = vmspath;
6544   vmslen = 0;
6545
6546   /* Start with the UNIX path */
6547   if (*unixptr != '/') {
6548     /* relative paths */
6549
6550     /* If allowing logical names on relative pathnames, then handle here */
6551     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6552         !decc_posix_compliant_pathnames) {
6553     char * nextslash;
6554     int seg_len;
6555     char * trn;
6556     int islnm;
6557
6558         /* Find the next slash */
6559         nextslash = strchr(unixptr,'/');
6560
6561         esa = PerlMem_malloc(vmspath_len);
6562         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6563
6564         trn = PerlMem_malloc(VMS_MAXRSS);
6565         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6566
6567         if (nextslash != NULL) {
6568
6569             seg_len = nextslash - unixptr;
6570             strncpy(esa, unixptr, seg_len);
6571             esa[seg_len] = 0;
6572         }
6573         else {
6574             strcpy(esa, unixptr);
6575             seg_len = strlen(unixptr);
6576         }
6577         /* trnlnm(section) */
6578         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6579
6580         if (islnm) {
6581             /* Now fix up the directory */
6582
6583             /* Split up the path to find the components */
6584             sts = vms_split_path
6585                   (trn,
6586                    &v_spec,
6587                    &v_len,
6588                    &r_spec,
6589                    &r_len,
6590                    &d_spec,
6591                    &d_len,
6592                    &n_spec,
6593                    &n_len,
6594                    &e_spec,
6595                    &e_len,
6596                    &vs_spec,
6597                    &vs_len);
6598
6599             while (sts == 0) {
6600             char * strt;
6601             int cmp;
6602
6603                 /* A logical name must be a directory  or the full
6604                    specification.  It is only a full specification if
6605                    it is the only component */
6606                 if ((unixptr[seg_len] == '\0') ||
6607                     (unixptr[seg_len+1] == '\0')) {
6608
6609                     /* Is a directory being required? */
6610                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6611                         /* Not a logical name */
6612                         break;
6613                     }
6614
6615
6616                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6617                         /* This must be a directory */
6618                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6619                             strcpy(vmsptr, esa);
6620                             vmslen=strlen(vmsptr);
6621                             vmsptr[vmslen] = ':';
6622                             vmslen++;
6623                             vmsptr[vmslen] = '\0';
6624                             return SS$_NORMAL;
6625                         }
6626                     }
6627
6628                 }
6629
6630
6631                 /* must be dev/directory - ignore version */
6632                 if ((n_len + e_len) != 0)
6633                     break;
6634
6635                 /* transfer the volume */
6636                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6637                     strncpy(vmsptr, v_spec, v_len);
6638                     vmsptr += v_len;
6639                     vmsptr[0] = '\0';
6640                     vmslen += v_len;
6641                 }
6642
6643                 /* unroot the rooted directory */
6644                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6645                     r_spec[0] = '[';
6646                     r_spec[r_len - 1] = ']';
6647
6648                     /* This should not be there, but nothing is perfect */
6649                     if (r_len > 9) {
6650                         cmp = strcmp(&r_spec[1], "000000.");
6651                         if (cmp == 0) {
6652                             r_spec += 7;
6653                             r_spec[7] = '[';
6654                             r_len -= 7;
6655                             if (r_len == 2)
6656                                 r_len = 0;
6657                         }
6658                     }
6659                     if (r_len > 0) {
6660                         strncpy(vmsptr, r_spec, r_len);
6661                         vmsptr += r_len;
6662                         vmslen += r_len;
6663                         vmsptr[0] = '\0';
6664                     }
6665                 }
6666                 /* Bring over the directory. */
6667                 if ((d_len > 0) &&
6668                     ((d_len + vmslen) < vmspath_len)) {
6669                     d_spec[0] = '[';
6670                     d_spec[d_len - 1] = ']';
6671                     if (d_len > 9) {
6672                         cmp = strcmp(&d_spec[1], "000000.");
6673                         if (cmp == 0) {
6674                             d_spec += 7;
6675                             d_spec[7] = '[';
6676                             d_len -= 7;
6677                             if (d_len == 2)
6678                                 d_len = 0;
6679                         }
6680                     }
6681
6682                     if (r_len > 0) {
6683                         /* Remove the redundant root */
6684                         if (r_len > 0) {
6685                             /* remove the ][ */
6686                             vmsptr--;
6687                             vmslen--;
6688                             d_spec++;
6689                             d_len--;
6690                         }
6691                         strncpy(vmsptr, d_spec, d_len);
6692                             vmsptr += d_len;
6693                             vmslen += d_len;
6694                             vmsptr[0] = '\0';
6695                     }
6696                 }
6697                 break;
6698             }
6699         }
6700
6701         PerlMem_free(esa);
6702         PerlMem_free(trn);
6703     }
6704
6705     if (lastslash > unixptr) {
6706     int dotdir_seen;
6707
6708       /* skip leading ./ */
6709       dotdir_seen = 0;
6710       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6711         dotdir_seen = 1;
6712         unixptr++;
6713         unixptr++;
6714       }
6715
6716       /* Are we still in a directory? */
6717       if (unixptr <= lastslash) {
6718         *vmsptr++ = '[';
6719         vmslen = 1;
6720         dir_start = 1;
6721
6722         /* if not backing up, then it is relative forward. */
6723         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6724               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6725           *vmsptr++ = '.';
6726           vmslen++;
6727           dir_dot = 1;
6728           }
6729        }
6730        else {
6731          if (dotdir_seen) {
6732            /* Perl wants an empty directory here to tell the difference
6733             * between a DCL commmand and a filename
6734             */
6735           *vmsptr++ = '[';
6736           *vmsptr++ = ']';
6737           vmslen = 2;
6738         }
6739       }
6740     }
6741     else {
6742       /* Handle two special files . and .. */
6743       if (unixptr[0] == '.') {
6744         if (&unixptr[1] == unixend) {
6745           *vmsptr++ = '[';
6746           *vmsptr++ = ']';
6747           vmslen += 2;
6748           *vmsptr++ = '\0';
6749           return SS$_NORMAL;
6750         }
6751         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6752           *vmsptr++ = '[';
6753           *vmsptr++ = '-';
6754           *vmsptr++ = ']';
6755           vmslen += 3;
6756           *vmsptr++ = '\0';
6757           return SS$_NORMAL;
6758         }
6759       }
6760     }
6761   }
6762   else {        /* Absolute PATH handling */
6763   int sts;
6764   char * nextslash;
6765   int seg_len;
6766     /* Need to find out where root is */
6767
6768     /* In theory, this procedure should never get an absolute POSIX pathname
6769      * that can not be found on the POSIX root.
6770      * In practice, that can not be relied on, and things will show up
6771      * here that are a VMS device name or concealed logical name instead.
6772      * So to make things work, this procedure must be tolerant.
6773      */
6774     esa = PerlMem_malloc(vmspath_len);
6775     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6776
6777     sts = SS$_NORMAL;
6778     nextslash = strchr(&unixptr[1],'/');
6779     seg_len = 0;
6780     if (nextslash != NULL) {
6781     int cmp;
6782       seg_len = nextslash - &unixptr[1];
6783       strncpy(vmspath, unixptr, seg_len + 1);
6784       vmspath[seg_len+1] = 0;
6785       cmp = 1;
6786       if (seg_len == 3) {
6787         cmp = strncmp(vmspath, "dev", 4);
6788         if (cmp == 0) {
6789             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6790             if (sts = SS$_NORMAL)
6791                 return SS$_NORMAL;
6792         }
6793       }
6794       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6795     }
6796
6797     if ($VMS_STATUS_SUCCESS(sts)) {
6798       /* This is verified to be a real path */
6799
6800       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6801       if ($VMS_STATUS_SUCCESS(sts)) {
6802         strcpy(vmspath, esa);
6803         vmslen = strlen(vmspath);
6804         vmsptr = vmspath + vmslen;
6805         unixptr++;
6806         if (unixptr < lastslash) {
6807         char * rptr;
6808           vmsptr--;
6809           *vmsptr++ = '.';
6810           dir_start = 1;
6811           dir_dot = 1;
6812           if (vmslen > 7) {
6813           int cmp;
6814             rptr = vmsptr - 7;
6815             cmp = strcmp(rptr,"000000.");
6816             if (cmp == 0) {
6817               vmslen -= 7;
6818               vmsptr -= 7;
6819               vmsptr[1] = '\0';
6820             } /* removing 6 zeros */
6821           } /* vmslen < 7, no 6 zeros possible */
6822         } /* Not in a directory */
6823       } /* Posix root found */
6824       else {
6825         /* No posix root, fall back to default directory */
6826         strcpy(vmspath, "SYS$DISK:[");
6827         vmsptr = &vmspath[10];
6828         vmslen = 10;
6829         if (unixptr > lastslash) {
6830            *vmsptr = ']';
6831            vmsptr++;
6832            vmslen++;
6833         }
6834         else {
6835            dir_start = 1;
6836         }
6837       }
6838     } /* end of verified real path handling */
6839     else {
6840     int add_6zero;
6841     int islnm;
6842
6843       /* Ok, we have a device or a concealed root that is not in POSIX
6844        * or we have garbage.  Make the best of it.
6845        */
6846
6847       /* Posix to VMS destroyed this, so copy it again */
6848       strncpy(vmspath, &unixptr[1], seg_len);
6849       vmspath[seg_len] = 0;
6850       vmslen = seg_len;
6851       vmsptr = &vmsptr[vmslen];
6852       islnm = 0;
6853
6854       /* Now do we need to add the fake 6 zero directory to it? */
6855       add_6zero = 1;
6856       if ((*lastslash == '/') && (nextslash < lastslash)) {
6857         /* No there is another directory */
6858         add_6zero = 0;
6859       }
6860       else {
6861       int trnend;
6862       int cmp;
6863
6864         /* now we have foo:bar or foo:[000000]bar to decide from */
6865         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6866
6867         if (!islnm && !decc_posix_compliant_pathnames) {
6868
6869             cmp = strncmp("bin", vmspath, 4);
6870             if (cmp == 0) {
6871                 /* bin => SYS$SYSTEM: */
6872                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6873             }
6874             else {
6875                 /* tmp => SYS$SCRATCH: */
6876                 cmp = strncmp("tmp", vmspath, 4);
6877                 if (cmp == 0) {
6878                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6879                 }
6880             }
6881         }
6882
6883         trnend = islnm ? islnm - 1 : 0;
6884
6885         /* if this was a logical name, ']' or '>' must be present */
6886         /* if not a logical name, then assume a device and hope. */
6887         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6888
6889         /* if log name and trailing '.' then rooted - treat as device */
6890         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6891
6892         /* Fix me, if not a logical name, a device lookup should be
6893          * done to see if the device is file structured.  If the device
6894          * is not file structured, the 6 zeros should not be put on.
6895          *
6896          * As it is, perl is occasionally looking for dev:[000000]tty.
6897          * which looks a little strange.
6898          *
6899          * Not that easy to detect as "/dev" may be file structured with
6900          * special device files.
6901          */
6902
6903         if ((add_6zero == 0) && (*nextslash == '/') &&
6904             (&nextslash[1] == unixend)) {
6905           /* No real directory present */
6906           add_6zero = 1;
6907         }
6908       }
6909
6910       /* Put the device delimiter on */
6911       *vmsptr++ = ':';
6912       vmslen++;
6913       unixptr = nextslash;
6914       unixptr++;
6915
6916       /* Start directory if needed */
6917       if (!islnm || add_6zero) {
6918         *vmsptr++ = '[';
6919         vmslen++;
6920         dir_start = 1;
6921       }
6922
6923       /* add fake 000000] if needed */
6924       if (add_6zero) {
6925         *vmsptr++ = '0';
6926         *vmsptr++ = '0';
6927         *vmsptr++ = '0';
6928         *vmsptr++ = '0';
6929         *vmsptr++ = '0';
6930         *vmsptr++ = '0';
6931         *vmsptr++ = ']';
6932         vmslen += 7;
6933         dir_start = 0;
6934       }
6935
6936     } /* non-POSIX translation */
6937     PerlMem_free(esa);
6938   } /* End of relative/absolute path handling */
6939
6940   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6941   int dash_flag;
6942   int in_cnt;
6943   int out_cnt;
6944
6945     dash_flag = 0;
6946
6947     if (dir_start != 0) {
6948
6949       /* First characters in a directory are handled special */
6950       while ((*unixptr == '/') ||
6951              ((*unixptr == '.') &&
6952               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6953                 (&unixptr[1]==unixend)))) {
6954       int loop_flag;
6955
6956         loop_flag = 0;
6957
6958         /* Skip redundant / in specification */
6959         while ((*unixptr == '/') && (dir_start != 0)) {
6960           loop_flag = 1;
6961           unixptr++;
6962           if (unixptr == lastslash)
6963             break;
6964         }
6965         if (unixptr == lastslash)
6966           break;
6967
6968         /* Skip redundant ./ characters */
6969         while ((*unixptr == '.') &&
6970                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6971           loop_flag = 1;
6972           unixptr++;
6973           if (unixptr == lastslash)
6974             break;
6975           if (*unixptr == '/')
6976             unixptr++;
6977         }
6978         if (unixptr == lastslash)
6979           break;
6980
6981         /* Skip redundant ../ characters */
6982         while ((*unixptr == '.') && (unixptr[1] == '.') &&
6983              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6984           /* Set the backing up flag */
6985           loop_flag = 1;
6986           dir_dot = 0;
6987           dash_flag = 1;
6988           *vmsptr++ = '-';
6989           vmslen++;
6990           unixptr++; /* first . */
6991           unixptr++; /* second . */
6992           if (unixptr == lastslash)
6993             break;
6994           if (*unixptr == '/') /* The slash */
6995             unixptr++;
6996         }
6997         if (unixptr == lastslash)
6998           break;
6999
7000         /* To do: Perl expects /.../ to be translated to [...] on VMS */
7001         /* Not needed when VMS is pretending to be UNIX. */
7002
7003         /* Is this loop stuck because of too many dots? */
7004         if (loop_flag == 0) {
7005           /* Exit the loop and pass the rest through */
7006           break;
7007         }
7008       }
7009
7010       /* Are we done with directories yet? */
7011       if (unixptr >= lastslash) {
7012
7013         /* Watch out for trailing dots */
7014         if (dir_dot != 0) {
7015             vmslen --;
7016             vmsptr--;
7017         }
7018         *vmsptr++ = ']';
7019         vmslen++;
7020         dash_flag = 0;
7021         dir_start = 0;
7022         if (*unixptr == '/')
7023           unixptr++;
7024       }
7025       else {
7026         /* Have we stopped backing up? */
7027         if (dash_flag) {
7028           *vmsptr++ = '.';
7029           vmslen++;
7030           dash_flag = 0;
7031           /* dir_start continues to be = 1 */
7032         }
7033         if (*unixptr == '-') {
7034           *vmsptr++ = '^';
7035           *vmsptr++ = *unixptr++;
7036           vmslen += 2;
7037           dir_start = 0;
7038
7039           /* Now are we done with directories yet? */
7040           if (unixptr >= lastslash) {
7041
7042             /* Watch out for trailing dots */
7043             if (dir_dot != 0) {
7044               vmslen --;
7045               vmsptr--;
7046             }
7047
7048             *vmsptr++ = ']';
7049             vmslen++;
7050             dash_flag = 0;
7051             dir_start = 0;
7052           }
7053         }
7054       }
7055     }
7056
7057     /* All done? */
7058     if (unixptr >= unixend)
7059       break;
7060
7061     /* Normal characters - More EFS work probably needed */
7062     dir_start = 0;
7063     dir_dot = 0;
7064
7065     switch(*unixptr) {
7066     case '/':
7067         /* remove multiple / */
7068         while (unixptr[1] == '/') {
7069            unixptr++;
7070         }
7071         if (unixptr == lastslash) {
7072           /* Watch out for trailing dots */
7073           if (dir_dot != 0) {
7074             vmslen --;
7075             vmsptr--;
7076           }
7077           *vmsptr++ = ']';
7078         }
7079         else {
7080           dir_start = 1;
7081           *vmsptr++ = '.';
7082           dir_dot = 1;
7083
7084           /* To do: Perl expects /.../ to be translated to [...] on VMS */
7085           /* Not needed when VMS is pretending to be UNIX. */
7086
7087         }
7088         dash_flag = 0;
7089         if (unixptr != unixend)
7090           unixptr++;
7091         vmslen++;
7092         break;
7093     case '.':
7094         if ((unixptr < lastdot) || (unixptr < lastslash) ||
7095             (&unixptr[1] == unixend)) {
7096           *vmsptr++ = '^';
7097           *vmsptr++ = '.';
7098           vmslen += 2;
7099           unixptr++;
7100
7101           /* trailing dot ==> '^..' on VMS */
7102           if (unixptr == unixend) {
7103             *vmsptr++ = '.';
7104             vmslen++;
7105             unixptr++;
7106           }
7107           break;
7108         }
7109
7110         *vmsptr++ = *unixptr++;
7111         vmslen ++;
7112         break;
7113     case '"':
7114         if (quoted && (&unixptr[1] == unixend)) {
7115             unixptr++;
7116             break;
7117         }
7118         in_cnt = copy_expand_unix_filename_escape
7119                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7120         vmsptr += out_cnt;
7121         unixptr += in_cnt;
7122         break;
7123     case '~':
7124     case ';':
7125     case '\\':
7126     case '?':
7127     case ' ':
7128     default:
7129         in_cnt = copy_expand_unix_filename_escape
7130                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7131         vmsptr += out_cnt;
7132         unixptr += in_cnt;
7133         break;
7134     }
7135   }
7136
7137   /* Make sure directory is closed */
7138   if (unixptr == lastslash) {
7139     char *vmsptr2;
7140     vmsptr2 = vmsptr - 1;
7141
7142     if (*vmsptr2 != ']') {
7143       *vmsptr2--;
7144
7145       /* directories do not end in a dot bracket */
7146       if (*vmsptr2 == '.') {
7147         vmsptr2--;
7148
7149         /* ^. is allowed */
7150         if (*vmsptr2 != '^') {
7151           vmsptr--; /* back up over the dot */
7152         }
7153       }
7154       *vmsptr++ = ']';
7155     }
7156   }
7157   else {
7158     char *vmsptr2;
7159     /* Add a trailing dot if a file with no extension */
7160     vmsptr2 = vmsptr - 1;
7161     if ((vmslen > 1) &&
7162         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7163         (*vmsptr2 != ')') && (*lastdot != '.')) {
7164         *vmsptr++ = '.';
7165         vmslen++;
7166     }
7167   }
7168
7169   *vmsptr = '\0';
7170   return SS$_NORMAL;
7171 }
7172 #endif
7173
7174  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7175 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7176 {
7177 char * result;
7178 int utf8_flag;
7179
7180    /* If a UTF8 flag is being passed, honor it */
7181    utf8_flag = 0;
7182    if (utf8_fl != NULL) {
7183      utf8_flag = *utf8_fl;
7184     *utf8_fl = 0;
7185    }
7186
7187    if (utf8_flag) {
7188      /* If there is a possibility of UTF8, then if any UTF8 characters
7189         are present, then they must be converted to VTF-7
7190       */
7191      result = strcpy(rslt, path); /* FIX-ME */
7192    }
7193    else
7194      result = strcpy(rslt, path);
7195
7196    return result;
7197 }
7198
7199
7200 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7201 static char *mp_do_tovmsspec
7202    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7203   static char __tovmsspec_retbuf[VMS_MAXRSS];
7204   char *rslt, *dirend;
7205   char *lastdot;
7206   char *vms_delim;
7207   register char *cp1;
7208   const char *cp2;
7209   unsigned long int infront = 0, hasdir = 1;
7210   int rslt_len;
7211   int no_type_seen;
7212   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7213   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7214
7215   if (path == NULL) return NULL;
7216   rslt_len = VMS_MAXRSS-1;
7217   if (buf) rslt = buf;
7218   else if (ts) Newx(rslt, VMS_MAXRSS, char);
7219   else rslt = __tovmsspec_retbuf;
7220
7221   /* '.' and '..' are "[]" and "[-]" for a quick check */
7222   if (path[0] == '.') {
7223     if (path[1] == '\0') {
7224       strcpy(rslt,"[]");
7225       if (utf8_flag != NULL)
7226         *utf8_flag = 0;
7227       return rslt;
7228     }
7229     else {
7230       if (path[1] == '.' && path[2] == '\0') {
7231         strcpy(rslt,"[-]");
7232         if (utf8_flag != NULL)
7233            *utf8_flag = 0;
7234         return rslt;
7235       }
7236     }
7237   }
7238
7239    /* Posix specifications are now a native VMS format */
7240   /*--------------------------------------------------*/
7241 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7242   if (decc_posix_compliant_pathnames) {
7243     if (strncmp(path,"\"^UP^",5) == 0) {
7244       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7245       return rslt;
7246     }
7247   }
7248 #endif
7249
7250   /* This is really the only way to see if this is already in VMS format */
7251   sts = vms_split_path
7252        (path,
7253         &v_spec,
7254         &v_len,
7255         &r_spec,
7256         &r_len,
7257         &d_spec,
7258         &d_len,
7259         &n_spec,
7260         &n_len,
7261         &e_spec,
7262         &e_len,
7263         &vs_spec,
7264         &vs_len);
7265   if (sts == 0) {
7266     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7267        replacement, because the above parse just took care of most of
7268        what is needed to do vmspath when the specification is already
7269        in VMS format.
7270
7271        And if it is not already, it is easier to do the conversion as
7272        part of this routine than to call this routine and then work on
7273        the result.
7274      */
7275
7276     /* If VMS punctuation was found, it is already VMS format */
7277     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7278       if (utf8_flag != NULL)
7279         *utf8_flag = 0;
7280       strcpy(rslt, path);
7281       return rslt;
7282     }
7283     /* Now, what to do with trailing "." cases where there is no
7284        extension?  If this is a UNIX specification, and EFS characters
7285        are enabled, then the trailing "." should be converted to a "^.".
7286        But if this was already a VMS specification, then it should be
7287        left alone.
7288
7289        So in the case of ambiguity, leave the specification alone.
7290      */
7291
7292
7293     /* If there is a possibility of UTF8, then if any UTF8 characters
7294         are present, then they must be converted to VTF-7
7295      */
7296     if (utf8_flag != NULL)
7297       *utf8_flag = 0;
7298     strcpy(rslt, path);
7299     return rslt;
7300   }
7301
7302   dirend = strrchr(path,'/');
7303
7304   if (dirend == NULL) {
7305      /* If we get here with no UNIX directory delimiters, then this is
7306         not a complete file specification, either garbage a UNIX glob
7307         specification that can not be converted to a VMS wildcard, or
7308         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7309         so apparently other programs expect this also.
7310
7311         utf8 flag setting needs to be preserved.
7312       */
7313       strcpy(rslt, path);
7314       return rslt;
7315   }
7316
7317 /* If POSIX mode active, handle the conversion */
7318 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7319   if (decc_efs_charset) {
7320     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7321     return rslt;
7322   }
7323 #endif
7324
7325   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7326     if (!*(dirend+2)) dirend +=2;
7327     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7328     if (decc_efs_charset == 0) {
7329       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7330     }
7331   }
7332
7333   cp1 = rslt;
7334   cp2 = path;
7335   lastdot = strrchr(cp2,'.');
7336   if (*cp2 == '/') {
7337     char *trndev;
7338     int islnm, rooted;
7339     STRLEN trnend;
7340
7341     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7342     if (!*(cp2+1)) {
7343       if (decc_disable_posix_root) {
7344         strcpy(rslt,"sys$disk:[000000]");
7345       }
7346       else {
7347         strcpy(rslt,"sys$posix_root:[000000]");
7348       }
7349       if (utf8_flag != NULL)
7350         *utf8_flag = 0;
7351       return rslt;
7352     }
7353     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7354     *cp1 = '\0';
7355     trndev = PerlMem_malloc(VMS_MAXRSS);
7356     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7357     islnm =  my_trnlnm(rslt,trndev,0);
7358
7359      /* DECC special handling */
7360     if (!islnm) {
7361       if (strcmp(rslt,"bin") == 0) {
7362         strcpy(rslt,"sys$system");
7363         cp1 = rslt + 10;
7364         *cp1 = 0;
7365         islnm =  my_trnlnm(rslt,trndev,0);
7366       }
7367       else if (strcmp(rslt,"tmp") == 0) {
7368         strcpy(rslt,"sys$scratch");
7369         cp1 = rslt + 11;
7370         *cp1 = 0;
7371         islnm =  my_trnlnm(rslt,trndev,0);
7372       }
7373       else if (!decc_disable_posix_root) {
7374         strcpy(rslt, "sys$posix_root");
7375         cp1 = rslt + 13;
7376         *cp1 = 0;
7377         cp2 = path;
7378         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7379         islnm =  my_trnlnm(rslt,trndev,0);
7380       }
7381       else if (strcmp(rslt,"dev") == 0) {
7382         if (strncmp(cp2,"/null", 5) == 0) {
7383           if ((cp2[5] == 0) || (cp2[5] == '/')) {
7384             strcpy(rslt,"NLA0");
7385             cp1 = rslt + 4;
7386             *cp1 = 0;
7387             cp2 = cp2 + 5;
7388             islnm =  my_trnlnm(rslt,trndev,0);
7389           }
7390         }
7391       }
7392     }
7393
7394     trnend = islnm ? strlen(trndev) - 1 : 0;
7395     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7396     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7397     /* If the first element of the path is a logical name, determine
7398      * whether it has to be translated so we can add more directories. */
7399     if (!islnm || rooted) {
7400       *(cp1++) = ':';
7401       *(cp1++) = '[';
7402       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7403       else cp2++;
7404     }
7405     else {
7406       if (cp2 != dirend) {
7407         strcpy(rslt,trndev);
7408         cp1 = rslt + trnend;
7409         if (*cp2 != 0) {
7410           *(cp1++) = '.';
7411           cp2++;
7412         }
7413       }
7414       else {
7415         if (decc_disable_posix_root) {
7416           *(cp1++) = ':';
7417           hasdir = 0;
7418         }
7419       }
7420     }
7421     PerlMem_free(trndev);
7422   }
7423   else {
7424     *(cp1++) = '[';
7425     if (*cp2 == '.') {
7426       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7427         cp2 += 2;         /* skip over "./" - it's redundant */
7428         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
7429       }
7430       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7431         *(cp1++) = '-';                                 /* "../" --> "-" */
7432         cp2 += 3;
7433       }
7434       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7435                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7436         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7437         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7438         cp2 += 4;
7439       }
7440       else if ((cp2 != lastdot) || (lastdot < dirend)) {
7441         /* Escape the extra dots in EFS file specifications */
7442         *(cp1++) = '^';
7443       }
7444       if (cp2 > dirend) cp2 = dirend;
7445     }
7446     else *(cp1++) = '.';
7447   }
7448   for (; cp2 < dirend; cp2++) {
7449     if (*cp2 == '/') {
7450       if (*(cp2-1) == '/') continue;
7451       if (*(cp1-1) != '.') *(cp1++) = '.';
7452       infront = 0;
7453     }
7454     else if (!infront && *cp2 == '.') {
7455       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7456       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
7457       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7458         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7459         else if (*(cp1-2) == '[') *(cp1-1) = '-';
7460         else {  /* back up over previous directory name */
7461           cp1--;
7462           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7463           if (*(cp1-1) == '[') {
7464             memcpy(cp1,"000000.",7);
7465             cp1 += 7;
7466           }
7467         }
7468         cp2 += 2;
7469         if (cp2 == dirend) break;
7470       }
7471       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7472                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7473         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7474         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7475         if (!*(cp2+3)) {
7476           *(cp1++) = '.';  /* Simulate trailing '/' */
7477           cp2 += 2;  /* for loop will incr this to == dirend */
7478         }
7479         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
7480       }
7481       else {
7482         if (decc_efs_charset == 0)
7483           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
7484         else {
7485           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
7486           *(cp1++) = '.';
7487         }
7488       }
7489     }
7490     else {
7491       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
7492       if (*cp2 == '.') {
7493         if (decc_efs_charset == 0)
7494           *(cp1++) = '_';
7495         else {
7496           *(cp1++) = '^';
7497           *(cp1++) = '.';
7498         }
7499       }
7500       else                  *(cp1++) =  *cp2;
7501       infront = 1;
7502     }
7503   }
7504   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7505   if (hasdir) *(cp1++) = ']';
7506   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
7507   /* fixme for ODS5 */
7508   no_type_seen = 0;
7509   if (cp2 > lastdot)
7510     no_type_seen = 1;
7511   while (*cp2) {
7512     switch(*cp2) {
7513     case '?':
7514         if (decc_efs_charset == 0)
7515           *(cp1++) = '%';
7516         else
7517           *(cp1++) = '?';
7518         cp2++;
7519     case ' ':
7520         *(cp1)++ = '^';
7521         *(cp1)++ = '_';
7522         cp2++;
7523         break;
7524     case '.':
7525         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7526             decc_readdir_dropdotnotype) {
7527           *(cp1)++ = '^';
7528           *(cp1)++ = '.';
7529           cp2++;
7530
7531           /* trailing dot ==> '^..' on VMS */
7532           if (*cp2 == '\0') {
7533             *(cp1++) = '.';
7534             no_type_seen = 0;
7535           }
7536         }
7537         else {
7538           *(cp1++) = *(cp2++);
7539           no_type_seen = 0;
7540         }
7541         break;
7542     case '$':
7543          /* This could be a macro to be passed through */
7544         *(cp1++) = *(cp2++);
7545         if (*cp2 == '(') {
7546         const char * save_cp2;
7547         char * save_cp1;
7548         int is_macro;
7549
7550             /* paranoid check */
7551             save_cp2 = cp2;
7552             save_cp1 = cp1;
7553             is_macro = 0;
7554
7555             /* Test through */
7556             *(cp1++) = *(cp2++);
7557             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7558                 *(cp1++) = *(cp2++);
7559                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7560                     *(cp1++) = *(cp2++);
7561                 }
7562                 if (*cp2 == ')') {
7563                     *(cp1++) = *(cp2++);
7564                     is_macro = 1;
7565                 }
7566             }
7567             if (is_macro == 0) {
7568                 /* Not really a macro - never mind */
7569                 cp2 = save_cp2;
7570                 cp1 = save_cp1;
7571             }
7572         }
7573         break;
7574     case '\"':
7575     case '~':
7576     case '`':
7577     case '!':
7578     case '#':
7579     case '%':
7580     case '^':
7581         /* Don't escape again if following character is
7582          * already something we escape.
7583          */
7584         if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
7585             *(cp1++) = *(cp2++);
7586             break;
7587         }
7588         /* But otherwise fall through and escape it. */
7589     case '&':
7590     case '(':
7591     case ')':
7592     case '=':
7593     case '+':
7594     case '\'':
7595     case '@':
7596     case '[':
7597     case ']':
7598     case '{':
7599     case '}':
7600     case ':':
7601     case '\\':
7602     case '|':
7603     case '<':
7604     case '>':
7605         *(cp1++) = '^';
7606         *(cp1++) = *(cp2++);
7607         break;
7608     case ';':
7609         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7610          * which is wrong.  UNIX notation should be ".dir." unless
7611          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7612          * changing this behavior could break more things at this time.
7613          * efs character set effectively does not allow "." to be a version
7614          * delimiter as a further complication about changing this.
7615          */
7616         if (decc_filename_unix_report != 0) {
7617           *(cp1++) = '^';
7618         }
7619         *(cp1++) = *(cp2++);
7620         break;
7621     default:
7622         *(cp1++) = *(cp2++);
7623     }
7624   }
7625   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7626   char *lcp1;
7627     lcp1 = cp1;
7628     lcp1--;
7629      /* Fix me for "^]", but that requires making sure that you do
7630       * not back up past the start of the filename
7631       */
7632     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7633       *cp1++ = '.';
7634   }
7635   *cp1 = '\0';
7636
7637   if (utf8_flag != NULL)
7638     *utf8_flag = 0;
7639   return rslt;
7640
7641 }  /* end of do_tovmsspec() */
7642 /*}}}*/
7643 /* External entry points */
7644 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7645   { return do_tovmsspec(path,buf,0,NULL); }
7646 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7647   { return do_tovmsspec(path,buf,1,NULL); }
7648 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7649   { return do_tovmsspec(path,buf,0,utf8_fl); }
7650 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7651   { return do_tovmsspec(path,buf,1,utf8_fl); }
7652
7653 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7654 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7655   static char __tovmspath_retbuf[VMS_MAXRSS];
7656   int vmslen;
7657   char *pathified, *vmsified, *cp;
7658
7659   if (path == NULL) return NULL;
7660   pathified = PerlMem_malloc(VMS_MAXRSS);
7661   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7662   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7663     PerlMem_free(pathified);
7664     return NULL;
7665   }
7666
7667   vmsified = NULL;
7668   if (buf == NULL)
7669      Newx(vmsified, VMS_MAXRSS, char);
7670   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7671     PerlMem_free(pathified);
7672     if (vmsified) Safefree(vmsified);
7673     return NULL;
7674   }
7675   PerlMem_free(pathified);
7676   if (buf) {
7677     return buf;
7678   }
7679   else if (ts) {
7680     vmslen = strlen(vmsified);
7681     Newx(cp,vmslen+1,char);
7682     memcpy(cp,vmsified,vmslen);
7683     cp[vmslen] = '\0';
7684     Safefree(vmsified);
7685     return cp;
7686   }
7687   else {
7688     strcpy(__tovmspath_retbuf,vmsified);
7689     Safefree(vmsified);
7690     return __tovmspath_retbuf;
7691   }
7692
7693 }  /* end of do_tovmspath() */
7694 /*}}}*/
7695 /* External entry points */
7696 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7697   { return do_tovmspath(path,buf,0, NULL); }
7698 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7699   { return do_tovmspath(path,buf,1, NULL); }
7700 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7701   { return do_tovmspath(path,buf,0,utf8_fl); }
7702 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7703   { return do_tovmspath(path,buf,1,utf8_fl); }
7704
7705
7706 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7707 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7708   static char __tounixpath_retbuf[VMS_MAXRSS];
7709   int unixlen;
7710   char *pathified, *unixified, *cp;
7711
7712   if (path == NULL) return NULL;
7713   pathified = PerlMem_malloc(VMS_MAXRSS);
7714   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7715   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7716     PerlMem_free(pathified);
7717     return NULL;
7718   }
7719
7720   unixified = NULL;
7721   if (buf == NULL) {
7722       Newx(unixified, VMS_MAXRSS, char);
7723   }
7724   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7725     PerlMem_free(pathified);
7726     if (unixified) Safefree(unixified);
7727     return NULL;
7728   }
7729   PerlMem_free(pathified);
7730   if (buf) {
7731     return buf;
7732   }
7733   else if (ts) {
7734     unixlen = strlen(unixified);
7735     Newx(cp,unixlen+1,char);
7736     memcpy(cp,unixified,unixlen);
7737     cp[unixlen] = '\0';
7738     Safefree(unixified);
7739     return cp;
7740   }
7741   else {
7742     strcpy(__tounixpath_retbuf,unixified);
7743     Safefree(unixified);
7744     return __tounixpath_retbuf;
7745   }
7746
7747 }  /* end of do_tounixpath() */
7748 /*}}}*/
7749 /* External entry points */
7750 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7751   { return do_tounixpath(path,buf,0,NULL); }
7752 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7753   { return do_tounixpath(path,buf,1,NULL); }
7754 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7755   { return do_tounixpath(path,buf,0,utf8_fl); }
7756 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7757   { return do_tounixpath(path,buf,1,utf8_fl); }
7758
7759 /*
7760  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark AT infocomm DOT com)
7761  *
7762  *****************************************************************************
7763  *                                                                           *
7764  *  Copyright (C) 1989-1994, 2007 by                                         *
7765  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
7766  *                                                                           *
7767  *  Permission is hereby granted for the reproduction of this software       *
7768  *  on condition that this copyright notice is included in source            *
7769  *  distributions of the software.  The code may be modified and             *
7770  *  distributed under the same terms as Perl itself.                         *
7771  *                                                                           *
7772  *  27-Aug-1994 Modified for inclusion in perl5                              *
7773  *              by Charles Bailey  (bailey AT newman DOT upenn DOT edu)      *
7774  *****************************************************************************
7775  */
7776
7777 /*
7778  * getredirection() is intended to aid in porting C programs
7779  * to VMS (Vax-11 C).  The native VMS environment does not support
7780  * '>' and '<' I/O redirection, or command line wild card expansion,
7781  * or a command line pipe mechanism using the '|' AND background
7782  * command execution '&'.  All of these capabilities are provided to any
7783  * C program which calls this procedure as the first thing in the
7784  * main program.
7785  * The piping mechanism will probably work with almost any 'filter' type
7786  * of program.  With suitable modification, it may useful for other
7787  * portability problems as well.
7788  *
7789  * Author:  Mark Pizzolato      (mark AT infocomm DOT com)
7790  */
7791 struct list_item
7792     {
7793     struct list_item *next;
7794     char *value;
7795     };
7796
7797 static void add_item(struct list_item **head,
7798                      struct list_item **tail,
7799                      char *value,
7800                      int *count);
7801
7802 static void mp_expand_wild_cards(pTHX_ char *item,
7803                                 struct list_item **head,
7804                                 struct list_item **tail,
7805                                 int *count);
7806
7807 static int background_process(pTHX_ int argc, char **argv);
7808
7809 static void pipe_and_fork(pTHX_ char **cmargv);
7810
7811 /*{{{ void getredirection(int *ac, char ***av)*/
7812 static void
7813 mp_getredirection(pTHX_ int *ac, char ***av)
7814 /*
7815  * Process vms redirection arg's.  Exit if any error is seen.
7816  * If getredirection() processes an argument, it is erased
7817  * from the vector.  getredirection() returns a new argc and argv value.
7818  * In the event that a background command is requested (by a trailing "&"),
7819  * this routine creates a background subprocess, and simply exits the program.
7820  *
7821  * Warning: do not try to simplify the code for vms.  The code
7822  * presupposes that getredirection() is called before any data is
7823  * read from stdin or written to stdout.
7824  *
7825  * Normal usage is as follows:
7826  *
7827  *      main(argc, argv)
7828  *      int             argc;
7829  *      char            *argv[];
7830  *      {
7831  *              getredirection(&argc, &argv);
7832  *      }
7833  */
7834 {
7835     int                 argc = *ac;     /* Argument Count         */
7836     char                **argv = *av;   /* Argument Vector        */
7837     char                *ap;            /* Argument pointer       */
7838     int                 j;              /* argv[] index           */
7839     int                 item_count = 0; /* Count of Items in List */
7840     struct list_item    *list_head = 0; /* First Item in List       */
7841     struct list_item    *list_tail;     /* Last Item in List        */
7842     char                *in = NULL;     /* Input File Name          */
7843     char                *out = NULL;    /* Output File Name         */
7844     char                *outmode = "w"; /* Mode to Open Output File */
7845     char                *err = NULL;    /* Error File Name          */
7846     char                *errmode = "w"; /* Mode to Open Error File  */
7847     int                 cmargc = 0;     /* Piped Command Arg Count  */
7848     char                **cmargv = NULL;/* Piped Command Arg Vector */
7849
7850     /*
7851      * First handle the case where the last thing on the line ends with
7852      * a '&'.  This indicates the desire for the command to be run in a
7853      * subprocess, so we satisfy that desire.
7854      */
7855     ap = argv[argc-1];
7856     if (0 == strcmp("&", ap))
7857        exit(background_process(aTHX_ --argc, argv));
7858     if (*ap && '&' == ap[strlen(ap)-1])
7859         {
7860         ap[strlen(ap)-1] = '\0';
7861        exit(background_process(aTHX_ argc, argv));
7862         }
7863     /*
7864      * Now we handle the general redirection cases that involve '>', '>>',
7865      * '<', and pipes '|'.
7866      */
7867     for (j = 0; j < argc; ++j)
7868         {
7869         if (0 == strcmp("<", argv[j]))
7870             {
7871             if (j+1 >= argc)
7872                 {
7873                 fprintf(stderr,"No input file after < on command line");
7874                 exit(LIB$_WRONUMARG);
7875                 }
7876             in = argv[++j];
7877             continue;
7878             }
7879         if ('<' == *(ap = argv[j]))
7880             {
7881             in = 1 + ap;
7882             continue;
7883             }
7884         if (0 == strcmp(">", ap))
7885             {
7886             if (j+1 >= argc)
7887                 {
7888                 fprintf(stderr,"No output file after > on command line");
7889                 exit(LIB$_WRONUMARG);
7890                 }
7891             out = argv[++j];
7892             continue;
7893             }
7894         if ('>' == *ap)
7895             {
7896             if ('>' == ap[1])
7897                 {
7898                 outmode = "a";
7899                 if ('\0' == ap[2])
7900                     out = argv[++j];
7901                 else
7902                     out = 2 + ap;
7903                 }
7904             else
7905                 out = 1 + ap;
7906             if (j >= argc)
7907                 {
7908                 fprintf(stderr,"No output file after > or >> on command line");
7909                 exit(LIB$_WRONUMARG);
7910                 }
7911             continue;
7912             }
7913         if (('2' == *ap) && ('>' == ap[1]))
7914             {
7915             if ('>' == ap[2])
7916                 {
7917                 errmode = "a";
7918                 if ('\0' == ap[3])
7919                     err = argv[++j];
7920                 else
7921                     err = 3 + ap;
7922                 }
7923             else
7924                 if ('\0' == ap[2])
7925                     err = argv[++j];
7926                 else
7927                     err = 2 + ap;
7928             if (j >= argc)
7929                 {
7930                 fprintf(stderr,"No output file after 2> or 2>> on command line");
7931                 exit(LIB$_WRONUMARG);
7932                 }
7933             continue;
7934             }
7935         if (0 == strcmp("|", argv[j]))
7936             {
7937             if (j+1 >= argc)
7938                 {
7939                 fprintf(stderr,"No command into which to pipe on command line");
7940                 exit(LIB$_WRONUMARG);
7941                 }
7942             cmargc = argc-(j+1);
7943             cmargv = &argv[j+1];
7944             argc = j;
7945             continue;
7946             }
7947         if ('|' == *(ap = argv[j]))
7948             {
7949             ++argv[j];
7950             cmargc = argc-j;
7951             cmargv = &argv[j];
7952             argc = j;
7953             continue;
7954             }
7955         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7956         }
7957     /*
7958      * Allocate and fill in the new argument vector, Some Unix's terminate
7959      * the list with an extra null pointer.
7960      */
7961     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7962     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7963     *av = argv;
7964     for (j = 0; j < item_count; ++j, list_head = list_head->next)
7965         argv[j] = list_head->value;
7966     *ac = item_count;
7967     if (cmargv != NULL)
7968         {
7969         if (out != NULL)
7970             {
7971             fprintf(stderr,"'|' and '>' may not both be specified on command line");
7972             exit(LIB$_INVARGORD);
7973             }
7974         pipe_and_fork(aTHX_ cmargv);
7975         }
7976
7977     /* Check for input from a pipe (mailbox) */
7978
7979     if (in == NULL && 1 == isapipe(0))
7980         {
7981         char mbxname[L_tmpnam];
7982         long int bufsize;
7983         long int dvi_item = DVI$_DEVBUFSIZ;
7984         $DESCRIPTOR(mbxnam, "");
7985         $DESCRIPTOR(mbxdevnam, "");
7986
7987         /* Input from a pipe, reopen it in binary mode to disable       */
7988         /* carriage control processing.                                 */
7989
7990         fgetname(stdin, mbxname);
7991         mbxnam.dsc$a_pointer = mbxname;
7992         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7993         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7994         mbxdevnam.dsc$a_pointer = mbxname;
7995         mbxdevnam.dsc$w_length = sizeof(mbxname);
7996         dvi_item = DVI$_DEVNAM;
7997         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7998         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7999         set_errno(0);
8000         set_vaxc_errno(1);
8001         freopen(mbxname, "rb", stdin);
8002         if (errno != 0)
8003             {
8004             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
8005             exit(vaxc$errno);
8006             }
8007         }
8008     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8009         {
8010         fprintf(stderr,"Can't open input file %s as stdin",in);
8011         exit(vaxc$errno);
8012         }
8013     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8014         {
8015         fprintf(stderr,"Can't open output file %s as stdout",out);
8016         exit(vaxc$errno);
8017         }
8018         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8019
8020     if (err != NULL) {
8021         if (strcmp(err,"&1") == 0) {
8022             dup2(fileno(stdout), fileno(stderr));
8023             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8024         } else {
8025         FILE *tmperr;
8026         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8027             {
8028             fprintf(stderr,"Can't open error file %s as stderr",err);
8029             exit(vaxc$errno);
8030             }
8031             fclose(tmperr);
8032            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8033                 {
8034                 exit(vaxc$errno);
8035                 }
8036             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8037         }
8038         }
8039 #ifdef ARGPROC_DEBUG
8040     PerlIO_printf(Perl_debug_log, "Arglist:\n");
8041     for (j = 0; j < *ac;  ++j)
8042         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8043 #endif
8044    /* Clear errors we may have hit expanding wildcards, so they don't
8045       show up in Perl's $! later */
8046    set_errno(0); set_vaxc_errno(1);
8047 }  /* end of getredirection() */
8048 /*}}}*/
8049
8050 static void add_item(struct list_item **head,
8051                      struct list_item **tail,
8052                      char *value,
8053                      int *count)
8054 {
8055     if (*head == 0)
8056         {
8057         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8058         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8059         *tail = *head;
8060         }
8061     else {
8062         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8063         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8064         *tail = (*tail)->next;
8065         }
8066     (*tail)->value = value;
8067     ++(*count);
8068 }
8069
8070 static void mp_expand_wild_cards(pTHX_ char *item,
8071                               struct list_item **head,
8072                               struct list_item **tail,
8073                               int *count)
8074 {
8075 int expcount = 0;
8076 unsigned long int context = 0;
8077 int isunix = 0;
8078 int item_len = 0;
8079 char *had_version;
8080 char *had_device;
8081 int had_directory;
8082 char *devdir,*cp;
8083 char *vmsspec;
8084 $DESCRIPTOR(filespec, "");
8085 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8086 $DESCRIPTOR(resultspec, "");
8087 unsigned long int lff_flags = 0;
8088 int sts;
8089 int rms_sts;
8090
8091 #ifdef VMS_LONGNAME_SUPPORT
8092     lff_flags = LIB$M_FIL_LONG_NAMES;
8093 #endif
8094
8095     for (cp = item; *cp; cp++) {
8096         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8097         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8098     }
8099     if (!*cp || isspace(*cp))
8100         {
8101         add_item(head, tail, item, count);
8102         return;
8103         }
8104     else
8105         {
8106      /* "double quoted" wild card expressions pass as is */
8107      /* From DCL that means using e.g.:                  */
8108      /* perl program """perl.*"""                        */
8109      item_len = strlen(item);
8110      if ( '"' == *item && '"' == item[item_len-1] )
8111        {
8112        item++;
8113        item[item_len-2] = '\0';
8114        add_item(head, tail, item, count);
8115        return;
8116        }
8117      }
8118     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8119     resultspec.dsc$b_class = DSC$K_CLASS_D;
8120     resultspec.dsc$a_pointer = NULL;
8121     vmsspec = PerlMem_malloc(VMS_MAXRSS);
8122     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8123     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8124       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8125     if (!isunix || !filespec.dsc$a_pointer)
8126       filespec.dsc$a_pointer = item;
8127     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8128     /*
8129      * Only return version specs, if the caller specified a version
8130      */
8131     had_version = strchr(item, ';');
8132     /*
8133      * Only return device and directory specs, if the caller specifed either.
8134      */
8135     had_device = strchr(item, ':');
8136     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8137
8138     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8139                                  (&filespec, &resultspec, &context,
8140                                   &defaultspec, 0, &rms_sts, &lff_flags)))
8141         {
8142         char *string;
8143         char *c;
8144
8145         string = PerlMem_malloc(resultspec.dsc$w_length+1);
8146         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8147         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8148         string[resultspec.dsc$w_length] = '\0';
8149         if (NULL == had_version)
8150             *(strrchr(string, ';')) = '\0';
8151         if ((!had_directory) && (had_device == NULL))
8152             {
8153             if (NULL == (devdir = strrchr(string, ']')))
8154                 devdir = strrchr(string, '>');
8155             strcpy(string, devdir + 1);
8156             }
8157         /*
8158          * Be consistent with what the C RTL has already done to the rest of
8159          * the argv items and lowercase all of these names.
8160          */
8161         if (!decc_efs_case_preserve) {
8162             for (c = string; *c; ++c)
8163             if (isupper(*c))
8164                 *c = tolower(*c);
8165         }
8166         if (isunix) trim_unixpath(string,item,1);
8167         add_item(head, tail, string, count);
8168         ++expcount;
8169     }
8170     PerlMem_free(vmsspec);
8171     if (sts != RMS$_NMF)
8172         {
8173         set_vaxc_errno(sts);
8174         switch (sts)
8175             {
8176             case RMS$_FNF: case RMS$_DNF:
8177                 set_errno(ENOENT); break;
8178             case RMS$_DIR:
8179                 set_errno(ENOTDIR); break;
8180             case RMS$_DEV:
8181                 set_errno(ENODEV); break;
8182             case RMS$_FNM: case RMS$_SYN:
8183                 set_errno(EINVAL); break;
8184             case RMS$_PRV:
8185                 set_errno(EACCES); break;
8186             default:
8187                 _ckvmssts_noperl(sts);
8188             }
8189         }
8190     if (expcount == 0)
8191         add_item(head, tail, item, count);
8192     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8193     _ckvmssts_noperl(lib$find_file_end(&context));
8194 }
8195
8196 static int child_st[2];/* Event Flag set when child process completes   */
8197
8198 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
8199
8200 static unsigned long int exit_handler(int *status)
8201 {
8202 short iosb[4];
8203
8204     if (0 == child_st[0])
8205         {
8206 #ifdef ARGPROC_DEBUG
8207         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8208 #endif
8209         fflush(stdout);     /* Have to flush pipe for binary data to    */
8210                             /* terminate properly -- <tp@mccall.com>    */
8211         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8212         sys$dassgn(child_chan);
8213         fclose(stdout);
8214         sys$synch(0, child_st);
8215         }
8216     return(1);
8217 }
8218
8219 static void sig_child(int chan)
8220 {
8221 #ifdef ARGPROC_DEBUG
8222     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8223 #endif
8224     if (child_st[0] == 0)
8225         child_st[0] = 1;
8226 }
8227
8228 static struct exit_control_block exit_block =
8229     {
8230     0,
8231     exit_handler,
8232     1,
8233     &exit_block.exit_status,
8234     0
8235     };
8236
8237 static void
8238 pipe_and_fork(pTHX_ char **cmargv)
8239 {
8240     PerlIO *fp;
8241     struct dsc$descriptor_s *vmscmd;
8242     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8243     int sts, j, l, ismcr, quote, tquote = 0;
8244
8245     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8246     vms_execfree(vmscmd);
8247
8248     j = l = 0;
8249     p = subcmd;
8250     q = cmargv[0];
8251     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
8252               && toupper(*(q+2)) == 'R' && !*(q+3);
8253
8254     while (q && l < MAX_DCL_LINE_LENGTH) {
8255         if (!*q) {
8256             if (j > 0 && quote) {
8257                 *p++ = '"';
8258                 l++;
8259             }
8260             q = cmargv[++j];
8261             if (q) {
8262                 if (ismcr && j > 1) quote = 1;
8263                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
8264                 *p++ = ' ';
8265                 l++;
8266                 if (quote || tquote) {
8267                     *p++ = '"';
8268                     l++;
8269                 }
8270             }
8271         } else {
8272             if ((quote||tquote) && *q == '"') {
8273                 *p++ = '"';
8274                 l++;
8275             }
8276             *p++ = *q++;
8277             l++;
8278         }
8279     }
8280     *p = '\0';
8281
8282     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8283     if (fp == Nullfp) {
8284         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8285     }
8286 }
8287
8288 static int background_process(pTHX_ int argc, char **argv)
8289 {
8290 char command[MAX_DCL_SYMBOL + 1] = "$";
8291 $DESCRIPTOR(value, "");
8292 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8293 static $DESCRIPTOR(null, "NLA0:");
8294 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8295 char pidstring[80];
8296 $DESCRIPTOR(pidstr, "");
8297 int pid;
8298 unsigned long int flags = 17, one = 1, retsts;
8299 int len;
8300
8301     strcat(command, argv[0]);
8302     len = strlen(command);
8303     while (--argc && (len < MAX_DCL_SYMBOL))
8304         {
8305         strcat(command, " \"");
8306         strcat(command, *(++argv));
8307         strcat(command, "\"");
8308         len = strlen(command);
8309         }
8310     value.dsc$a_pointer = command;
8311     value.dsc$w_length = strlen(value.dsc$a_pointer);
8312     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8313     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8314     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8315         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8316     }
8317     else {
8318         _ckvmssts_noperl(retsts);
8319     }
8320 #ifdef ARGPROC_DEBUG
8321     PerlIO_printf(Perl_debug_log, "%s\n", command);
8322 #endif
8323     sprintf(pidstring, "%08X", pid);
8324     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8325     pidstr.dsc$a_pointer = pidstring;
8326     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8327     lib$set_symbol(&pidsymbol, &pidstr);
8328     return(SS$_NORMAL);
8329 }
8330 /*}}}*/
8331 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8332
8333
8334 /* OS-specific initialization at image activation (not thread startup) */
8335 /* Older VAXC header files lack these constants */
8336 #ifndef JPI$_RIGHTS_SIZE
8337 #  define JPI$_RIGHTS_SIZE 817
8338 #endif
8339 #ifndef KGB$M_SUBSYSTEM
8340 #  define KGB$M_SUBSYSTEM 0x8
8341 #endif
8342
8343 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8344
8345 /*{{{void vms_image_init(int *, char ***)*/
8346 void
8347 vms_image_init(int *argcp, char ***argvp)
8348 {
8349   char eqv[LNM$C_NAMLENGTH+1] = "";
8350   unsigned int len, tabct = 8, tabidx = 0;
8351   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8352   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8353   unsigned short int dummy, rlen;
8354   struct dsc$descriptor_s **tabvec;
8355 #if defined(PERL_IMPLICIT_CONTEXT)
8356   pTHX = NULL;
8357 #endif
8358   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8359                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8360                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8361                                  {          0,                0,    0,      0} };
8362
8363 #ifdef KILL_BY_SIGPRC
8364     Perl_csighandler_init();
8365 #endif
8366
8367   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8368   _ckvmssts_noperl(iosb[0]);
8369   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8370     if (iprv[i]) {           /* Running image installed with privs? */
8371       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8372       will_taint = TRUE;
8373       break;
8374     }
8375   }
8376   /* Rights identifiers might trigger tainting as well. */
8377   if (!will_taint && (rlen || rsz)) {
8378     while (rlen < rsz) {
8379       /* We didn't get all the identifiers on the first pass.  Allocate a
8380        * buffer much larger than $GETJPI wants (rsz is size in bytes that
8381        * were needed to hold all identifiers at time of last call; we'll
8382        * allocate that many unsigned long ints), and go back and get 'em.
8383        * If it gave us less than it wanted to despite ample buffer space,
8384        * something's broken.  Is your system missing a system identifier?
8385        */
8386       if (rsz <= jpilist[1].buflen) {
8387          /* Perl_croak accvios when used this early in startup. */
8388          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8389                          rsz, (unsigned long) jpilist[1].buflen,
8390                          "Check your rights database for corruption.\n");
8391          exit(SS$_ABORT);
8392       }
8393       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8394       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8395       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8396       jpilist[1].buflen = rsz * sizeof(unsigned long int);
8397       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8398       _ckvmssts_noperl(iosb[0]);
8399     }
8400     mask = jpilist[1].bufadr;
8401     /* Check attribute flags for each identifier (2nd longword); protected
8402      * subsystem identifiers trigger tainting.
8403      */
8404     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8405       if (mask[i] & KGB$M_SUBSYSTEM) {
8406         will_taint = TRUE;
8407         break;
8408       }
8409     }
8410     if (mask != rlst) PerlMem_free(mask);
8411   }
8412
8413   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8414    * logical, some versions of the CRTL will add a phanthom /000000/
8415    * directory.  This needs to be removed.
8416    */
8417   if (decc_filename_unix_report) {
8418   char * zeros;
8419   int ulen;
8420     ulen = strlen(argvp[0][0]);
8421     if (ulen > 7) {
8422       zeros = strstr(argvp[0][0], "/000000/");
8423       if (zeros != NULL) {
8424         int mlen;
8425         mlen = ulen - (zeros - argvp[0][0]) - 7;
8426         memmove(zeros, &zeros[7], mlen);
8427         ulen = ulen - 7;
8428         argvp[0][0][ulen] = '\0';
8429       }
8430     }
8431     /* It also may have a trailing dot that needs to be removed otherwise
8432      * it will be converted to VMS mode incorrectly.
8433      */
8434     ulen--;
8435     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8436       argvp[0][0][ulen] = '\0';
8437   }
8438
8439   /* We need to use this hack to tell Perl it should run with tainting,
8440    * since its tainting flag may be part of the PL_curinterp struct, which
8441    * hasn't been allocated when vms_image_init() is called.
8442    */
8443   if (will_taint) {
8444     char **newargv, **oldargv;
8445     oldargv = *argvp;
8446     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8447     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8448     newargv[0] = oldargv[0];
8449     newargv[1] = PerlMem_malloc(3 * sizeof(char));
8450     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8451     strcpy(newargv[1], "-T");
8452     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8453     (*argcp)++;
8454     newargv[*argcp] = NULL;
8455     /* We orphan the old argv, since we don't know where it's come from,
8456      * so we don't know how to free it.
8457      */
8458     *argvp = newargv;
8459   }
8460   else {  /* Did user explicitly request tainting? */
8461     int i;
8462     char *cp, **av = *argvp;
8463     for (i = 1; i < *argcp; i++) {
8464       if (*av[i] != '-') break;
8465       for (cp = av[i]+1; *cp; cp++) {
8466         if (*cp == 'T') { will_taint = 1; break; }
8467         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8468                   strchr("DFIiMmx",*cp)) break;
8469       }
8470       if (will_taint) break;
8471     }
8472   }
8473
8474   for (tabidx = 0;
8475        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8476        tabidx++) {
8477     if (!tabidx) {
8478       tabvec = (struct dsc$descriptor_s **)
8479             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8480       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8481     }
8482     else if (tabidx >= tabct) {
8483       tabct += 8;
8484       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8485       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8486     }
8487     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8488     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8489     tabvec[tabidx]->dsc$w_length  = 0;
8490     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
8491     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
8492     tabvec[tabidx]->dsc$a_pointer = NULL;
8493     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8494   }
8495   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8496
8497   getredirection(argcp,argvp);
8498 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8499   {
8500 # include <reentrancy.h>
8501   decc$set_reentrancy(C$C_MULTITHREAD);
8502   }
8503 #endif
8504   return;
8505 }
8506 /*}}}*/
8507
8508
8509 /* trim_unixpath()
8510  * Trim Unix-style prefix off filespec, so it looks like what a shell
8511  * glob expansion would return (i.e. from specified prefix on, not
8512  * full path).  Note that returned filespec is Unix-style, regardless
8513  * of whether input filespec was VMS-style or Unix-style.
8514  *
8515  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8516  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
8517  * vector of options; at present, only bit 0 is used, and if set tells
8518  * trim unixpath to try the current default directory as a prefix when
8519  * presented with a possibly ambiguous ... wildcard.
8520  *
8521  * Returns !=0 on success, with trimmed filespec replacing contents of
8522  * fspec, and 0 on failure, with contents of fpsec unchanged.
8523  */
8524 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8525 int
8526 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8527 {
8528   char *unixified, *unixwild,
8529        *template, *base, *end, *cp1, *cp2;
8530   register int tmplen, reslen = 0, dirs = 0;
8531
8532   unixwild = PerlMem_malloc(VMS_MAXRSS);
8533   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8534   if (!wildspec || !fspec) return 0;
8535   template = unixwild;
8536   if (strpbrk(wildspec,"]>:") != NULL) {
8537     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8538         PerlMem_free(unixwild);
8539         return 0;
8540     }
8541   }
8542   else {
8543     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8544     unixwild[VMS_MAXRSS-1] = 0;
8545   }
8546   unixified = PerlMem_malloc(VMS_MAXRSS);
8547   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8548   if (strpbrk(fspec,"]>:") != NULL) {
8549     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8550         PerlMem_free(unixwild);
8551         PerlMem_free(unixified);
8552         return 0;
8553     }
8554     else base = unixified;
8555     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8556      * check to see that final result fits into (isn't longer than) fspec */
8557     reslen = strlen(fspec);
8558   }
8559   else base = fspec;
8560
8561   /* No prefix or absolute path on wildcard, so nothing to remove */
8562   if (!*template || *template == '/') {
8563     PerlMem_free(unixwild);
8564     if (base == fspec) {
8565         PerlMem_free(unixified);
8566         return 1;
8567     }
8568     tmplen = strlen(unixified);
8569     if (tmplen > reslen) {
8570         PerlMem_free(unixified);
8571         return 0;  /* not enough space */
8572     }
8573     /* Copy unixified resultant, including trailing NUL */
8574     memmove(fspec,unixified,tmplen+1);
8575     PerlMem_free(unixified);
8576     return 1;
8577   }
8578
8579   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
8580   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8581     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8582     for (cp1 = end ;cp1 >= base; cp1--)
8583       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8584         { cp1++; break; }
8585     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8586     PerlMem_free(unixified);
8587     PerlMem_free(unixwild);
8588     return 1;
8589   }
8590   else {
8591     char *tpl, *lcres;
8592     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8593     int ells = 1, totells, segdirs, match;
8594     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8595                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8596
8597     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8598     totells = ells;
8599     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8600     tpl = PerlMem_malloc(VMS_MAXRSS);
8601     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8602     if (ellipsis == template && opts & 1) {
8603       /* Template begins with an ellipsis.  Since we can't tell how many
8604        * directory names at the front of the resultant to keep for an
8605        * arbitrary starting point, we arbitrarily choose the current
8606        * default directory as a starting point.  If it's there as a prefix,
8607        * clip it off.  If not, fall through and act as if the leading
8608        * ellipsis weren't there (i.e. return shortest possible path that
8609        * could match template).
8610        */
8611       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8612           PerlMem_free(tpl);
8613           PerlMem_free(unixified);
8614           PerlMem_free(unixwild);
8615           return 0;
8616       }
8617       if (!decc_efs_case_preserve) {
8618         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8619           if (_tolower(*cp1) != _tolower(*cp2)) break;
8620       }
8621       segdirs = dirs - totells;  /* Min # of dirs we must have left */
8622       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8623       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8624         memmove(fspec,cp2+1,end - cp2);
8625         PerlMem_free(tpl);
8626         PerlMem_free(unixified);
8627         PerlMem_free(unixwild);
8628         return 1;
8629       }
8630     }
8631     /* First off, back up over constant elements at end of path */
8632     if (dirs) {
8633       for (front = end ; front >= base; front--)
8634          if (*front == '/' && !dirs--) { front++; break; }
8635     }
8636     lcres = PerlMem_malloc(VMS_MAXRSS);
8637     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8638     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8639          cp1++,cp2++) {
8640             if (!decc_efs_case_preserve) {
8641                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
8642             }
8643             else {
8644                 *cp2 = *cp1;
8645             }
8646     }
8647     if (cp1 != '\0') {
8648         PerlMem_free(tpl);
8649         PerlMem_free(unixified);
8650         PerlMem_free(unixwild);
8651         PerlMem_free(lcres);
8652         return 0;  /* Path too long. */
8653     }
8654     lcend = cp2;
8655     *cp2 = '\0';  /* Pick up with memcpy later */
8656     lcfront = lcres + (front - base);
8657     /* Now skip over each ellipsis and try to match the path in front of it. */
8658     while (ells--) {
8659       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8660         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
8661             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
8662       if (cp1 < template) break; /* template started with an ellipsis */
8663       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8664         ellipsis = cp1; continue;
8665       }
8666       wilddsc.dsc$a_pointer = tpl;
8667       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8668       nextell = cp1;
8669       for (segdirs = 0, cp2 = tpl;
8670            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8671            cp1++, cp2++) {
8672          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8673          else {
8674             if (!decc_efs_case_preserve) {
8675               *cp2 = _tolower(*cp1);  /* else lowercase for match */
8676             }
8677             else {
8678               *cp2 = *cp1;  /* else preserve case for match */
8679             }
8680          }
8681          if (*cp2 == '/') segdirs++;
8682       }
8683       if (cp1 != ellipsis - 1) {
8684           PerlMem_free(tpl);
8685           PerlMem_free(unixified);
8686           PerlMem_free(unixwild);
8687           PerlMem_free(lcres);
8688           return 0; /* Path too long */
8689       }
8690       /* Back up at least as many dirs as in template before matching */
8691       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8692         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8693       for (match = 0; cp1 > lcres;) {
8694         resdsc.dsc$a_pointer = cp1;
8695         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8696           match++;
8697           if (match == 1) lcfront = cp1;
8698         }
8699         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8700       }
8701       if (!match) {
8702         PerlMem_free(tpl);
8703         PerlMem_free(unixified);
8704         PerlMem_free(unixwild);
8705         PerlMem_free(lcres);
8706         return 0;  /* Can't find prefix ??? */
8707       }
8708       if (match > 1 && opts & 1) {
8709         /* This ... wildcard could cover more than one set of dirs (i.e.
8710          * a set of similar dir names is repeated).  If the template
8711          * contains more than 1 ..., upstream elements could resolve the
8712          * ambiguity, but it's not worth a full backtracking setup here.
8713          * As a quick heuristic, clip off the current default directory
8714          * if it's present to find the trimmed spec, else use the
8715          * shortest string that this ... could cover.
8716          */
8717         char def[NAM$C_MAXRSS+1], *st;
8718
8719         if (getcwd(def, sizeof def,0) == NULL) {
8720             Safefree(unixified);
8721             Safefree(unixwild);
8722             Safefree(lcres);
8723             Safefree(tpl);
8724             return 0;
8725         }
8726         if (!decc_efs_case_preserve) {
8727           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8728             if (_tolower(*cp1) != _tolower(*cp2)) break;
8729         }
8730         segdirs = dirs - totells;  /* Min # of dirs we must have left */
8731         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8732         if (*cp1 == '\0' && *cp2 == '/') {
8733           memmove(fspec,cp2+1,end - cp2);
8734           PerlMem_free(tpl);
8735           PerlMem_free(unixified);
8736           PerlMem_free(unixwild);
8737           PerlMem_free(lcres);
8738           return 1;
8739         }
8740         /* Nope -- stick with lcfront from above and keep going. */
8741       }
8742     }
8743     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8744     PerlMem_free(tpl);
8745     PerlMem_free(unixified);
8746     PerlMem_free(unixwild);
8747     PerlMem_free(lcres);
8748     return 1;
8749     ellipsis = nextell;
8750   }
8751
8752 }  /* end of trim_unixpath() */
8753 /*}}}*/
8754
8755
8756 /*
8757  *  VMS readdir() routines.
8758  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8759  *
8760  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
8761  *  Minor modifications to original routines.
8762  */
8763
8764 /* readdir may have been redefined by reentr.h, so make sure we get
8765  * the local version for what we do here.
8766  */
8767 #ifdef readdir
8768 # undef readdir
8769 #endif
8770 #if !defined(PERL_IMPLICIT_CONTEXT)
8771 # define readdir Perl_readdir
8772 #else
8773 # define readdir(a) Perl_readdir(aTHX_ a)
8774 #endif
8775
8776     /* Number of elements in vms_versions array */
8777 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
8778
8779 /*
8780  *  Open a directory, return a handle for later use.
8781  */
8782 /*{{{ DIR *opendir(char*name) */
8783 DIR *
8784 Perl_opendir(pTHX_ const char *name)
8785 {
8786     DIR *dd;
8787     char *dir;
8788     Stat_t sb;
8789
8790     Newx(dir, VMS_MAXRSS, char);
8791     if (do_tovmspath(name,dir,0,NULL) == NULL) {
8792       Safefree(dir);
8793       return NULL;
8794     }
8795     /* Check access before stat; otherwise stat does not
8796      * accurately report whether it's a directory.
8797      */
8798     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8799       /* cando_by_name has already set errno */
8800       Safefree(dir);
8801       return NULL;
8802     }
8803     if (flex_stat(dir,&sb) == -1) return NULL;
8804     if (!S_ISDIR(sb.st_mode)) {
8805       Safefree(dir);
8806       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
8807       return NULL;
8808     }
8809     /* Get memory for the handle, and the pattern. */
8810     Newx(dd,1,DIR);
8811     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8812
8813     /* Fill in the fields; mainly playing with the descriptor. */
8814     sprintf(dd->pattern, "%s*.*",dir);
8815     Safefree(dir);
8816     dd->context = 0;
8817     dd->count = 0;
8818     dd->flags = 0;
8819     /* By saying we always want the result of readdir() in unix format, we
8820      * are really saying we want all the escapes removed.  Otherwise the caller,
8821      * having no way to know whether it's already in VMS format, might send it
8822      * through tovmsspec again, thus double escaping.
8823      */
8824     dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8825     dd->pat.dsc$a_pointer = dd->pattern;
8826     dd->pat.dsc$w_length = strlen(dd->pattern);
8827     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8828     dd->pat.dsc$b_class = DSC$K_CLASS_S;
8829 #if defined(USE_ITHREADS)
8830     Newx(dd->mutex,1,perl_mutex);
8831     MUTEX_INIT( (perl_mutex *) dd->mutex );
8832 #else
8833     dd->mutex = NULL;
8834 #endif
8835
8836     return dd;
8837 }  /* end of opendir() */
8838 /*}}}*/
8839
8840 /*
8841  *  Set the flag to indicate we want versions or not.
8842  */
8843 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8844 void
8845 vmsreaddirversions(DIR *dd, int flag)
8846 {
8847     if (flag)
8848         dd->flags |= PERL_VMSDIR_M_VERSIONS;
8849     else
8850         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8851 }
8852 /*}}}*/
8853
8854 /*
8855  *  Free up an opened directory.
8856  */
8857 /*{{{ void closedir(DIR *dd)*/
8858 void
8859 Perl_closedir(DIR *dd)
8860 {
8861     int sts;
8862
8863     sts = lib$find_file_end(&dd->context);
8864     Safefree(dd->pattern);
8865 #if defined(USE_ITHREADS)
8866     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8867     Safefree(dd->mutex);
8868 #endif
8869     Safefree(dd);
8870 }
8871 /*}}}*/
8872
8873 /*
8874  *  Collect all the version numbers for the current file.
8875  */
8876 static void
8877 collectversions(pTHX_ DIR *dd)
8878 {
8879     struct dsc$descriptor_s     pat;
8880     struct dsc$descriptor_s     res;
8881     struct dirent *e;
8882     char *p, *text, *buff;
8883     int i;
8884     unsigned long context, tmpsts;
8885
8886     /* Convenient shorthand. */
8887     e = &dd->entry;
8888
8889     /* Add the version wildcard, ignoring the "*.*" put on before */
8890     i = strlen(dd->pattern);
8891     Newx(text,i + e->d_namlen + 3,char);
8892     strcpy(text, dd->pattern);
8893     sprintf(&text[i - 3], "%s;*", e->d_name);
8894
8895     /* Set up the pattern descriptor. */
8896     pat.dsc$a_pointer = text;
8897     pat.dsc$w_length = i + e->d_namlen - 1;
8898     pat.dsc$b_dtype = DSC$K_DTYPE_T;
8899     pat.dsc$b_class = DSC$K_CLASS_S;
8900
8901     /* Set up result descriptor. */
8902     Newx(buff, VMS_MAXRSS, char);
8903     res.dsc$a_pointer = buff;
8904     res.dsc$w_length = VMS_MAXRSS - 1;
8905     res.dsc$b_dtype = DSC$K_DTYPE_T;
8906     res.dsc$b_class = DSC$K_CLASS_S;
8907
8908     /* Read files, collecting versions. */
8909     for (context = 0, e->vms_verscount = 0;
8910          e->vms_verscount < VERSIZE(e);
8911          e->vms_verscount++) {
8912         unsigned long rsts;
8913         unsigned long flags = 0;
8914
8915 #ifdef VMS_LONGNAME_SUPPORT
8916         flags = LIB$M_FIL_LONG_NAMES;
8917 #endif
8918         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8919         if (tmpsts == RMS$_NMF || context == 0) break;
8920         _ckvmssts(tmpsts);
8921         buff[VMS_MAXRSS - 1] = '\0';
8922         if ((p = strchr(buff, ';')))
8923             e->vms_versions[e->vms_verscount] = atoi(p + 1);
8924         else
8925             e->vms_versions[e->vms_verscount] = -1;
8926     }
8927
8928     _ckvmssts(lib$find_file_end(&context));
8929     Safefree(text);
8930     Safefree(buff);
8931
8932 }  /* end of collectversions() */
8933
8934 /*
8935  *  Read the next entry from the directory.
8936  */
8937 /*{{{ struct dirent *readdir(DIR *dd)*/
8938 struct dirent *
8939 Perl_readdir(pTHX_ DIR *dd)
8940 {
8941     struct dsc$descriptor_s     res;
8942     char *p, *buff;
8943     unsigned long int tmpsts;
8944     unsigned long rsts;
8945     unsigned long flags = 0;
8946     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8947     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8948
8949     /* Set up result descriptor, and get next file. */
8950     Newx(buff, VMS_MAXRSS, char);
8951     res.dsc$a_pointer = buff;
8952     res.dsc$w_length = VMS_MAXRSS - 1;
8953     res.dsc$b_dtype = DSC$K_DTYPE_T;
8954     res.dsc$b_class = DSC$K_CLASS_S;
8955
8956 #ifdef VMS_LONGNAME_SUPPORT
8957     flags = LIB$M_FIL_LONG_NAMES;
8958 #endif
8959
8960     tmpsts = lib$find_file
8961         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8962     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
8963     if (!(tmpsts & 1)) {
8964       set_vaxc_errno(tmpsts);
8965       switch (tmpsts) {
8966         case RMS$_PRV:
8967           set_errno(EACCES); break;
8968         case RMS$_DEV:
8969           set_errno(ENODEV); break;
8970         case RMS$_DIR:
8971           set_errno(ENOTDIR); break;
8972         case RMS$_FNF: case RMS$_DNF:
8973           set_errno(ENOENT); break;
8974         default:
8975           set_errno(EVMSERR);
8976       }
8977       Safefree(buff);
8978       return NULL;
8979     }
8980     dd->count++;
8981     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8982     if (!decc_efs_case_preserve) {
8983       buff[VMS_MAXRSS - 1] = '\0';
8984       for (p = buff; *p; p++) *p = _tolower(*p);
8985     }
8986     else {
8987       /* we don't want to force to lowercase, just null terminate */
8988       buff[res.dsc$w_length] = '\0';
8989     }
8990     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
8991     *p = '\0';
8992
8993     /* Skip any directory component and just copy the name. */
8994     sts = vms_split_path
8995        (buff,
8996         &v_spec,
8997         &v_len,
8998         &r_spec,
8999         &r_len,
9000         &d_spec,
9001         &d_len,
9002         &n_spec,
9003         &n_len,
9004         &e_spec,
9005         &e_len,
9006         &vs_spec,
9007         &vs_len);
9008
9009     /* Drop NULL extensions on UNIX file specification */
9010     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
9011         (e_len == 1) && decc_readdir_dropdotnotype)) {
9012         e_len = 0;
9013         e_spec[0] = '\0';
9014     }
9015
9016     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9017     dd->entry.d_name[n_len + e_len] = '\0';
9018     dd->entry.d_namlen = strlen(dd->entry.d_name);
9019
9020     /* Convert the filename to UNIX format if needed */
9021     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9022
9023         /* Translate the encoded characters. */
9024         /* Fixme: Unicode handling could result in embedded 0 characters */
9025         if (strchr(dd->entry.d_name, '^') != NULL) {
9026             char new_name[256];
9027             char * q;
9028             p = dd->entry.d_name;
9029             q = new_name;
9030             while (*p != 0) {
9031                 int inchars_read, outchars_added;
9032                 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9033                 p += inchars_read;
9034                 q += outchars_added;
9035                 /* fix-me */
9036                 /* if outchars_added > 1, then this is a wide file specification */
9037                 /* Wide file specifications need to be passed in Perl */
9038                 /* counted strings apparently with a Unicode flag */
9039             }
9040             *q = 0;
9041             strcpy(dd->entry.d_name, new_name);
9042             dd->entry.d_namlen = strlen(dd->entry.d_name);
9043         }
9044     }
9045
9046     dd->entry.vms_verscount = 0;
9047     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9048     Safefree(buff);
9049     return &dd->entry;
9050
9051 }  /* end of readdir() */
9052 /*}}}*/
9053
9054 /*
9055  *  Read the next entry from the directory -- thread-safe version.
9056  */
9057 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9058 int
9059 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9060 {
9061     int retval;
9062
9063     MUTEX_LOCK( (perl_mutex *) dd->mutex );
9064
9065     entry = readdir(dd);
9066     *result = entry;
9067     retval = ( *result == NULL ? errno : 0 );
9068
9069     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9070
9071     return retval;
9072
9073 }  /* end of readdir_r() */
9074 /*}}}*/
9075
9076 /*
9077  *  Return something that can be used in a seekdir later.
9078  */
9079 /*{{{ long telldir(DIR *dd)*/
9080 long
9081 Perl_telldir(DIR *dd)
9082 {
9083     return dd->count;
9084 }
9085 /*}}}*/
9086
9087 /*
9088  *  Return to a spot where we used to be.  Brute force.
9089  */
9090 /*{{{ void seekdir(DIR *dd,long count)*/
9091 void
9092 Perl_seekdir(pTHX_ DIR *dd, long count)
9093 {
9094     int old_flags;
9095
9096     /* If we haven't done anything yet... */
9097     if (dd->count == 0)
9098         return;
9099
9100     /* Remember some state, and clear it. */
9101     old_flags = dd->flags;
9102     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9103     _ckvmssts(lib$find_file_end(&dd->context));
9104     dd->context = 0;
9105
9106     /* The increment is in readdir(). */
9107     for (dd->count = 0; dd->count < count; )
9108         readdir(dd);
9109
9110     dd->flags = old_flags;
9111
9112 }  /* end of seekdir() */
9113 /*}}}*/
9114
9115 /* VMS subprocess management
9116  *
9117  * my_vfork() - just a vfork(), after setting a flag to record that
9118  * the current script is trying a Unix-style fork/exec.
9119  *
9120  * vms_do_aexec() and vms_do_exec() are called in response to the
9121  * perl 'exec' function.  If this follows a vfork call, then they
9122  * call out the regular perl routines in doio.c which do an
9123  * execvp (for those who really want to try this under VMS).
9124  * Otherwise, they do exactly what the perl docs say exec should
9125  * do - terminate the current script and invoke a new command
9126  * (See below for notes on command syntax.)
9127  *
9128  * do_aspawn() and do_spawn() implement the VMS side of the perl
9129  * 'system' function.
9130  *
9131  * Note on command arguments to perl 'exec' and 'system': When handled
9132  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9133  * are concatenated to form a DCL command string.  If the first arg
9134  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
9135  * the command string is handed off to DCL directly.  Otherwise,
9136  * the first token of the command is taken as the filespec of an image
9137  * to run.  The filespec is expanded using a default type of '.EXE' and
9138  * the process defaults for device, directory, etc., and if found, the resultant
9139  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9140  * the command string as parameters.  This is perhaps a bit complicated,
9141  * but I hope it will form a happy medium between what VMS folks expect
9142  * from lib$spawn and what Unix folks expect from exec.
9143  */
9144
9145 static int vfork_called;
9146
9147 /*{{{int my_vfork()*/
9148 int
9149 my_vfork()
9150 {
9151   vfork_called++;
9152   return vfork();
9153 }
9154 /*}}}*/
9155
9156
9157 static void
9158 vms_execfree(struct dsc$descriptor_s *vmscmd)
9159 {
9160   if (vmscmd) {
9161       if (vmscmd->dsc$a_pointer) {
9162           PerlMem_free(vmscmd->dsc$a_pointer);
9163       }
9164       PerlMem_free(vmscmd);
9165   }
9166 }
9167
9168 static char *
9169 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9170 {
9171   char *junk, *tmps = Nullch;
9172   register size_t cmdlen = 0;
9173   size_t rlen;
9174   register SV **idx;
9175   STRLEN n_a;
9176
9177   idx = mark;
9178   if (really) {
9179     tmps = SvPV(really,rlen);
9180     if (*tmps) {
9181       cmdlen += rlen + 1;
9182       idx++;
9183     }
9184   }
9185
9186   for (idx++; idx <= sp; idx++) {
9187     if (*idx) {
9188       junk = SvPVx(*idx,rlen);
9189       cmdlen += rlen ? rlen + 1 : 0;
9190     }
9191   }
9192   Newx(PL_Cmd, cmdlen+1, char);
9193
9194   if (tmps && *tmps) {
9195     strcpy(PL_Cmd,tmps);
9196     mark++;
9197   }
9198   else *PL_Cmd = '\0';
9199   while (++mark <= sp) {
9200     if (*mark) {
9201       char *s = SvPVx(*mark,n_a);
9202       if (!*s) continue;
9203       if (*PL_Cmd) strcat(PL_Cmd," ");
9204       strcat(PL_Cmd,s);
9205     }
9206   }
9207   return PL_Cmd;
9208
9209 }  /* end of setup_argstr() */
9210
9211
9212 static unsigned long int
9213 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9214                    struct dsc$descriptor_s **pvmscmd)
9215 {
9216   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9217   char image_name[NAM$C_MAXRSS+1];
9218   char image_argv[NAM$C_MAXRSS+1];
9219   $DESCRIPTOR(defdsc,".EXE");
9220   $DESCRIPTOR(defdsc2,".");
9221   $DESCRIPTOR(resdsc,resspec);
9222   struct dsc$descriptor_s *vmscmd;
9223   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9224   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9225   register char *s, *rest, *cp, *wordbreak;
9226   char * cmd;
9227   int cmdlen;
9228   register int isdcl;
9229
9230   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9231   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9232
9233   /* Make a copy for modification */
9234   cmdlen = strlen(incmd);
9235   cmd = PerlMem_malloc(cmdlen+1);
9236   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9237   strncpy(cmd, incmd, cmdlen);
9238   cmd[cmdlen] = 0;
9239   image_name[0] = 0;
9240   image_argv[0] = 0;
9241
9242   vmscmd->dsc$a_pointer = NULL;
9243   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
9244   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
9245   vmscmd->dsc$w_length = 0;
9246   if (pvmscmd) *pvmscmd = vmscmd;
9247
9248   if (suggest_quote) *suggest_quote = 0;
9249
9250   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9251     PerlMem_free(cmd);
9252     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
9253   }
9254
9255   s = cmd;
9256
9257   while (*s && isspace(*s)) s++;
9258
9259   if (*s == '@' || *s == '$') {
9260     vmsspec[0] = *s;  rest = s + 1;
9261     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9262   }
9263   else { cp = vmsspec; rest = s; }
9264   if (*rest == '.' || *rest == '/') {
9265     char *cp2;
9266     for (cp2 = resspec;
9267          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9268          rest++, cp2++) *cp2 = *rest;
9269     *cp2 = '\0';
9270     if (do_tovmsspec(resspec,cp,0,NULL)) {
9271       s = vmsspec;
9272       if (*rest) {
9273         for (cp2 = vmsspec + strlen(vmsspec);
9274              *rest && cp2 - vmsspec < sizeof vmsspec;
9275              rest++, cp2++) *cp2 = *rest;
9276         *cp2 = '\0';
9277       }
9278     }
9279   }
9280   /* Intuit whether verb (first word of cmd) is a DCL command:
9281    *   - if first nonspace char is '@', it's a DCL indirection
9282    * otherwise
9283    *   - if verb contains a filespec separator, it's not a DCL command
9284    *   - if it doesn't, caller tells us whether to default to a DCL
9285    *     command, or to a local image unless told it's DCL (by leading '$')
9286    */
9287   if (*s == '@') {
9288       isdcl = 1;
9289       if (suggest_quote) *suggest_quote = 1;
9290   } else {
9291     register char *filespec = strpbrk(s,":<[.;");
9292     rest = wordbreak = strpbrk(s," \"\t/");
9293     if (!wordbreak) wordbreak = s + strlen(s);
9294     if (*s == '$') check_img = 0;
9295     if (filespec && (filespec < wordbreak)) isdcl = 0;
9296     else isdcl = !check_img;
9297   }
9298
9299   if (!isdcl) {
9300     int rsts;
9301     imgdsc.dsc$a_pointer = s;
9302     imgdsc.dsc$w_length = wordbreak - s;
9303     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9304     if (!(retsts&1)) {
9305         _ckvmssts(lib$find_file_end(&cxt));
9306         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9307       if (!(retsts & 1) && *s == '$') {
9308         _ckvmssts(lib$find_file_end(&cxt));
9309         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9310         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9311         if (!(retsts&1)) {
9312           _ckvmssts(lib$find_file_end(&cxt));
9313           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9314         }
9315       }
9316     }
9317     _ckvmssts(lib$find_file_end(&cxt));
9318
9319     if (retsts & 1) {
9320       FILE *fp;
9321       s = resspec;
9322       while (*s && !isspace(*s)) s++;
9323       *s = '\0';
9324
9325       /* check that it's really not DCL with no file extension */
9326       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9327       if (fp) {
9328         char b[256] = {0,0,0,0};
9329         read(fileno(fp), b, 256);
9330         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9331         if (isdcl) {
9332           int shebang_len;
9333
9334           /* Check for script */
9335           shebang_len = 0;
9336           if ((b[0] == '#') && (b[1] == '!'))
9337              shebang_len = 2;
9338 #ifdef ALTERNATE_SHEBANG
9339           else {
9340             shebang_len = strlen(ALTERNATE_SHEBANG);
9341             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9342               char * perlstr;
9343                 perlstr = strstr("perl",b);
9344                 if (perlstr == NULL)
9345                   shebang_len = 0;
9346             }
9347             else
9348               shebang_len = 0;
9349           }
9350 #endif
9351
9352           if (shebang_len > 0) {
9353           int i;
9354           int j;
9355           char tmpspec[NAM$C_MAXRSS + 1];
9356
9357             i = shebang_len;
9358              /* Image is following after white space */
9359             /*--------------------------------------*/
9360             while (isprint(b[i]) && isspace(b[i]))
9361                 i++;
9362
9363             j = 0;
9364             while (isprint(b[i]) && !isspace(b[i])) {
9365                 tmpspec[j++] = b[i++];
9366                 if (j >= NAM$C_MAXRSS)
9367                    break;
9368             }
9369             tmpspec[j] = '\0';
9370
9371              /* There may be some default parameters to the image */
9372             /*---------------------------------------------------*/
9373             j = 0;
9374             while (isprint(b[i])) {
9375                 image_argv[j++] = b[i++];
9376                 if (j >= NAM$C_MAXRSS)
9377                    break;
9378             }
9379             while ((j > 0) && !isprint(image_argv[j-1]))
9380                 j--;
9381             image_argv[j] = 0;
9382
9383             /* It will need to be converted to VMS format and validated */
9384             if (tmpspec[0] != '\0') {
9385               char * iname;
9386
9387                /* Try to find the exact program requested to be run */
9388               /*---------------------------------------------------*/
9389               iname = do_rmsexpand
9390                  (tmpspec, image_name, 0, ".exe",
9391                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
9392               if (iname != NULL) {
9393                 if (cando_by_name_int
9394                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9395                   /* MCR prefix needed */
9396                   isdcl = 0;
9397                 }
9398                 else {
9399                    /* Try again with a null type */
9400                   /*----------------------------*/
9401                   iname = do_rmsexpand
9402                     (tmpspec, image_name, 0, ".",
9403                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
9404                   if (iname != NULL) {
9405                     if (cando_by_name_int
9406                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9407                       /* MCR prefix needed */
9408                       isdcl = 0;
9409                     }
9410                   }
9411                 }
9412
9413                  /* Did we find the image to run the script? */
9414                 /*------------------------------------------*/
9415                 if (isdcl) {
9416                   char *tchr;
9417
9418                    /* Assume DCL or foreign command exists */
9419                   /*--------------------------------------*/
9420                   tchr = strrchr(tmpspec, '/');
9421                   if (tchr != NULL) {
9422                     tchr++;
9423                   }
9424                   else {
9425                     tchr = tmpspec;
9426                   }
9427                   strcpy(image_name, tchr);
9428                 }
9429               }
9430             }
9431           }
9432         }
9433         fclose(fp);
9434       }
9435       if (check_img && isdcl) return RMS$_FNF;
9436
9437       if (cando_by_name(S_IXUSR,0,resspec)) {
9438         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9439         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9440         if (!isdcl) {
9441             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9442             if (image_name[0] != 0) {
9443                 strcat(vmscmd->dsc$a_pointer, image_name);
9444                 strcat(vmscmd->dsc$a_pointer, " ");
9445             }
9446         } else if (image_name[0] != 0) {
9447             strcpy(vmscmd->dsc$a_pointer, image_name);
9448             strcat(vmscmd->dsc$a_pointer, " ");
9449         } else {
9450             strcpy(vmscmd->dsc$a_pointer,"@");
9451         }
9452         if (suggest_quote) *suggest_quote = 1;
9453
9454         /* If there is an image name, use original command */
9455         if (image_name[0] == 0)
9456             strcat(vmscmd->dsc$a_pointer,resspec);
9457         else {
9458             rest = cmd;
9459             while (*rest && isspace(*rest)) rest++;
9460         }
9461
9462         if (image_argv[0] != 0) {
9463           strcat(vmscmd->dsc$a_pointer,image_argv);
9464           strcat(vmscmd->dsc$a_pointer, " ");
9465         }
9466         if (rest) {
9467            int rest_len;
9468            int vmscmd_len;
9469
9470            rest_len = strlen(rest);
9471            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9472            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9473               strcat(vmscmd->dsc$a_pointer,rest);
9474            else
9475              retsts = CLI$_BUFOVF;
9476         }
9477         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9478         PerlMem_free(cmd);
9479         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9480       }
9481       else
9482         retsts = RMS$_PRV;
9483     }
9484   }
9485   /* It's either a DCL command or we couldn't find a suitable image */
9486   vmscmd->dsc$w_length = strlen(cmd);
9487
9488   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9489   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9490   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9491
9492   PerlMem_free(cmd);
9493
9494   /* check if it's a symbol (for quoting purposes) */
9495   if (suggest_quote && !*suggest_quote) {
9496     int iss;
9497     char equiv[LNM$C_NAMLENGTH];
9498     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9499     eqvdsc.dsc$a_pointer = equiv;
9500
9501     iss = lib$get_symbol(vmscmd,&eqvdsc);
9502     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9503   }
9504   if (!(retsts & 1)) {
9505     /* just hand off status values likely to be due to user error */
9506     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9507         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9508        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9509     else { _ckvmssts(retsts); }
9510   }
9511
9512   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9513
9514 }  /* end of setup_cmddsc() */
9515
9516
9517 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9518 bool
9519 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9520 {
9521 bool exec_sts;
9522 char * cmd;
9523
9524   if (sp > mark) {
9525     if (vfork_called) {           /* this follows a vfork - act Unixish */
9526       vfork_called--;
9527       if (vfork_called < 0) {
9528         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9529         vfork_called = 0;
9530       }
9531       else return do_aexec(really,mark,sp);
9532     }
9533                                            /* no vfork - act VMSish */
9534     cmd = setup_argstr(aTHX_ really,mark,sp);
9535     exec_sts = vms_do_exec(cmd);
9536     Safefree(cmd);  /* Clean up from setup_argstr() */
9537     return exec_sts;
9538   }
9539
9540   return FALSE;
9541 }  /* end of vms_do_aexec() */
9542 /*}}}*/
9543
9544 /* {{{bool vms_do_exec(char *cmd) */
9545 bool
9546 Perl_vms_do_exec(pTHX_ const char *cmd)
9547 {
9548   struct dsc$descriptor_s *vmscmd;
9549
9550   if (vfork_called) {             /* this follows a vfork - act Unixish */
9551     vfork_called--;
9552     if (vfork_called < 0) {
9553       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9554       vfork_called = 0;
9555     }
9556     else return do_exec(cmd);
9557   }
9558
9559   {                               /* no vfork - act VMSish */
9560     unsigned long int retsts;
9561
9562     TAINT_ENV();
9563     TAINT_PROPER("exec");
9564     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9565       retsts = lib$do_command(vmscmd);
9566
9567     switch (retsts) {
9568       case RMS$_FNF: case RMS$_DNF:
9569         set_errno(ENOENT); break;
9570       case RMS$_DIR:
9571         set_errno(ENOTDIR); break;
9572       case RMS$_DEV:
9573         set_errno(ENODEV); break;
9574       case RMS$_PRV:
9575         set_errno(EACCES); break;
9576       case RMS$_SYN:
9577         set_errno(EINVAL); break;
9578       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9579         set_errno(E2BIG); break;
9580       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9581         _ckvmssts(retsts); /* fall through */
9582       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9583         set_errno(EVMSERR);
9584     }
9585     set_vaxc_errno(retsts);
9586     if (ckWARN(WARN_EXEC)) {
9587       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9588              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9589     }
9590     vms_execfree(vmscmd);
9591   }
9592
9593   return FALSE;
9594
9595 }  /* end of vms_do_exec() */
9596 /*}}}*/
9597
9598 unsigned long int Perl_do_spawn(pTHX_ const char *);
9599
9600 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9601 unsigned long int
9602 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9603 {
9604 unsigned long int sts;
9605 char * cmd;
9606
9607   if (sp > mark) {
9608     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9609     sts = do_spawn(cmd);
9610     /* pp_sys will clean up cmd */
9611     return sts;
9612   }
9613   return SS$_ABORT;
9614 }  /* end of do_aspawn() */
9615 /*}}}*/
9616
9617 /* {{{unsigned long int do_spawn(char *cmd) */
9618 unsigned long int
9619 Perl_do_spawn(pTHX_ const char *cmd)
9620 {
9621   unsigned long int sts, substs;
9622
9623   /* The caller of this routine expects to Safefree(PL_Cmd) */
9624   Newx(PL_Cmd,10,char);
9625
9626   TAINT_ENV();
9627   TAINT_PROPER("spawn");
9628   if (!cmd || !*cmd) {
9629     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9630     if (!(sts & 1)) {
9631       switch (sts) {
9632         case RMS$_FNF:  case RMS$_DNF:
9633           set_errno(ENOENT); break;
9634         case RMS$_DIR:
9635           set_errno(ENOTDIR); break;
9636         case RMS$_DEV:
9637           set_errno(ENODEV); break;
9638         case RMS$_PRV:
9639           set_errno(EACCES); break;
9640         case RMS$_SYN:
9641           set_errno(EINVAL); break;
9642         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9643           set_errno(E2BIG); break;
9644         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9645           _ckvmssts(sts); /* fall through */
9646         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9647           set_errno(EVMSERR);
9648       }
9649       set_vaxc_errno(sts);
9650       if (ckWARN(WARN_EXEC)) {
9651         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9652                     Strerror(errno));
9653       }
9654     }
9655     sts = substs;
9656   }
9657   else {
9658     PerlIO * fp;
9659     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9660     if (fp != NULL)
9661       my_pclose(fp);
9662   }
9663   return sts;
9664 }  /* end of do_spawn() */
9665 /*}}}*/
9666
9667
9668 static unsigned int *sockflags, sockflagsize;
9669
9670 /*
9671  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9672  * routines found in some versions of the CRTL can't deal with sockets.
9673  * We don't shim the other file open routines since a socket isn't
9674  * likely to be opened by a name.
9675  */
9676 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9677 FILE *my_fdopen(int fd, const char *mode)
9678 {
9679   FILE *fp = fdopen(fd, mode);
9680
9681   if (fp) {
9682     unsigned int fdoff = fd / sizeof(unsigned int);
9683     Stat_t sbuf; /* native stat; we don't need flex_stat */
9684     if (!sockflagsize || fdoff > sockflagsize) {
9685       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
9686       else           Newx  (sockflags,fdoff+2,unsigned int);
9687       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9688       sockflagsize = fdoff + 2;
9689     }
9690     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9691       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9692   }
9693   return fp;
9694
9695 }
9696 /*}}}*/
9697
9698
9699 /*
9700  * Clear the corresponding bit when the (possibly) socket stream is closed.
9701  * There still a small hole: we miss an implicit close which might occur
9702  * via freopen().  >> Todo
9703  */
9704 /*{{{ int my_fclose(FILE *fp)*/
9705 int my_fclose(FILE *fp) {
9706   if (fp) {
9707     unsigned int fd = fileno(fp);
9708     unsigned int fdoff = fd / sizeof(unsigned int);
9709
9710     if (sockflagsize && fdoff <= sockflagsize)
9711       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9712   }
9713   return fclose(fp);
9714 }
9715 /*}}}*/
9716
9717
9718 /*
9719  * A simple fwrite replacement which outputs itmsz*nitm chars without
9720  * introducing record boundaries every itmsz chars.
9721  * We are using fputs, which depends on a terminating null.  We may
9722  * well be writing binary data, so we need to accommodate not only
9723  * data with nulls sprinkled in the middle but also data with no null
9724  * byte at the end.
9725  */
9726 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9727 int
9728 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9729 {
9730   register char *cp, *end, *cpd, *data;
9731   register unsigned int fd = fileno(dest);
9732   register unsigned int fdoff = fd / sizeof(unsigned int);
9733   int retval;
9734   int bufsize = itmsz * nitm + 1;
9735
9736   if (fdoff < sockflagsize &&
9737       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9738     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9739     return nitm;
9740   }
9741
9742   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9743   memcpy( data, src, itmsz*nitm );
9744   data[itmsz*nitm] = '\0';
9745
9746   end = data + itmsz * nitm;
9747   retval = (int) nitm; /* on success return # items written */
9748
9749   cpd = data;
9750   while (cpd <= end) {
9751     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9752     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9753     if (cp < end)
9754       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9755     cpd = cp + 1;
9756   }
9757
9758   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9759   return retval;
9760
9761 }  /* end of my_fwrite() */
9762 /*}}}*/
9763
9764 /*{{{ int my_flush(FILE *fp)*/
9765 int
9766 Perl_my_flush(pTHX_ FILE *fp)
9767 {
9768     int res;
9769     if ((res = fflush(fp)) == 0 && fp) {
9770 #ifdef VMS_DO_SOCKETS
9771         Stat_t s;
9772         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9773 #endif
9774             res = fsync(fileno(fp));
9775     }
9776 /*
9777  * If the flush succeeded but set end-of-file, we need to clear
9778  * the error because our caller may check ferror().  BTW, this
9779  * probably means we just flushed an empty file.
9780  */
9781     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9782
9783     return res;
9784 }
9785 /*}}}*/
9786
9787 /*
9788  * Here are replacements for the following Unix routines in the VMS environment:
9789  *      getpwuid    Get information for a particular UIC or UID
9790  *      getpwnam    Get information for a named user
9791  *      getpwent    Get information for each user in the rights database
9792  *      setpwent    Reset search to the start of the rights database
9793  *      endpwent    Finish searching for users in the rights database
9794  *
9795  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9796  * (defined in pwd.h), which contains the following fields:-
9797  *      struct passwd {
9798  *              char        *pw_name;    Username (in lower case)
9799  *              char        *pw_passwd;  Hashed password
9800  *              unsigned int pw_uid;     UIC
9801  *              unsigned int pw_gid;     UIC group  number
9802  *              char        *pw_unixdir; Default device/directory (VMS-style)
9803  *              char        *pw_gecos;   Owner name
9804  *              char        *pw_dir;     Default device/directory (Unix-style)
9805  *              char        *pw_shell;   Default CLI name (eg. DCL)
9806  *      };
9807  * If the specified user does not exist, getpwuid and getpwnam return NULL.
9808  *
9809  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9810  * not the UIC member number (eg. what's returned by getuid()),
9811  * getpwuid() can accept either as input (if uid is specified, the caller's
9812  * UIC group is used), though it won't recognise gid=0.
9813  *
9814  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9815  * information about other users in your group or in other groups, respectively.
9816  * If the required privilege is not available, then these routines fill only
9817  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9818  * string).
9819  *
9820  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9821  */
9822
9823 /* sizes of various UAF record fields */
9824 #define UAI$S_USERNAME 12
9825 #define UAI$S_IDENT    31
9826 #define UAI$S_OWNER    31
9827 #define UAI$S_DEFDEV   31
9828 #define UAI$S_DEFDIR   63
9829 #define UAI$S_DEFCLI   31
9830 #define UAI$S_PWD       8
9831
9832 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
9833                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9834                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
9835
9836 static char __empty[]= "";
9837 static struct passwd __passwd_empty=
9838     {(char *) __empty, (char *) __empty, 0, 0,
9839      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9840 static int contxt= 0;
9841 static struct passwd __pwdcache;
9842 static char __pw_namecache[UAI$S_IDENT+1];
9843
9844 /*
9845  * This routine does most of the work extracting the user information.
9846  */
9847 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9848 {
9849     static struct {
9850         unsigned char length;
9851         char pw_gecos[UAI$S_OWNER+1];
9852     } owner;
9853     static union uicdef uic;
9854     static struct {
9855         unsigned char length;
9856         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9857     } defdev;
9858     static struct {
9859         unsigned char length;
9860         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9861     } defdir;
9862     static struct {
9863         unsigned char length;
9864         char pw_shell[UAI$S_DEFCLI+1];
9865     } defcli;
9866     static char pw_passwd[UAI$S_PWD+1];
9867
9868     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9869     struct dsc$descriptor_s name_desc;
9870     unsigned long int sts;
9871
9872     static struct itmlst_3 itmlst[]= {
9873         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
9874         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
9875         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
9876         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
9877         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
9878         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
9879         {0,                0,           NULL,    NULL}};
9880
9881     name_desc.dsc$w_length=  strlen(name);
9882     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9883     name_desc.dsc$b_class=   DSC$K_CLASS_S;
9884     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9885
9886 /*  Note that sys$getuai returns many fields as counted strings. */
9887     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9888     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9889       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9890     }
9891     else { _ckvmssts(sts); }
9892     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
9893
9894     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
9895     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9896     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9897     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9898     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9899     owner.pw_gecos[lowner]=            '\0';
9900     defdev.pw_dir[ldefdev+ldefdir]= '\0';
9901     defcli.pw_shell[ldefcli]=          '\0';
9902     if (valid_uic(uic)) {
9903         pwd->pw_uid= uic.uic$l_uic;
9904         pwd->pw_gid= uic.uic$v_group;
9905     }
9906     else
9907       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9908     pwd->pw_passwd=  pw_passwd;
9909     pwd->pw_gecos=   owner.pw_gecos;
9910     pwd->pw_dir=     defdev.pw_dir;
9911     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9912     pwd->pw_shell=   defcli.pw_shell;
9913     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9914         int ldir;
9915         ldir= strlen(pwd->pw_unixdir) - 1;
9916         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9917     }
9918     else
9919         strcpy(pwd->pw_unixdir, pwd->pw_dir);
9920     if (!decc_efs_case_preserve)
9921         __mystrtolower(pwd->pw_unixdir);
9922     return 1;
9923 }
9924
9925 /*
9926  * Get information for a named user.
9927 */
9928 /*{{{struct passwd *getpwnam(char *name)*/
9929 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9930 {
9931     struct dsc$descriptor_s name_desc;
9932     union uicdef uic;
9933     unsigned long int status, sts;
9934
9935     __pwdcache = __passwd_empty;
9936     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9937       /* We still may be able to determine pw_uid and pw_gid */
9938       name_desc.dsc$w_length=  strlen(name);
9939       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9940       name_desc.dsc$b_class=   DSC$K_CLASS_S;
9941       name_desc.dsc$a_pointer= (char *) name;
9942       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9943         __pwdcache.pw_uid= uic.uic$l_uic;
9944         __pwdcache.pw_gid= uic.uic$v_group;
9945       }
9946       else {
9947         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9948           set_vaxc_errno(sts);
9949           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9950           return NULL;
9951         }
9952         else { _ckvmssts(sts); }
9953       }
9954     }
9955     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9956     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9957     __pwdcache.pw_name= __pw_namecache;
9958     return &__pwdcache;
9959 }  /* end of my_getpwnam() */
9960 /*}}}*/
9961
9962 /*
9963  * Get information for a particular UIC or UID.
9964  * Called by my_getpwent with uid=-1 to list all users.
9965 */
9966 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9967 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9968 {
9969     const $DESCRIPTOR(name_desc,__pw_namecache);
9970     unsigned short lname;
9971     union uicdef uic;
9972     unsigned long int status;
9973
9974     if (uid == (unsigned int) -1) {
9975       do {
9976         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9977         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9978           set_vaxc_errno(status);
9979           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9980           my_endpwent();
9981           return NULL;
9982         }
9983         else { _ckvmssts(status); }
9984       } while (!valid_uic (uic));
9985     }
9986     else {
9987       uic.uic$l_uic= uid;
9988       if (!uic.uic$v_group)
9989         uic.uic$v_group= PerlProc_getgid();
9990       if (valid_uic(uic))
9991         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9992       else status = SS$_IVIDENT;
9993       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9994           status == RMS$_PRV) {
9995         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9996         return NULL;
9997       }
9998       else { _ckvmssts(status); }
9999     }
10000     __pw_namecache[lname]= '\0';
10001     __mystrtolower(__pw_namecache);
10002
10003     __pwdcache = __passwd_empty;
10004     __pwdcache.pw_name = __pw_namecache;
10005
10006 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10007     The identifier's value is usually the UIC, but it doesn't have to be,
10008     so if we can, we let fillpasswd update this. */
10009     __pwdcache.pw_uid =  uic.uic$l_uic;
10010     __pwdcache.pw_gid =  uic.uic$v_group;
10011
10012     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10013     return &__pwdcache;
10014
10015 }  /* end of my_getpwuid() */
10016 /*}}}*/
10017
10018 /*
10019  * Get information for next user.
10020 */
10021 /*{{{struct passwd *my_getpwent()*/
10022 struct passwd *Perl_my_getpwent(pTHX)
10023 {
10024     return (my_getpwuid((unsigned int) -1));
10025 }
10026 /*}}}*/
10027
10028 /*
10029  * Finish searching rights database for users.
10030 */
10031 /*{{{void my_endpwent()*/
10032 void Perl_my_endpwent(pTHX)
10033 {
10034     if (contxt) {
10035       _ckvmssts(sys$finish_rdb(&contxt));
10036       contxt= 0;
10037     }
10038 }
10039 /*}}}*/
10040
10041 #ifdef HOMEGROWN_POSIX_SIGNALS
10042   /* Signal handling routines, pulled into the core from POSIX.xs.
10043    *
10044    * We need these for threads, so they've been rolled into the core,
10045    * rather than left in POSIX.xs.
10046    *
10047    * (DRS, Oct 23, 1997)
10048    */
10049
10050   /* sigset_t is atomic under VMS, so these routines are easy */
10051 /*{{{int my_sigemptyset(sigset_t *) */
10052 int my_sigemptyset(sigset_t *set) {
10053     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10054     *set = 0; return 0;
10055 }
10056 /*}}}*/
10057
10058
10059 /*{{{int my_sigfillset(sigset_t *)*/
10060 int my_sigfillset(sigset_t *set) {
10061     int i;
10062     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10063     for (i = 0; i < NSIG; i++) *set |= (1 << i);
10064     return 0;
10065 }
10066 /*}}}*/
10067
10068
10069 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10070 int my_sigaddset(sigset_t *set, int sig) {
10071     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10072     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10073     *set |= (1 << (sig - 1));
10074     return 0;
10075 }
10076 /*}}}*/
10077
10078
10079 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10080 int my_sigdelset(sigset_t *set, int sig) {
10081     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10082     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10083     *set &= ~(1 << (sig - 1));
10084     return 0;
10085 }
10086 /*}}}*/
10087
10088
10089 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10090 int my_sigismember(sigset_t *set, int sig) {
10091     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10092     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10093     return *set & (1 << (sig - 1));
10094 }
10095 /*}}}*/
10096
10097
10098 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10099 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10100     sigset_t tempmask;
10101
10102     /* If set and oset are both null, then things are badly wrong. Bail out. */
10103     if ((oset == NULL) && (set == NULL)) {
10104       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10105       return -1;
10106     }
10107
10108     /* If set's null, then we're just handling a fetch. */
10109     if (set == NULL) {
10110         tempmask = sigblock(0);
10111     }
10112     else {
10113       switch (how) {
10114       case SIG_SETMASK:
10115         tempmask = sigsetmask(*set);
10116         break;
10117       case SIG_BLOCK:
10118         tempmask = sigblock(*set);
10119         break;
10120       case SIG_UNBLOCK:
10121         tempmask = sigblock(0);
10122         sigsetmask(*oset & ~tempmask);
10123         break;
10124       default:
10125         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10126         return -1;
10127       }
10128     }
10129
10130     /* Did they pass us an oset? If so, stick our holding mask into it */
10131     if (oset)
10132       *oset = tempmask;
10133
10134     return 0;
10135 }
10136 /*}}}*/
10137 #endif  /* HOMEGROWN_POSIX_SIGNALS */
10138
10139
10140 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10141  * my_utime(), and flex_stat(), all of which operate on UTC unless
10142  * VMSISH_TIMES is true.
10143  */
10144 /* method used to handle UTC conversions:
10145  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
10146  */
10147 static int gmtime_emulation_type;
10148 /* number of secs to add to UTC POSIX-style time to get local time */
10149 static long int utc_offset_secs;
10150
10151 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10152  * in vmsish.h.  #undef them here so we can call the CRTL routines
10153  * directly.
10154  */
10155 #undef gmtime
10156 #undef localtime
10157 #undef time
10158
10159
10160 /*
10161  * DEC C previous to 6.0 corrupts the behavior of the /prefix
10162  * qualifier with the extern prefix pragma.  This provisional
10163  * hack circumvents this prefix pragma problem in previous
10164  * precompilers.
10165  */
10166 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10167 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10168 #    pragma __extern_prefix save
10169 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
10170 #    define gmtime decc$__utctz_gmtime
10171 #    define localtime decc$__utctz_localtime
10172 #    define time decc$__utc_time
10173 #    pragma __extern_prefix restore
10174
10175      struct tm *gmtime(), *localtime();
10176
10177 #  endif
10178 #endif
10179
10180
10181 static time_t toutc_dst(time_t loc) {
10182   struct tm *rsltmp;
10183
10184   if ((rsltmp = localtime(&loc)) == NULL) return -1;
10185   loc -= utc_offset_secs;
10186   if (rsltmp->tm_isdst) loc -= 3600;
10187   return loc;
10188 }
10189 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10190        ((gmtime_emulation_type || my_time(NULL)), \
10191        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10192        ((secs) - utc_offset_secs))))
10193
10194 static time_t toloc_dst(time_t utc) {
10195   struct tm *rsltmp;
10196
10197   utc += utc_offset_secs;
10198   if ((rsltmp = localtime(&utc)) == NULL) return -1;
10199   if (rsltmp->tm_isdst) utc += 3600;
10200   return utc;
10201 }
10202 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10203        ((gmtime_emulation_type || my_time(NULL)), \
10204        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10205        ((secs) + utc_offset_secs))))
10206
10207 #ifndef RTL_USES_UTC
10208 /*
10209
10210     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
10211         DST starts on 1st sun of april      at 02:00  std time
10212             ends on last sun of october     at 02:00  dst time
10213     see the UCX management command reference, SET CONFIG TIMEZONE
10214     for formatting info.
10215
10216     No, it's not as general as it should be, but then again, NOTHING
10217     will handle UK times in a sensible way.
10218 */
10219
10220
10221 /*
10222     parse the DST start/end info:
10223     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10224 */
10225
10226 static char *
10227 tz_parse_startend(char *s, struct tm *w, int *past)
10228 {
10229     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10230     int ly, dozjd, d, m, n, hour, min, sec, j, k;
10231     time_t g;
10232
10233     if (!s)    return 0;
10234     if (!w) return 0;
10235     if (!past) return 0;
10236
10237     ly = 0;
10238     if (w->tm_year % 4        == 0) ly = 1;
10239     if (w->tm_year % 100      == 0) ly = 0;
10240     if (w->tm_year+1900 % 400 == 0) ly = 1;
10241     if (ly) dinm[1]++;
10242
10243     dozjd = isdigit(*s);
10244     if (*s == 'J' || *s == 'j' || dozjd) {
10245         if (!dozjd && !isdigit(*++s)) return 0;
10246         d = *s++ - '0';
10247         if (isdigit(*s)) {
10248             d = d*10 + *s++ - '0';
10249             if (isdigit(*s)) {
10250                 d = d*10 + *s++ - '0';
10251             }
10252         }
10253         if (d == 0) return 0;
10254         if (d > 366) return 0;
10255         d--;
10256         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
10257         g = d * 86400;
10258         dozjd = 1;
10259     } else if (*s == 'M' || *s == 'm') {
10260         if (!isdigit(*++s)) return 0;
10261         m = *s++ - '0';
10262         if (isdigit(*s)) m = 10*m + *s++ - '0';
10263         if (*s != '.') return 0;
10264         if (!isdigit(*++s)) return 0;
10265         n = *s++ - '0';
10266         if (n < 1 || n > 5) return 0;
10267         if (*s != '.') return 0;
10268         if (!isdigit(*++s)) return 0;
10269         d = *s++ - '0';
10270         if (d > 6) return 0;
10271     }
10272
10273     if (*s == '/') {
10274         if (!isdigit(*++s)) return 0;
10275         hour = *s++ - '0';
10276         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10277         if (*s == ':') {
10278             if (!isdigit(*++s)) return 0;
10279             min = *s++ - '0';
10280             if (isdigit(*s)) min = 10*min + *s++ - '0';
10281             if (*s == ':') {
10282                 if (!isdigit(*++s)) return 0;
10283                 sec = *s++ - '0';
10284                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10285             }
10286         }
10287     } else {
10288         hour = 2;
10289         min = 0;
10290         sec = 0;
10291     }
10292
10293     if (dozjd) {
10294         if (w->tm_yday < d) goto before;
10295         if (w->tm_yday > d) goto after;
10296     } else {
10297         if (w->tm_mon+1 < m) goto before;
10298         if (w->tm_mon+1 > m) goto after;
10299
10300         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
10301         k = d - j; /* mday of first d */
10302         if (k <= 0) k += 7;
10303         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
10304         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10305         if (w->tm_mday < k) goto before;
10306         if (w->tm_mday > k) goto after;
10307     }
10308
10309     if (w->tm_hour < hour) goto before;
10310     if (w->tm_hour > hour) goto after;
10311     if (w->tm_min  < min)  goto before;
10312     if (w->tm_min  > min)  goto after;
10313     if (w->tm_sec  < sec)  goto before;
10314     goto after;
10315
10316 before:
10317     *past = 0;
10318     return s;
10319 after:
10320     *past = 1;
10321     return s;
10322 }
10323
10324
10325
10326
10327 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
10328
10329 static char *
10330 tz_parse_offset(char *s, int *offset)
10331 {
10332     int hour = 0, min = 0, sec = 0;
10333     int neg = 0;
10334     if (!s) return 0;
10335     if (!offset) return 0;
10336
10337     if (*s == '-') {neg++; s++;}
10338     if (*s == '+') s++;
10339     if (!isdigit(*s)) return 0;
10340     hour = *s++ - '0';
10341     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10342     if (hour > 24) return 0;
10343     if (*s == ':') {
10344         if (!isdigit(*++s)) return 0;
10345         min = *s++ - '0';
10346         if (isdigit(*s)) min = min*10 + (*s++ - '0');
10347         if (min > 59) return 0;
10348         if (*s == ':') {
10349             if (!isdigit(*++s)) return 0;
10350             sec = *s++ - '0';
10351             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10352             if (sec > 59) return 0;
10353         }
10354     }
10355
10356     *offset = (hour*60+min)*60 + sec;
10357     if (neg) *offset = -*offset;
10358     return s;
10359 }
10360
10361 /*
10362     input time is w, whatever type of time the CRTL localtime() uses.
10363     sets dst, the zone, and the gmtoff (seconds)
10364
10365     caches the value of TZ and UCX$TZ env variables; note that
10366     my_setenv looks for these and sets a flag if they're changed
10367     for efficiency.
10368
10369     We have to watch out for the "australian" case (dst starts in
10370     october, ends in april)...flagged by "reverse" and checked by
10371     scanning through the months of the previous year.
10372
10373 */
10374
10375 static int
10376 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10377 {
10378     time_t when;
10379     struct tm *w2;
10380     char *s,*s2;
10381     char *dstzone, *tz, *s_start, *s_end;
10382     int std_off, dst_off, isdst;
10383     int y, dststart, dstend;
10384     static char envtz[1025];  /* longer than any logical, symbol, ... */
10385     static char ucxtz[1025];
10386     static char reversed = 0;
10387
10388     if (!w) return 0;
10389
10390     if (tz_updated) {
10391         tz_updated = 0;
10392         reversed = -1;  /* flag need to check  */
10393         envtz[0] = ucxtz[0] = '\0';
10394         tz = my_getenv("TZ",0);
10395         if (tz) strcpy(envtz, tz);
10396         tz = my_getenv("UCX$TZ",0);
10397         if (tz) strcpy(ucxtz, tz);
10398         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
10399     }
10400     tz = envtz;
10401     if (!*tz) tz = ucxtz;
10402
10403     s = tz;
10404     while (isalpha(*s)) s++;
10405     s = tz_parse_offset(s, &std_off);
10406     if (!s) return 0;
10407     if (!*s) {                  /* no DST, hurray we're done! */
10408         isdst = 0;
10409         goto done;
10410     }
10411
10412     dstzone = s;
10413     while (isalpha(*s)) s++;
10414     s2 = tz_parse_offset(s, &dst_off);
10415     if (s2) {
10416         s = s2;
10417     } else {
10418         dst_off = std_off - 3600;
10419     }
10420
10421     if (!*s) {      /* default dst start/end?? */
10422         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
10423             s = strchr(ucxtz,',');
10424         }
10425         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
10426     }
10427     if (*s != ',') return 0;
10428
10429     when = *w;
10430     when = _toutc(when);      /* convert to utc */
10431     when = when - std_off;    /* convert to pseudolocal time*/
10432
10433     w2 = localtime(&when);
10434     y = w2->tm_year;
10435     s_start = s+1;
10436     s = tz_parse_startend(s_start,w2,&dststart);
10437     if (!s) return 0;
10438     if (*s != ',') return 0;
10439
10440     when = *w;
10441     when = _toutc(when);      /* convert to utc */
10442     when = when - dst_off;    /* convert to pseudolocal time*/
10443     w2 = localtime(&when);
10444     if (w2->tm_year != y) {   /* spans a year, just check one time */
10445         when += dst_off - std_off;
10446         w2 = localtime(&when);
10447     }
10448     s_end = s+1;
10449     s = tz_parse_startend(s_end,w2,&dstend);
10450     if (!s) return 0;
10451
10452     if (reversed == -1) {  /* need to check if start later than end */
10453         int j, ds, de;
10454
10455         when = *w;
10456         if (when < 2*365*86400) {
10457             when += 2*365*86400;
10458         } else {
10459             when -= 365*86400;
10460         }
10461         w2 =localtime(&when);
10462         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
10463
10464         for (j = 0; j < 12; j++) {
10465             w2 =localtime(&when);
10466             tz_parse_startend(s_start,w2,&ds);
10467             tz_parse_startend(s_end,w2,&de);
10468             if (ds != de) break;
10469             when += 30*86400;
10470         }
10471         reversed = 0;
10472         if (de && !ds) reversed = 1;
10473     }
10474
10475     isdst = dststart && !dstend;
10476     if (reversed) isdst = dststart  || !dstend;
10477
10478 done:
10479     if (dst)    *dst = isdst;
10480     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10481     if (isdst)  tz = dstzone;
10482     if (zone) {
10483         while(isalpha(*tz))  *zone++ = *tz++;
10484         *zone = '\0';
10485     }
10486     return 1;
10487 }
10488
10489 #endif /* !RTL_USES_UTC */
10490
10491 /* my_time(), my_localtime(), my_gmtime()
10492  * By default traffic in UTC time values, using CRTL gmtime() or
10493  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10494  * Note: We need to use these functions even when the CRTL has working
10495  * UTC support, since they also handle C<use vmsish qw(times);>
10496  *
10497  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
10498  * Modified by Charles Bailey <bailey@newman.upenn.edu>
10499  */
10500
10501 /*{{{time_t my_time(time_t *timep)*/
10502 time_t Perl_my_time(pTHX_ time_t *timep)
10503 {
10504   time_t when;
10505   struct tm *tm_p;
10506
10507   if (gmtime_emulation_type == 0) {
10508     int dstnow;
10509     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
10510                               /* results of calls to gmtime() and localtime() */
10511                               /* for same &base */
10512
10513     gmtime_emulation_type++;
10514     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10515       char off[LNM$C_NAMLENGTH+1];;
10516
10517       gmtime_emulation_type++;
10518       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10519         gmtime_emulation_type++;
10520         utc_offset_secs = 0;
10521         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10522       }
10523       else { utc_offset_secs = atol(off); }
10524     }
10525     else { /* We've got a working gmtime() */
10526       struct tm gmt, local;
10527
10528       gmt = *tm_p;
10529       tm_p = localtime(&base);
10530       local = *tm_p;
10531       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
10532       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10533       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
10534       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
10535     }
10536   }
10537
10538   when = time(NULL);
10539 # ifdef VMSISH_TIME
10540 # ifdef RTL_USES_UTC
10541   if (VMSISH_TIME) when = _toloc(when);
10542 # else
10543   if (!VMSISH_TIME) when = _toutc(when);
10544 # endif
10545 # endif
10546   if (timep != NULL) *timep = when;
10547   return when;
10548
10549 }  /* end of my_time() */
10550 /*}}}*/
10551
10552
10553 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10554 struct tm *
10555 Perl_my_gmtime(pTHX_ const time_t *timep)
10556 {
10557   char *p;
10558   time_t when;
10559   struct tm *rsltmp;
10560
10561   if (timep == NULL) {
10562     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10563     return NULL;
10564   }
10565   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10566
10567   when = *timep;
10568 # ifdef VMSISH_TIME
10569   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10570 #  endif
10571 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
10572   return gmtime(&when);
10573 # else
10574   /* CRTL localtime() wants local time as input, so does no tz correction */
10575   rsltmp = localtime(&when);
10576   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
10577   return rsltmp;
10578 #endif
10579 }  /* end of my_gmtime() */
10580 /*}}}*/
10581
10582
10583 /*{{{struct tm *my_localtime(const time_t *timep)*/
10584 struct tm *
10585 Perl_my_localtime(pTHX_ const time_t *timep)
10586 {
10587   time_t when, whenutc;
10588   struct tm *rsltmp;
10589   int dst, offset;
10590
10591   if (timep == NULL) {
10592     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10593     return NULL;
10594   }
10595   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10596   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10597
10598   when = *timep;
10599 # ifdef RTL_USES_UTC
10600 # ifdef VMSISH_TIME
10601   if (VMSISH_TIME) when = _toutc(when);
10602 # endif
10603   /* CRTL localtime() wants UTC as input, does tz correction itself */
10604   return localtime(&when);
10605
10606 # else /* !RTL_USES_UTC */
10607   whenutc = when;
10608 # ifdef VMSISH_TIME
10609   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
10610   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
10611 # endif
10612   dst = -1;
10613 #ifndef RTL_USES_UTC
10614   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
10615       when = whenutc - offset;                   /* pseudolocal time*/
10616   }
10617 # endif
10618   /* CRTL localtime() wants local time as input, so does no tz correction */
10619   rsltmp = localtime(&when);
10620   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10621   return rsltmp;
10622 # endif
10623
10624 } /*  end of my_localtime() */
10625 /*}}}*/
10626
10627 /* Reset definitions for later calls */
10628 #define gmtime(t)    my_gmtime(t)
10629 #define localtime(t) my_localtime(t)
10630 #define time(t)      my_time(t)
10631
10632
10633 /* my_utime - update modification/access time of a file
10634  *
10635  * VMS 7.3 and later implementation
10636  * Only the UTC translation is home-grown. The rest is handled by the
10637  * CRTL utime(), which will take into account the relevant feature
10638  * logicals and ODS-5 volume characteristics for true access times.
10639  *
10640  * pre VMS 7.3 implementation:
10641  * The calling sequence is identical to POSIX utime(), but under
10642  * VMS with ODS-2, only the modification time is changed; ODS-2 does
10643  * not maintain access times.  Restrictions differ from the POSIX
10644  * definition in that the time can be changed as long as the
10645  * caller has permission to execute the necessary IO$_MODIFY $QIO;
10646  * no separate checks are made to insure that the caller is the
10647  * owner of the file or has special privs enabled.
10648  * Code here is based on Joe Meadows' FILE utility.
10649  *
10650  */
10651
10652 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10653  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
10654  * in 100 ns intervals.
10655  */
10656 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10657
10658 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10659 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10660 {
10661 #if __CRTL_VER >= 70300000
10662   struct utimbuf utc_utimes, *utc_utimesp;
10663
10664   if (utimes != NULL) {
10665     utc_utimes.actime = utimes->actime;
10666     utc_utimes.modtime = utimes->modtime;
10667 # ifdef VMSISH_TIME
10668     /* If input was local; convert to UTC for sys svc */
10669     if (VMSISH_TIME) {
10670       utc_utimes.actime = _toutc(utimes->actime);
10671       utc_utimes.modtime = _toutc(utimes->modtime);
10672     }
10673 # endif
10674     utc_utimesp = &utc_utimes;
10675   }
10676   else {
10677     utc_utimesp = NULL;
10678   }
10679
10680   return utime(file, utc_utimesp);
10681
10682 #else /* __CRTL_VER < 70300000 */
10683
10684   register int i;
10685   int sts;
10686   long int bintime[2], len = 2, lowbit, unixtime,
10687            secscale = 10000000; /* seconds --> 100 ns intervals */
10688   unsigned long int chan, iosb[2], retsts;
10689   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10690   struct FAB myfab = cc$rms_fab;
10691   struct NAM mynam = cc$rms_nam;
10692 #if defined (__DECC) && defined (__VAX)
10693   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10694    * at least through VMS V6.1, which causes a type-conversion warning.
10695    */
10696 #  pragma message save
10697 #  pragma message disable cvtdiftypes
10698 #endif
10699   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10700   struct fibdef myfib;
10701 #if defined (__DECC) && defined (__VAX)
10702   /* This should be right after the declaration of myatr, but due
10703    * to a bug in VAX DEC C, this takes effect a statement early.
10704    */
10705 #  pragma message restore
10706 #endif
10707   /* cast ok for read only parameter */
10708   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10709                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10710                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10711
10712   if (file == NULL || *file == '\0') {
10713     SETERRNO(ENOENT, LIB$_INVARG);
10714     return -1;
10715   }
10716
10717   /* Convert to VMS format ensuring that it will fit in 255 characters */
10718   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10719       SETERRNO(ENOENT, LIB$_INVARG);
10720       return -1;
10721   }
10722   if (utimes != NULL) {
10723     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
10724      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10725      * Since time_t is unsigned long int, and lib$emul takes a signed long int
10726      * as input, we force the sign bit to be clear by shifting unixtime right
10727      * one bit, then multiplying by an extra factor of 2 in lib$emul().
10728      */
10729     lowbit = (utimes->modtime & 1) ? secscale : 0;
10730     unixtime = (long int) utimes->modtime;
10731 #   ifdef VMSISH_TIME
10732     /* If input was UTC; convert to local for sys svc */
10733     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10734 #   endif
10735     unixtime >>= 1;  secscale <<= 1;
10736     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10737     if (!(retsts & 1)) {
10738       SETERRNO(EVMSERR, retsts);
10739       return -1;
10740     }
10741     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10742     if (!(retsts & 1)) {
10743       SETERRNO(EVMSERR, retsts);
10744       return -1;
10745     }
10746   }
10747   else {
10748     /* Just get the current time in VMS format directly */
10749     retsts = sys$gettim(bintime);
10750     if (!(retsts & 1)) {
10751       SETERRNO(EVMSERR, retsts);
10752       return -1;
10753     }
10754   }
10755
10756   myfab.fab$l_fna = vmsspec;
10757   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10758   myfab.fab$l_nam = &mynam;
10759   mynam.nam$l_esa = esa;
10760   mynam.nam$b_ess = (unsigned char) sizeof esa;
10761   mynam.nam$l_rsa = rsa;
10762   mynam.nam$b_rss = (unsigned char) sizeof rsa;
10763   if (decc_efs_case_preserve)
10764       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10765
10766   /* Look for the file to be affected, letting RMS parse the file
10767    * specification for us as well.  I have set errno using only
10768    * values documented in the utime() man page for VMS POSIX.
10769    */
10770   retsts = sys$parse(&myfab,0,0);
10771   if (!(retsts & 1)) {
10772     set_vaxc_errno(retsts);
10773     if      (retsts == RMS$_PRV) set_errno(EACCES);
10774     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10775     else                         set_errno(EVMSERR);
10776     return -1;
10777   }
10778   retsts = sys$search(&myfab,0,0);
10779   if (!(retsts & 1)) {
10780     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10781     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10782     set_vaxc_errno(retsts);
10783     if      (retsts == RMS$_PRV) set_errno(EACCES);
10784     else if (retsts == RMS$_FNF) set_errno(ENOENT);
10785     else                         set_errno(EVMSERR);
10786     return -1;
10787   }
10788
10789   devdsc.dsc$w_length = mynam.nam$b_dev;
10790   /* cast ok for read only parameter */
10791   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10792
10793   retsts = sys$assign(&devdsc,&chan,0,0);
10794   if (!(retsts & 1)) {
10795     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10796     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10797     set_vaxc_errno(retsts);
10798     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
10799     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
10800     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
10801     else                               set_errno(EVMSERR);
10802     return -1;
10803   }
10804
10805   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10806   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10807
10808   memset((void *) &myfib, 0, sizeof myfib);
10809 #if defined(__DECC) || defined(__DECCXX)
10810   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10811   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10812   /* This prevents the revision time of the file being reset to the current
10813    * time as a result of our IO$_MODIFY $QIO. */
10814   myfib.fib$l_acctl = FIB$M_NORECORD;
10815 #else
10816   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10817   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10818   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10819 #endif
10820   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10821   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10822   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10823   _ckvmssts(sys$dassgn(chan));
10824   if (retsts & 1) retsts = iosb[0];
10825   if (!(retsts & 1)) {
10826     set_vaxc_errno(retsts);
10827     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10828     else                      set_errno(EVMSERR);
10829     return -1;
10830   }
10831
10832   return 0;
10833
10834 #endif /* #if __CRTL_VER >= 70300000 */
10835
10836 }  /* end of my_utime() */
10837 /*}}}*/
10838
10839 /*
10840  * flex_stat, flex_lstat, flex_fstat
10841  * basic stat, but gets it right when asked to stat
10842  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10843  */
10844
10845 #ifndef _USE_STD_STAT
10846 /* encode_dev packs a VMS device name string into an integer to allow
10847  * simple comparisons. This can be used, for example, to check whether two
10848  * files are located on the same device, by comparing their encoded device
10849  * names. Even a string comparison would not do, because stat() reuses the
10850  * device name buffer for each call; so without encode_dev, it would be
10851  * necessary to save the buffer and use strcmp (this would mean a number of
10852  * changes to the standard Perl code, to say nothing of what a Perl script
10853  * would have to do.
10854  *
10855  * The device lock id, if it exists, should be unique (unless perhaps compared
10856  * with lock ids transferred from other nodes). We have a lock id if the disk is
10857  * mounted cluster-wide, which is when we tend to get long (host-qualified)
10858  * device names. Thus we use the lock id in preference, and only if that isn't
10859  * available, do we try to pack the device name into an integer (flagged by
10860  * the sign bit (LOCKID_MASK) being set).
10861  *
10862  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10863  * name and its encoded form, but it seems very unlikely that we will find
10864  * two files on different disks that share the same encoded device names,
10865  * and even more remote that they will share the same file id (if the test
10866  * is to check for the same file).
10867  *
10868  * A better method might be to use sys$device_scan on the first call, and to
10869  * search for the device, returning an index into the cached array.
10870  * The number returned would be more intelligible.
10871  * This is probably not worth it, and anyway would take quite a bit longer
10872  * on the first call.
10873  */
10874 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
10875 static mydev_t encode_dev (pTHX_ const char *dev)
10876 {
10877   int i;
10878   unsigned long int f;
10879   mydev_t enc;
10880   char c;
10881   const char *q;
10882
10883   if (!dev || !dev[0]) return 0;
10884
10885 #if LOCKID_MASK
10886   {
10887     struct dsc$descriptor_s dev_desc;
10888     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10889
10890     /* For cluster-mounted disks, the disk lock identifier is unique, so we
10891        can try that first. */
10892     dev_desc.dsc$w_length =  strlen (dev);
10893     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
10894     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
10895     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
10896     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10897     if (!$VMS_STATUS_SUCCESS(status)) {
10898       switch (status) {
10899         case SS$_NOSUCHDEV:
10900           SETERRNO(ENODEV, status);
10901           return 0;
10902         default:
10903           _ckvmssts(status);
10904       }
10905     }
10906     if (lockid) return (lockid & ~LOCKID_MASK);
10907   }
10908 #endif
10909
10910   /* Otherwise we try to encode the device name */
10911   enc = 0;
10912   f = 1;
10913   i = 0;
10914   for (q = dev + strlen(dev); q--; q >= dev) {
10915     if (*q == ':')
10916         break;
10917     if (isdigit (*q))
10918       c= (*q) - '0';
10919     else if (isalpha (toupper (*q)))
10920       c= toupper (*q) - 'A' + (char)10;
10921     else
10922       continue; /* Skip '$'s */
10923     i++;
10924     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
10925     if (i>1) f *= 36;
10926     enc += f * (unsigned long int) c;
10927   }
10928   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
10929
10930 }  /* end of encode_dev() */
10931 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10932         device_no = encode_dev(aTHX_ devname)
10933 #else
10934 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10935         device_no = new_dev_no
10936 #endif
10937
10938 static int
10939 is_null_device(name)
10940     const char *name;
10941 {
10942   if (decc_bug_devnull != 0) {
10943     if (strncmp("/dev/null", name, 9) == 0)
10944       return 1;
10945   }
10946     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10947        The underscore prefix, controller letter, and unit number are
10948        independently optional; for our purposes, the colon punctuation
10949        is not.  The colon can be trailed by optional directory and/or
10950        filename, but two consecutive colons indicates a nodename rather
10951        than a device.  [pr]  */
10952   if (*name == '_') ++name;
10953   if (tolower(*name++) != 'n') return 0;
10954   if (tolower(*name++) != 'l') return 0;
10955   if (tolower(*name) == 'a') ++name;
10956   if (*name == '0') ++name;
10957   return (*name++ == ':') && (*name != ':');
10958 }
10959
10960
10961 static I32
10962 Perl_cando_by_name_int
10963    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10964 {
10965   char usrname[L_cuserid];
10966   struct dsc$descriptor_s usrdsc =
10967          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10968   char *vmsname = NULL, *fileified = NULL;
10969   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10970   unsigned short int retlen, trnlnm_iter_count;
10971   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10972   union prvdef curprv;
10973   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10974          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10975          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10976   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10977          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10978          {0,0,0,0}};
10979   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10980          {0,0,0,0}};
10981   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10982   Stat_t st;
10983   static int profile_context = -1;
10984
10985   if (!fname || !*fname) return FALSE;
10986
10987   /* Make sure we expand logical names, since sys$check_access doesn't */
10988   fileified = PerlMem_malloc(VMS_MAXRSS);
10989   if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
10990   if (!strpbrk(fname,"/]>:")) {
10991       strcpy(fileified,fname);
10992       trnlnm_iter_count = 0;
10993       while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
10994         trnlnm_iter_count++;
10995         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10996       }
10997       fname = fileified;
10998   }
10999
11000   vmsname = PerlMem_malloc(VMS_MAXRSS);
11001   if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11002   if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11003     /* Don't know if already in VMS format, so make sure */
11004     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11005       PerlMem_free(fileified);
11006       PerlMem_free(vmsname);
11007       return FALSE;
11008     }
11009   }
11010   else {
11011     strcpy(vmsname,fname);
11012   }
11013
11014   /* sys$check_access needs a file spec, not a directory spec.
11015    * Don't use flex_stat here, as that depends on thread context
11016    * having been initialized, and we may get here during startup.
11017    */
11018
11019   retlen = namdsc.dsc$w_length = strlen(vmsname);
11020   if (vmsname[retlen-1] == ']'
11021       || vmsname[retlen-1] == '>'
11022       || vmsname[retlen-1] == ':'
11023       || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11024
11025       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11026         PerlMem_free(fileified);
11027         PerlMem_free(vmsname);
11028         return FALSE;
11029       }
11030       fname = fileified;
11031   }
11032   else {
11033       fname = vmsname;
11034   }
11035
11036   retlen = namdsc.dsc$w_length = strlen(fname);
11037   namdsc.dsc$a_pointer = (char *)fname;
11038
11039   switch (bit) {
11040     case S_IXUSR: case S_IXGRP: case S_IXOTH:
11041       access = ARM$M_EXECUTE;
11042       flags = CHP$M_READ;
11043       break;
11044     case S_IRUSR: case S_IRGRP: case S_IROTH:
11045       access = ARM$M_READ;
11046       flags = CHP$M_READ | CHP$M_USEREADALL;
11047       break;
11048     case S_IWUSR: case S_IWGRP: case S_IWOTH:
11049       access = ARM$M_WRITE;
11050       flags = CHP$M_READ | CHP$M_WRITE;
11051       break;
11052     case S_IDUSR: case S_IDGRP: case S_IDOTH:
11053       access = ARM$M_DELETE;
11054       flags = CHP$M_READ | CHP$M_WRITE;
11055       break;
11056     default:
11057       if (fileified != NULL)
11058         PerlMem_free(fileified);
11059       if (vmsname != NULL)
11060         PerlMem_free(vmsname);
11061       return FALSE;
11062   }
11063
11064   /* Before we call $check_access, create a user profile with the current
11065    * process privs since otherwise it just uses the default privs from the
11066    * UAF and might give false positives or negatives.  This only works on
11067    * VMS versions v6.0 and later since that's when sys$create_user_profile
11068    * became available.
11069    */
11070
11071   /* get current process privs and username */
11072   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11073   _ckvmssts(iosb[0]);
11074
11075 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11076
11077   /* find out the space required for the profile */
11078   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11079                                     &usrprodsc.dsc$w_length,&profile_context));
11080
11081   /* allocate space for the profile and get it filled in */
11082   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11083   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11084   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11085                                     &usrprodsc.dsc$w_length,&profile_context));
11086
11087   /* use the profile to check access to the file; free profile & analyze results */
11088   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11089   PerlMem_free(usrprodsc.dsc$a_pointer);
11090   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11091
11092 #else
11093
11094   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11095
11096 #endif
11097
11098   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11099       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11100       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11101     set_vaxc_errno(retsts);
11102     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11103     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11104     else set_errno(ENOENT);
11105     if (fileified != NULL)
11106       PerlMem_free(fileified);
11107     if (vmsname != NULL)
11108       PerlMem_free(vmsname);
11109     return FALSE;
11110   }
11111   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11112     if (fileified != NULL)
11113       PerlMem_free(fileified);
11114     if (vmsname != NULL)
11115       PerlMem_free(vmsname);
11116     return TRUE;
11117   }
11118   _ckvmssts(retsts);
11119
11120   if (fileified != NULL)
11121     PerlMem_free(fileified);
11122   if (vmsname != NULL)
11123     PerlMem_free(vmsname);
11124   return FALSE;  /* Should never get here */
11125
11126 }
11127
11128 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
11129 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11130  * subset of the applicable information.
11131  */
11132 bool
11133 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11134 {
11135   return cando_by_name_int
11136         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11137 }  /* end of cando() */
11138 /*}}}*/
11139
11140
11141 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11142 I32
11143 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11144 {
11145    return cando_by_name_int(bit, effective, fname, 0);
11146
11147 }  /* end of cando_by_name() */
11148 /*}}}*/
11149
11150
11151 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11152 int
11153 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11154 {
11155   if (!fstat(fd,(stat_t *) statbufp)) {
11156     char *cptr;
11157     char *vms_filename;
11158     vms_filename = PerlMem_malloc(VMS_MAXRSS);
11159     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11160
11161     /* Save name for cando by name in VMS format */
11162     cptr = getname(fd, vms_filename, 1);
11163
11164     /* This should not happen, but just in case */
11165     if (cptr == NULL) {
11166         statbufp->st_devnam[0] = 0;
11167     }
11168     else {
11169         /* Make sure that the saved name fits in 255 characters */
11170         cptr = do_rmsexpand
11171                        (vms_filename,
11172                         statbufp->st_devnam,
11173                         0,
11174                         NULL,
11175                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11176                         NULL,
11177                         NULL);
11178         if (cptr == NULL)
11179             statbufp->st_devnam[0] = 0;
11180     }
11181     PerlMem_free(vms_filename);
11182
11183     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11184     VMS_DEVICE_ENCODE
11185         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11186
11187 #   ifdef RTL_USES_UTC
11188 #   ifdef VMSISH_TIME
11189     if (VMSISH_TIME) {
11190       statbufp->st_mtime = _toloc(statbufp->st_mtime);
11191       statbufp->st_atime = _toloc(statbufp->st_atime);
11192       statbufp->st_ctime = _toloc(statbufp->st_ctime);
11193     }
11194 #   endif
11195 #   else
11196 #   ifdef VMSISH_TIME
11197     if (!VMSISH_TIME) { /* Return UTC instead of local time */
11198 #   else
11199     if (1) {
11200 #   endif
11201       statbufp->st_mtime = _toutc(statbufp->st_mtime);
11202       statbufp->st_atime = _toutc(statbufp->st_atime);
11203       statbufp->st_ctime = _toutc(statbufp->st_ctime);
11204     }
11205 #endif
11206     return 0;
11207   }
11208   return -1;
11209
11210 }  /* end of flex_fstat() */
11211 /*}}}*/
11212
11213 #if !defined(__VAX) && __CRTL_VER >= 80200000
11214 #ifdef lstat
11215 #undef lstat
11216 #endif
11217 #else
11218 #ifdef lstat
11219 #undef lstat
11220 #endif
11221 #define lstat(_x, _y) stat(_x, _y)
11222 #endif
11223
11224 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11225
11226 static int
11227 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11228 {
11229     char fileified[VMS_MAXRSS];
11230     char temp_fspec[VMS_MAXRSS];
11231     char *save_spec;
11232     int retval = -1;
11233     int saved_errno, saved_vaxc_errno;
11234
11235     if (!fspec) return retval;
11236     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11237     strcpy(temp_fspec, fspec);
11238
11239     if (decc_bug_devnull != 0) {
11240       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11241         memset(statbufp,0,sizeof *statbufp);
11242         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11243         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11244         statbufp->st_uid = 0x00010001;
11245         statbufp->st_gid = 0x0001;
11246         time((time_t *)&statbufp->st_mtime);
11247         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11248         return 0;
11249       }
11250     }
11251
11252     /* Try for a directory name first.  If fspec contains a filename without
11253      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11254      * and sea:[wine.dark]water. exist, we prefer the directory here.
11255      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11256      * not sea:[wine.dark]., if the latter exists.  If the intended target is
11257      * the file with null type, specify this by calling flex_stat() with
11258      * a '.' at the end of fspec.
11259      *
11260      * If we are in Posix filespec mode, accept the filename as is.
11261      */
11262
11263
11264 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11265   /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11266    * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11267    */
11268   if (!decc_efs_charset)
11269     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11270 #endif
11271
11272 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11273   if (decc_posix_compliant_pathnames == 0) {
11274 #endif
11275     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11276       if (lstat_flag == 0)
11277         retval = stat(fileified,(stat_t *) statbufp);
11278       else
11279         retval = lstat(fileified,(stat_t *) statbufp);
11280       save_spec = fileified;
11281     }
11282     if (retval) {
11283       if (lstat_flag == 0)
11284         retval = stat(temp_fspec,(stat_t *) statbufp);
11285       else
11286         retval = lstat(temp_fspec,(stat_t *) statbufp);
11287       save_spec = temp_fspec;
11288     }
11289 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11290   } else {
11291     if (lstat_flag == 0)
11292       retval = stat(temp_fspec,(stat_t *) statbufp);
11293     else
11294       retval = lstat(temp_fspec,(stat_t *) statbufp);
11295       save_spec = temp_fspec;
11296   }
11297 #endif
11298
11299 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11300   /* As you were... */
11301   if (!decc_efs_charset)
11302     decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11303 #endif
11304
11305     if (!retval) {
11306     char * cptr;
11307       cptr = do_rmsexpand
11308        (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
11309       if (cptr == NULL)
11310         statbufp->st_devnam[0] = 0;
11311
11312       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11313       VMS_DEVICE_ENCODE
11314         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11315 #     ifdef RTL_USES_UTC
11316 #     ifdef VMSISH_TIME
11317       if (VMSISH_TIME) {
11318         statbufp->st_mtime = _toloc(statbufp->st_mtime);
11319         statbufp->st_atime = _toloc(statbufp->st_atime);
11320         statbufp->st_ctime = _toloc(statbufp->st_ctime);
11321       }
11322 #     endif
11323 #     else
11324 #     ifdef VMSISH_TIME
11325       if (!VMSISH_TIME) { /* Return UTC instead of local time */
11326 #     else
11327       if (1) {
11328 #     endif
11329         statbufp->st_mtime = _toutc(statbufp->st_mtime);
11330         statbufp->st_atime = _toutc(statbufp->st_atime);
11331         statbufp->st_ctime = _toutc(statbufp->st_ctime);
11332       }
11333 #     endif
11334     }
11335     /* If we were successful, leave errno where we found it */
11336     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
11337     return retval;
11338
11339 }  /* end of flex_stat_int() */
11340
11341
11342 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
11343 int
11344 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
11345 {
11346    return flex_stat_int(fspec, statbufp, 0);
11347 }
11348 /*}}}*/
11349
11350 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
11351 int
11352 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
11353 {
11354    return flex_stat_int(fspec, statbufp, 1);
11355 }
11356 /*}}}*/
11357
11358
11359 /*{{{char *my_getlogin()*/
11360 /* VMS cuserid == Unix getlogin, except calling sequence */
11361 char *
11362 my_getlogin(void)
11363 {
11364     static char user[L_cuserid];
11365     return cuserid(user);
11366 }
11367 /*}}}*/
11368
11369
11370 /*  rmscopy - copy a file using VMS RMS routines
11371  *
11372  *  Copies contents and attributes of spec_in to spec_out, except owner
11373  *  and protection information.  Name and type of spec_in are used as
11374  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
11375  *  should try to propagate timestamps from the input file to the output file.
11376  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
11377  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
11378  *  propagated to the output file at creation iff the output file specification
11379  *  did not contain an explicit name or type, and the revision date is always
11380  *  updated at the end of the copy operation.  If it is greater than 0, then
11381  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11382  *  other than the revision date should be propagated, and bit 1 indicates
11383  *  that the revision date should be propagated.
11384  *
11385  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11386  *
11387  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11388  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
11389  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
11390  * as part of the Perl standard distribution under the terms of the
11391  * GNU General Public License or the Perl Artistic License.  Copies
11392  * of each may be found in the Perl standard distribution.
11393  */ /* FIXME */
11394 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11395 int
11396 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11397 {
11398     char *vmsin, * vmsout, *esa, *esa_out,
11399          *rsa, *ubf;
11400     unsigned long int i, sts, sts2;
11401     int dna_len;
11402     struct FAB fab_in, fab_out;
11403     struct RAB rab_in, rab_out;
11404     rms_setup_nam(nam);
11405     rms_setup_nam(nam_out);
11406     struct XABDAT xabdat;
11407     struct XABFHC xabfhc;
11408     struct XABRDT xabrdt;
11409     struct XABSUM xabsum;
11410
11411     vmsin = PerlMem_malloc(VMS_MAXRSS);
11412     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11413     vmsout = PerlMem_malloc(VMS_MAXRSS);
11414     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11415     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11416         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11417       PerlMem_free(vmsin);
11418       PerlMem_free(vmsout);
11419       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11420       return 0;
11421     }
11422
11423     esa = PerlMem_malloc(VMS_MAXRSS);
11424     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11425     fab_in = cc$rms_fab;
11426     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11427     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11428     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11429     fab_in.fab$l_fop = FAB$M_SQO;
11430     rms_bind_fab_nam(fab_in, nam);
11431     fab_in.fab$l_xab = (void *) &xabdat;
11432
11433     rsa = PerlMem_malloc(VMS_MAXRSS);
11434     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11435     rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11436     rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11437     rms_nam_esl(nam) = 0;
11438     rms_nam_rsl(nam) = 0;
11439     rms_nam_esll(nam) = 0;
11440     rms_nam_rsll(nam) = 0;
11441 #ifdef NAM$M_NO_SHORT_UPCASE
11442     if (decc_efs_case_preserve)
11443         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11444 #endif
11445
11446     xabdat = cc$rms_xabdat;        /* To get creation date */
11447     xabdat.xab$l_nxt = (void *) &xabfhc;
11448
11449     xabfhc = cc$rms_xabfhc;        /* To get record length */
11450     xabfhc.xab$l_nxt = (void *) &xabsum;
11451
11452     xabsum = cc$rms_xabsum;        /* To get key and area information */
11453
11454     if (!((sts = sys$open(&fab_in)) & 1)) {
11455       PerlMem_free(vmsin);
11456       PerlMem_free(vmsout);
11457       PerlMem_free(esa);
11458       PerlMem_free(rsa);
11459       set_vaxc_errno(sts);
11460       switch (sts) {
11461         case RMS$_FNF: case RMS$_DNF:
11462           set_errno(ENOENT); break;
11463         case RMS$_DIR:
11464           set_errno(ENOTDIR); break;
11465         case RMS$_DEV:
11466           set_errno(ENODEV); break;
11467         case RMS$_SYN:
11468           set_errno(EINVAL); break;
11469         case RMS$_PRV:
11470           set_errno(EACCES); break;
11471         default:
11472           set_errno(EVMSERR);
11473       }
11474       return 0;
11475     }
11476
11477     nam_out = nam;
11478     fab_out = fab_in;
11479     fab_out.fab$w_ifi = 0;
11480     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11481     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11482     fab_out.fab$l_fop = FAB$M_SQO;
11483     rms_bind_fab_nam(fab_out, nam_out);
11484     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11485     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11486     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11487     esa_out = PerlMem_malloc(VMS_MAXRSS);
11488     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11489     rms_set_rsa(nam_out, NULL, 0);
11490     rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11491
11492     if (preserve_dates == 0) {  /* Act like DCL COPY */
11493       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11494       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
11495       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11496         PerlMem_free(vmsin);
11497         PerlMem_free(vmsout);
11498         PerlMem_free(esa);
11499         PerlMem_free(rsa);
11500         PerlMem_free(esa_out);
11501         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11502         set_vaxc_errno(sts);
11503         return 0;
11504       }
11505       fab_out.fab$l_xab = (void *) &xabdat;
11506       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11507         preserve_dates = 1;
11508     }
11509     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
11510       preserve_dates =0;      /* bitmask from this point forward   */
11511
11512     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11513     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11514       PerlMem_free(vmsin);
11515       PerlMem_free(vmsout);
11516       PerlMem_free(esa);
11517       PerlMem_free(rsa);
11518       PerlMem_free(esa_out);
11519       set_vaxc_errno(sts);
11520       switch (sts) {
11521         case RMS$_DNF:
11522           set_errno(ENOENT); break;
11523         case RMS$_DIR:
11524           set_errno(ENOTDIR); break;
11525         case RMS$_DEV:
11526           set_errno(ENODEV); break;
11527         case RMS$_SYN:
11528           set_errno(EINVAL); break;
11529         case RMS$_PRV:
11530           set_errno(EACCES); break;
11531         default:
11532           set_errno(EVMSERR);
11533       }
11534       return 0;
11535     }
11536     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
11537     if (preserve_dates & 2) {
11538       /* sys$close() will process xabrdt, not xabdat */
11539       xabrdt = cc$rms_xabrdt;
11540 #ifndef __GNUC__
11541       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11542 #else
11543       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11544        * is unsigned long[2], while DECC & VAXC use a struct */
11545       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11546 #endif
11547       fab_out.fab$l_xab = (void *) &xabrdt;
11548     }
11549
11550     ubf = PerlMem_malloc(32256);
11551     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11552     rab_in = cc$rms_rab;
11553     rab_in.rab$l_fab = &fab_in;
11554     rab_in.rab$l_rop = RAB$M_BIO;
11555     rab_in.rab$l_ubf = ubf;
11556     rab_in.rab$w_usz = 32256;
11557     if (!((sts = sys$connect(&rab_in)) & 1)) {
11558       sys$close(&fab_in); sys$close(&fab_out);
11559       PerlMem_free(vmsin);
11560       PerlMem_free(vmsout);
11561       PerlMem_free(esa);
11562       PerlMem_free(ubf);
11563       PerlMem_free(rsa);
11564       PerlMem_free(esa_out);
11565       set_errno(EVMSERR); set_vaxc_errno(sts);
11566       return 0;
11567     }
11568
11569     rab_out = cc$rms_rab;
11570     rab_out.rab$l_fab = &fab_out;
11571     rab_out.rab$l_rbf = ubf;
11572     if (!((sts = sys$connect(&rab_out)) & 1)) {
11573       sys$close(&fab_in); sys$close(&fab_out);
11574       PerlMem_free(vmsin);
11575       PerlMem_free(vmsout);
11576       PerlMem_free(esa);
11577       PerlMem_free(ubf);
11578       PerlMem_free(rsa);
11579       PerlMem_free(esa_out);
11580       set_errno(EVMSERR); set_vaxc_errno(sts);
11581       return 0;
11582     }
11583
11584     while ((sts = sys$read(&rab_in))) {  /* always true  */
11585       if (sts == RMS$_EOF) break;
11586       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11587       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11588         sys$close(&fab_in); sys$close(&fab_out);
11589         PerlMem_free(vmsin);
11590         PerlMem_free(vmsout);
11591         PerlMem_free(esa);
11592         PerlMem_free(ubf);
11593         PerlMem_free(rsa);
11594         PerlMem_free(esa_out);
11595         set_errno(EVMSERR); set_vaxc_errno(sts);
11596         return 0;
11597       }
11598     }
11599
11600
11601     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
11602     sys$close(&fab_in);  sys$close(&fab_out);
11603     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11604     if (!(sts & 1)) {
11605       PerlMem_free(vmsin);
11606       PerlMem_free(vmsout);
11607       PerlMem_free(esa);
11608       PerlMem_free(ubf);
11609       PerlMem_free(rsa);
11610       PerlMem_free(esa_out);
11611       set_errno(EVMSERR); set_vaxc_errno(sts);
11612       return 0;
11613     }
11614
11615     PerlMem_free(vmsin);
11616     PerlMem_free(vmsout);
11617     PerlMem_free(esa);
11618     PerlMem_free(ubf);
11619     PerlMem_free(rsa);
11620     PerlMem_free(esa_out);
11621     return 1;
11622
11623 }  /* end of rmscopy() */
11624 /*}}}*/
11625
11626
11627 /***  The following glue provides 'hooks' to make some of the routines
11628  * from this file available from Perl.  These routines are sufficiently
11629  * basic, and are required sufficiently early in the build process,
11630  * that's it's nice to have them available to miniperl as well as the
11631  * full Perl, so they're set up here instead of in an extension.  The
11632  * Perl code which handles importation of these names into a given
11633  * package lives in [.VMS]Filespec.pm in @INC.
11634  */
11635
11636 void
11637 rmsexpand_fromperl(pTHX_ CV *cv)
11638 {
11639   dXSARGS;
11640   char *fspec, *defspec = NULL, *rslt;
11641   STRLEN n_a;
11642   int fs_utf8, dfs_utf8;
11643
11644   fs_utf8 = 0;
11645   dfs_utf8 = 0;
11646   if (!items || items > 2)
11647     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11648   fspec = SvPV(ST(0),n_a);
11649   fs_utf8 = SvUTF8(ST(0));
11650   if (!fspec || !*fspec) XSRETURN_UNDEF;
11651   if (items == 2) {
11652     defspec = SvPV(ST(1),n_a);
11653     dfs_utf8 = SvUTF8(ST(1));
11654   }
11655   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11656   ST(0) = sv_newmortal();
11657   if (rslt != NULL) {
11658     sv_usepvn(ST(0),rslt,strlen(rslt));
11659     if (fs_utf8) {
11660         SvUTF8_on(ST(0));
11661     }
11662   }
11663   XSRETURN(1);
11664 }
11665
11666 void
11667 vmsify_fromperl(pTHX_ CV *cv)
11668 {
11669   dXSARGS;
11670   char *vmsified;
11671   STRLEN n_a;
11672   int utf8_fl;
11673
11674   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11675   utf8_fl = SvUTF8(ST(0));
11676   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11677   ST(0) = sv_newmortal();
11678   if (vmsified != NULL) {
11679     sv_usepvn(ST(0),vmsified,strlen(vmsified));
11680     if (utf8_fl) {
11681         SvUTF8_on(ST(0));
11682     }
11683   }
11684   XSRETURN(1);
11685 }
11686
11687 void
11688 unixify_fromperl(pTHX_ CV *cv)
11689 {
11690   dXSARGS;
11691   char *unixified;
11692   STRLEN n_a;
11693   int utf8_fl;
11694
11695   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11696   utf8_fl = SvUTF8(ST(0));
11697   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11698   ST(0) = sv_newmortal();
11699   if (unixified != NULL) {
11700     sv_usepvn(ST(0),unixified,strlen(unixified));
11701     if (utf8_fl) {
11702         SvUTF8_on(ST(0));
11703     }
11704   }
11705   XSRETURN(1);
11706 }
11707
11708 void
11709 fileify_fromperl(pTHX_ CV *cv)
11710 {
11711   dXSARGS;
11712   char *fileified;
11713   STRLEN n_a;
11714   int utf8_fl;
11715
11716   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11717   utf8_fl = SvUTF8(ST(0));
11718   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11719   ST(0) = sv_newmortal();
11720   if (fileified != NULL) {
11721     sv_usepvn(ST(0),fileified,strlen(fileified));
11722     if (utf8_fl) {
11723         SvUTF8_on(ST(0));
11724     }
11725   }
11726   XSRETURN(1);
11727 }
11728
11729 void
11730 pathify_fromperl(pTHX_ CV *cv)
11731 {
11732   dXSARGS;
11733   char *pathified;
11734   STRLEN n_a;
11735   int utf8_fl;
11736
11737   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11738   utf8_fl = SvUTF8(ST(0));
11739   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11740   ST(0) = sv_newmortal();
11741   if (pathified != NULL) {
11742     sv_usepvn(ST(0),pathified,strlen(pathified));
11743     if (utf8_fl) {
11744         SvUTF8_on(ST(0));
11745     }
11746   }
11747   XSRETURN(1);
11748 }
11749
11750 void
11751 vmspath_fromperl(pTHX_ CV *cv)
11752 {
11753   dXSARGS;
11754   char *vmspath;
11755   STRLEN n_a;
11756   int utf8_fl;
11757
11758   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11759   utf8_fl = SvUTF8(ST(0));
11760   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11761   ST(0) = sv_newmortal();
11762   if (vmspath != NULL) {
11763     sv_usepvn(ST(0),vmspath,strlen(vmspath));
11764     if (utf8_fl) {
11765         SvUTF8_on(ST(0));
11766     }
11767   }
11768   XSRETURN(1);
11769 }
11770
11771 void
11772 unixpath_fromperl(pTHX_ CV *cv)
11773 {
11774   dXSARGS;
11775   char *unixpath;
11776   STRLEN n_a;
11777   int utf8_fl;
11778
11779   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11780   utf8_fl = SvUTF8(ST(0));
11781   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11782   ST(0) = sv_newmortal();
11783   if (unixpath != NULL) {
11784     sv_usepvn(ST(0),unixpath,strlen(unixpath));
11785     if (utf8_fl) {
11786         SvUTF8_on(ST(0));
11787     }
11788   }
11789   XSRETURN(1);
11790 }
11791
11792 void
11793 candelete_fromperl(pTHX_ CV *cv)
11794 {
11795   dXSARGS;
11796   char *fspec, *fsp;
11797   SV *mysv;
11798   IO *io;
11799   STRLEN n_a;
11800
11801   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11802
11803   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11804   Newx(fspec, VMS_MAXRSS, char);
11805   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11806   if (SvTYPE(mysv) == SVt_PVGV) {
11807     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11808       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11809       ST(0) = &PL_sv_no;
11810       Safefree(fspec);
11811       XSRETURN(1);
11812     }
11813     fsp = fspec;
11814   }
11815   else {
11816     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11817       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11818       ST(0) = &PL_sv_no;
11819       Safefree(fspec);
11820       XSRETURN(1);
11821     }
11822   }
11823
11824   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11825   Safefree(fspec);
11826   XSRETURN(1);
11827 }
11828
11829 void
11830 rmscopy_fromperl(pTHX_ CV *cv)
11831 {
11832   dXSARGS;
11833   char *inspec, *outspec, *inp, *outp;
11834   int date_flag;
11835   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11836                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11837   unsigned long int sts;
11838   SV *mysv;
11839   IO *io;
11840   STRLEN n_a;
11841
11842   if (items < 2 || items > 3)
11843     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11844
11845   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11846   Newx(inspec, VMS_MAXRSS, char);
11847   if (SvTYPE(mysv) == SVt_PVGV) {
11848     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11849       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11850       ST(0) = &PL_sv_no;
11851       Safefree(inspec);
11852       XSRETURN(1);
11853     }
11854     inp = inspec;
11855   }
11856   else {
11857     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11858       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11859       ST(0) = &PL_sv_no;
11860       Safefree(inspec);
11861       XSRETURN(1);
11862     }
11863   }
11864   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11865   Newx(outspec, VMS_MAXRSS, char);
11866   if (SvTYPE(mysv) == SVt_PVGV) {
11867     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11868       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11869       ST(0) = &PL_sv_no;
11870       Safefree(inspec);
11871       Safefree(outspec);
11872       XSRETURN(1);
11873     }
11874     outp = outspec;
11875   }
11876   else {
11877     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11878       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11879       ST(0) = &PL_sv_no;
11880       Safefree(inspec);
11881       Safefree(outspec);
11882       XSRETURN(1);
11883     }
11884   }
11885   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11886
11887   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11888   Safefree(inspec);
11889   Safefree(outspec);
11890   XSRETURN(1);
11891 }
11892
11893 /* The mod2fname is limited to shorter filenames by design, so it should
11894  * not be modified to support longer EFS pathnames
11895  */
11896 void
11897 mod2fname(pTHX_ CV *cv)
11898 {
11899   dXSARGS;
11900   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11901        workbuff[NAM$C_MAXRSS*1 + 1];
11902   int total_namelen = 3, counter, num_entries;
11903   /* ODS-5 ups this, but we want to be consistent, so... */
11904   int max_name_len = 39;
11905   AV *in_array = (AV *)SvRV(ST(0));
11906
11907   num_entries = av_len(in_array);
11908
11909   /* All the names start with PL_. */
11910   strcpy(ultimate_name, "PL_");
11911
11912   /* Clean up our working buffer */
11913   Zero(work_name, sizeof(work_name), char);
11914
11915   /* Run through the entries and build up a working name */
11916   for(counter = 0; counter <= num_entries; counter++) {
11917     /* If it's not the first name then tack on a __ */
11918     if (counter) {
11919       strcat(work_name, "__");
11920     }
11921     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11922                            PL_na));
11923   }
11924
11925   /* Check to see if we actually have to bother...*/
11926   if (strlen(work_name) + 3 <= max_name_len) {
11927     strcat(ultimate_name, work_name);
11928   } else {
11929     /* It's too darned big, so we need to go strip. We use the same */
11930     /* algorithm as xsubpp does. First, strip out doubled __ */
11931     char *source, *dest, last;
11932     dest = workbuff;
11933     last = 0;
11934     for (source = work_name; *source; source++) {
11935       if (last == *source && last == '_') {
11936         continue;
11937       }
11938       *dest++ = *source;
11939       last = *source;
11940     }
11941     /* Go put it back */
11942     strcpy(work_name, workbuff);
11943     /* Is it still too big? */
11944     if (strlen(work_name) + 3 > max_name_len) {
11945       /* Strip duplicate letters */
11946       last = 0;
11947       dest = workbuff;
11948       for (source = work_name; *source; source++) {
11949         if (last == toupper(*source)) {
11950         continue;
11951         }
11952         *dest++ = *source;
11953         last = toupper(*source);
11954       }
11955       strcpy(work_name, workbuff);
11956     }
11957
11958     /* Is it *still* too big? */
11959     if (strlen(work_name) + 3 > max_name_len) {
11960       /* Too bad, we truncate */
11961       work_name[max_name_len - 2] = 0;
11962     }
11963     strcat(ultimate_name, work_name);
11964   }
11965
11966   /* Okay, return it */
11967   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11968   XSRETURN(1);
11969 }
11970
11971 void
11972 hushexit_fromperl(pTHX_ CV *cv)
11973 {
11974     dXSARGS;
11975
11976     if (items > 0) {
11977         VMSISH_HUSHED = SvTRUE(ST(0));
11978     }
11979     ST(0) = boolSV(VMSISH_HUSHED);
11980     XSRETURN(1);
11981 }
11982
11983
11984 PerlIO *
11985 Perl_vms_start_glob
11986    (pTHX_ SV *tmpglob,
11987     IO *io)
11988 {
11989     PerlIO *fp;
11990     struct vs_str_st *rslt;
11991     char *vmsspec;
11992     char *rstr;
11993     char *begin, *cp;
11994     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11995     PerlIO *tmpfp;
11996     STRLEN i;
11997     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11998     struct dsc$descriptor_vs rsdsc;
11999     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12000     unsigned long hasver = 0, isunix = 0;
12001     unsigned long int lff_flags = 0;
12002     int rms_sts;
12003
12004 #ifdef VMS_LONGNAME_SUPPORT
12005     lff_flags = LIB$M_FIL_LONG_NAMES;
12006 #endif
12007     /* The Newx macro will not allow me to assign a smaller array
12008      * to the rslt pointer, so we will assign it to the begin char pointer
12009      * and then copy the value into the rslt pointer.
12010      */
12011     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12012     rslt = (struct vs_str_st *)begin;
12013     rslt->length = 0;
12014     rstr = &rslt->str[0];
12015     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12016     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12017     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12018     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12019
12020     Newx(vmsspec, VMS_MAXRSS, char);
12021
12022         /* We could find out if there's an explicit dev/dir or version
12023            by peeking into lib$find_file's internal context at
12024            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12025            but that's unsupported, so I don't want to do it now and
12026            have it bite someone in the future. */
12027         /* Fix-me: vms_split_path() is the only way to do this, the
12028            existing method will fail with many legal EFS or UNIX specifications
12029          */
12030
12031     cp = SvPV(tmpglob,i);
12032
12033     for (; i; i--) {
12034         if (cp[i] == ';') hasver = 1;
12035         if (cp[i] == '.') {
12036             if (sts) hasver = 1;
12037             else sts = 1;
12038         }
12039         if (cp[i] == '/') {
12040             hasdir = isunix = 1;
12041             break;
12042         }
12043         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12044             hasdir = 1;
12045             break;
12046         }
12047     }
12048     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12049         int found = 0;
12050         Stat_t st;
12051         int stat_sts;
12052         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12053         if (!stat_sts && S_ISDIR(st.st_mode)) {
12054             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12055             ok = (wilddsc.dsc$a_pointer != NULL);
12056             /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12057             hasdir = 1;
12058         }
12059         else {
12060             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12061             ok = (wilddsc.dsc$a_pointer != NULL);
12062         }
12063         if (ok)
12064             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12065
12066         /* If not extended character set, replace ? with % */
12067         /* With extended character set, ? is a wildcard single character */
12068         if (!decc_efs_case_preserve) {
12069             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12070                 if (*cp == '?') *cp = '%';
12071         }
12072         sts = SS$_NORMAL;
12073         while (ok && $VMS_STATUS_SUCCESS(sts)) {
12074          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12075          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12076
12077             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12078                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
12079             if (!$VMS_STATUS_SUCCESS(sts))
12080                 break;
12081
12082             found++;
12083
12084             /* with varying string, 1st word of buffer contains result length */
12085             rstr[rslt->length] = '\0';
12086
12087              /* Find where all the components are */
12088              v_sts = vms_split_path
12089                        (rstr,
12090                         &v_spec,
12091                         &v_len,
12092                         &r_spec,
12093                         &r_len,
12094                         &d_spec,
12095                         &d_len,
12096                         &n_spec,
12097                         &n_len,
12098                         &e_spec,
12099                         &e_len,
12100                         &vs_spec,
12101                         &vs_len);
12102
12103             /* If no version on input, truncate the version on output */
12104             if (!hasver && (vs_len > 0)) {
12105                 *vs_spec = '\0';
12106                 vs_len = 0;
12107
12108                 /* No version & a null extension on UNIX handling */
12109                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12110                     e_len = 0;
12111                     *e_spec = '\0';
12112                 }
12113             }
12114
12115             if (!decc_efs_case_preserve) {
12116                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12117             }
12118
12119             if (hasdir) {
12120                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12121                 begin = rstr;
12122             }
12123             else {
12124                 /* Start with the name */
12125                 begin = n_spec;
12126             }
12127             strcat(begin,"\n");
12128             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12129         }
12130         if (cxt) (void)lib$find_file_end(&cxt);
12131
12132         if (!found) {
12133             /* Be POSIXish: return the input pattern when no matches */
12134             begin = SvPVX(tmpglob);
12135             strcat(begin,"\n");
12136             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12137         }
12138
12139         if (ok && sts != RMS$_NMF &&
12140             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12141         if (!ok) {
12142             if (!(sts & 1)) {
12143                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12144             }
12145             PerlIO_close(tmpfp);
12146             fp = NULL;
12147         }
12148         else {
12149             PerlIO_rewind(tmpfp);
12150             IoTYPE(io) = IoTYPE_RDONLY;
12151             IoIFP(io) = fp = tmpfp;
12152             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
12153         }
12154     }
12155     Safefree(vmsspec);
12156     Safefree(rslt);
12157     return fp;
12158 }
12159
12160
12161 #ifdef HAS_SYMLINK
12162 static char *
12163 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
12164                    const int *utf8_fl);
12165
12166 void
12167 vms_realpath_fromperl(pTHX_ CV *cv)
12168 {
12169   dXSARGS;
12170   char *fspec, *rslt_spec, *rslt;
12171   STRLEN n_a;
12172
12173   if (!items || items != 1)
12174     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12175
12176   fspec = SvPV(ST(0),n_a);
12177   if (!fspec || !*fspec) XSRETURN_UNDEF;
12178
12179   Newx(rslt_spec, VMS_MAXRSS + 1, char);
12180   rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12181   ST(0) = sv_newmortal();
12182   if (rslt != NULL)
12183     sv_usepvn(ST(0),rslt,strlen(rslt));
12184   else
12185     Safefree(rslt_spec);
12186   XSRETURN(1);
12187 }
12188 #endif
12189
12190 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12191 int do_vms_case_tolerant(void);
12192
12193 void
12194 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12195 {
12196   dXSARGS;
12197   ST(0) = boolSV(do_vms_case_tolerant());
12198   XSRETURN(1);
12199 }
12200 #endif
12201
12202 void
12203 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12204                           struct interp_intern *dst)
12205 {
12206     memcpy(dst,src,sizeof(struct interp_intern));
12207 }
12208
12209 void
12210 Perl_sys_intern_clear(pTHX)
12211 {
12212 }
12213
12214 void
12215 Perl_sys_intern_init(pTHX)
12216 {
12217     unsigned int ix = RAND_MAX;
12218     double x;
12219
12220     VMSISH_HUSHED = 0;
12221
12222     /* fix me later to track running under GNV */
12223     /* this allows some limited testing */
12224     MY_POSIX_EXIT = decc_filename_unix_report;
12225
12226     x = (float)ix;
12227     MY_INV_RAND_MAX = 1./x;
12228 }
12229
12230 void
12231 init_os_extras(void)
12232 {
12233   dTHX;
12234   char* file = __FILE__;
12235   if (decc_disable_to_vms_logname_translation) {
12236     no_translate_barewords = TRUE;
12237   } else {
12238     no_translate_barewords = FALSE;
12239   }
12240
12241   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
12242   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
12243   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
12244   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
12245   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
12246   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
12247   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
12248   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
12249   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
12250   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
12251   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
12252 #ifdef HAS_SYMLINK
12253   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
12254 #endif
12255 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12256   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
12257 #endif
12258
12259   store_pipelocs(aTHX);         /* will redo any earlier attempts */
12260
12261   return;
12262 }
12263
12264 #ifdef HAS_SYMLINK
12265
12266 #if __CRTL_VER == 80200000
12267 /* This missed getting in to the DECC SDK for 8.2 */
12268 char *realpath(const char *file_name, char * resolved_name, ...);
12269 #endif
12270
12271 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
12272 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
12273  * The perl fallback routine to provide realpath() is not as efficient
12274  * on OpenVMS.
12275  */
12276 static char *
12277 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
12278                    const int *utf8_fl)
12279 {
12280     return realpath(filespec, outbuf);
12281 }
12282
12283 /*}}}*/
12284 /* External entry points */
12285 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12286 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
12287 #else
12288 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12289 { return NULL; }
12290 #endif
12291
12292
12293 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12294 /* case_tolerant */
12295
12296 /*{{{int do_vms_case_tolerant(void)*/
12297 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
12298  * controlled by a process setting.
12299  */
12300 int do_vms_case_tolerant(void)
12301 {
12302     return vms_process_case_tolerant;
12303 }
12304 /*}}}*/
12305 /* External entry points */
12306 int Perl_vms_case_tolerant(void)
12307 { return do_vms_case_tolerant(); }
12308 #else
12309 int Perl_vms_case_tolerant(void)
12310 { return vms_process_case_tolerant; }
12311 #endif
12312
12313
12314  /* Start of DECC RTL Feature handling */
12315
12316 static int sys_trnlnm
12317    (const char * logname,
12318     char * value,
12319     int value_len)
12320 {
12321     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
12322     const unsigned long attr = LNM$M_CASE_BLIND;
12323     struct dsc$descriptor_s name_dsc;
12324     int status;
12325     unsigned short result;
12326     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
12327                                 {0, 0, 0, 0}};
12328
12329     name_dsc.dsc$w_length = strlen(logname);
12330     name_dsc.dsc$a_pointer = (char *)logname;
12331     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12332     name_dsc.dsc$b_class = DSC$K_CLASS_S;
12333
12334     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
12335
12336     if ($VMS_STATUS_SUCCESS(status)) {
12337
12338          /* Null terminate and return the string */
12339         /*--------------------------------------*/
12340         value[result] = 0;
12341     }
12342
12343     return status;
12344 }
12345
12346 static int sys_crelnm
12347    (const char * logname,
12348     const char * value)
12349 {
12350     int ret_val;
12351     const char * proc_table = "LNM$PROCESS_TABLE";
12352     struct dsc$descriptor_s proc_table_dsc;
12353     struct dsc$descriptor_s logname_dsc;
12354     struct itmlst_3 item_list[2];
12355
12356     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
12357     proc_table_dsc.dsc$w_length = strlen(proc_table);
12358     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12359     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
12360
12361     logname_dsc.dsc$a_pointer = (char *) logname;
12362     logname_dsc.dsc$w_length = strlen(logname);
12363     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12364     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
12365
12366     item_list[0].buflen = strlen(value);
12367     item_list[0].itmcode = LNM$_STRING;
12368     item_list[0].bufadr = (char *)value;
12369     item_list[0].retlen = NULL;
12370
12371     item_list[1].buflen = 0;
12372     item_list[1].itmcode = 0;
12373
12374     ret_val = sys$crelnm
12375                        (NULL,
12376                         (const struct dsc$descriptor_s *)&proc_table_dsc,
12377                         (const struct dsc$descriptor_s *)&logname_dsc,
12378                         NULL,
12379                         (const struct item_list_3 *) item_list);
12380
12381     return ret_val;
12382 }
12383
12384 /* C RTL Feature settings */
12385
12386 static int set_features
12387    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
12388     int (* cli_routine)(void),  /* Not documented */
12389     void *image_info)           /* Not documented */
12390 {
12391     int status;
12392     int s;
12393     int dflt;
12394     char* str;
12395     char val_str[10];
12396 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12397     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12398     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12399     unsigned long case_perm;
12400     unsigned long case_image;
12401 #endif
12402
12403     /* Allow an exception to bring Perl into the VMS debugger */
12404     vms_debug_on_exception = 0;
12405     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12406     if ($VMS_STATUS_SUCCESS(status)) {
12407        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12408          vms_debug_on_exception = 1;
12409        else
12410          vms_debug_on_exception = 0;
12411     }
12412
12413     /* Create VTF-7 filenames from Unicode instead of UTF-8 */
12414     vms_vtf7_filenames = 0;
12415     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12416     if ($VMS_STATUS_SUCCESS(status)) {
12417        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12418          vms_vtf7_filenames = 1;
12419        else
12420          vms_vtf7_filenames = 0;
12421     }
12422
12423     /* Dectect running under GNV Bash or other UNIX like shell */
12424 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12425     gnv_unix_shell = 0;
12426     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12427     if ($VMS_STATUS_SUCCESS(status)) {
12428        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12429          gnv_unix_shell = 1;
12430          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12431          set_feature_default("DECC$EFS_CHARSET", 1);
12432          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12433          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12434          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12435          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12436        }
12437        else
12438          gnv_unix_shell = 0;
12439     }
12440 #endif
12441
12442     /* hacks to see if known bugs are still present for testing */
12443
12444     /* Readdir is returning filenames in VMS syntax always */
12445     decc_bug_readdir_efs1 = 1;
12446     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12447     if ($VMS_STATUS_SUCCESS(status)) {
12448        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12449          decc_bug_readdir_efs1 = 1;
12450        else
12451          decc_bug_readdir_efs1 = 0;
12452     }
12453
12454     /* PCP mode requires creating /dev/null special device file */
12455     decc_bug_devnull = 0;
12456     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12457     if ($VMS_STATUS_SUCCESS(status)) {
12458        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12459           decc_bug_devnull = 1;
12460        else
12461           decc_bug_devnull = 0;
12462     }
12463
12464     /* fgetname returning a VMS name in UNIX mode */
12465     decc_bug_fgetname = 1;
12466     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12467     if ($VMS_STATUS_SUCCESS(status)) {
12468       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12469         decc_bug_fgetname = 1;
12470       else
12471         decc_bug_fgetname = 0;
12472     }
12473
12474     /* UNIX directory names with no paths are broken in a lot of places */
12475     decc_dir_barename = 1;
12476     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12477     if ($VMS_STATUS_SUCCESS(status)) {
12478       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12479         decc_dir_barename = 1;
12480       else
12481         decc_dir_barename = 0;
12482     }
12483
12484 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12485     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12486     if (s >= 0) {
12487         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12488         if (decc_disable_to_vms_logname_translation < 0)
12489             decc_disable_to_vms_logname_translation = 0;
12490     }
12491
12492     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12493     if (s >= 0) {
12494         decc_efs_case_preserve = decc$feature_get_value(s, 1);
12495         if (decc_efs_case_preserve < 0)
12496             decc_efs_case_preserve = 0;
12497     }
12498
12499     s = decc$feature_get_index("DECC$EFS_CHARSET");
12500     if (s >= 0) {
12501         decc_efs_charset = decc$feature_get_value(s, 1);
12502         if (decc_efs_charset < 0)
12503             decc_efs_charset = 0;
12504     }
12505
12506     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12507     if (s >= 0) {
12508         decc_filename_unix_report = decc$feature_get_value(s, 1);
12509         if (decc_filename_unix_report > 0)
12510             decc_filename_unix_report = 1;
12511         else
12512             decc_filename_unix_report = 0;
12513     }
12514
12515     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12516     if (s >= 0) {
12517         decc_filename_unix_only = decc$feature_get_value(s, 1);
12518         if (decc_filename_unix_only > 0) {
12519             decc_filename_unix_only = 1;
12520         }
12521         else {
12522             decc_filename_unix_only = 0;
12523         }
12524     }
12525
12526     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12527     if (s >= 0) {
12528         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12529         if (decc_filename_unix_no_version < 0)
12530             decc_filename_unix_no_version = 0;
12531     }
12532
12533     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12534     if (s >= 0) {
12535         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12536         if (decc_readdir_dropdotnotype < 0)
12537             decc_readdir_dropdotnotype = 0;
12538     }
12539
12540     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12541     if ($VMS_STATUS_SUCCESS(status)) {
12542         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12543         if (s >= 0) {
12544             dflt = decc$feature_get_value(s, 4);
12545             if (dflt > 0) {
12546                 decc_disable_posix_root = decc$feature_get_value(s, 1);
12547                 if (decc_disable_posix_root <= 0) {
12548                     decc$feature_set_value(s, 1, 1);
12549                     decc_disable_posix_root = 1;
12550                 }
12551             }
12552             else {
12553                 /* Traditionally Perl assumes this is off */
12554                 decc_disable_posix_root = 1;
12555                 decc$feature_set_value(s, 1, 1);
12556             }
12557         }
12558     }
12559
12560 #if __CRTL_VER >= 80200000
12561     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12562     if (s >= 0) {
12563         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12564         if (decc_posix_compliant_pathnames < 0)
12565             decc_posix_compliant_pathnames = 0;
12566         if (decc_posix_compliant_pathnames > 4)
12567             decc_posix_compliant_pathnames = 0;
12568     }
12569
12570 #endif
12571 #else
12572     status = sys_trnlnm
12573         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12574     if ($VMS_STATUS_SUCCESS(status)) {
12575         val_str[0] = _toupper(val_str[0]);
12576         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12577            decc_disable_to_vms_logname_translation = 1;
12578         }
12579     }
12580
12581 #ifndef __VAX
12582     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12583     if ($VMS_STATUS_SUCCESS(status)) {
12584         val_str[0] = _toupper(val_str[0]);
12585         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12586            decc_efs_case_preserve = 1;
12587         }
12588     }
12589 #endif
12590
12591     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12592     if ($VMS_STATUS_SUCCESS(status)) {
12593         val_str[0] = _toupper(val_str[0]);
12594         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12595            decc_filename_unix_report = 1;
12596         }
12597     }
12598     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12599     if ($VMS_STATUS_SUCCESS(status)) {
12600         val_str[0] = _toupper(val_str[0]);
12601         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12602            decc_filename_unix_only = 1;
12603            decc_filename_unix_report = 1;
12604         }
12605     }
12606     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12607     if ($VMS_STATUS_SUCCESS(status)) {
12608         val_str[0] = _toupper(val_str[0]);
12609         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12610            decc_filename_unix_no_version = 1;
12611         }
12612     }
12613     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12614     if ($VMS_STATUS_SUCCESS(status)) {
12615         val_str[0] = _toupper(val_str[0]);
12616         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12617            decc_readdir_dropdotnotype = 1;
12618         }
12619     }
12620 #endif
12621
12622 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12623
12624      /* Report true case tolerance */
12625     /*----------------------------*/
12626     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12627     if (!$VMS_STATUS_SUCCESS(status))
12628         case_perm = PPROP$K_CASE_BLIND;
12629     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12630     if (!$VMS_STATUS_SUCCESS(status))
12631         case_image = PPROP$K_CASE_BLIND;
12632     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12633         (case_image == PPROP$K_CASE_SENSITIVE))
12634         vms_process_case_tolerant = 0;
12635
12636 #endif
12637
12638
12639     /* CRTL can be initialized past this point, but not before. */
12640 /*    DECC$CRTL_INIT(); */
12641
12642     return SS$_NORMAL;
12643 }
12644
12645 #ifdef __DECC
12646 #pragma nostandard
12647 #pragma extern_model save
12648 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12649         const __align (LONGWORD) int spare[8] = {0};
12650
12651 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
12652 #if __DECC_VER >= 60560002
12653 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
12654 #else
12655 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
12656 #endif
12657 #endif /* __DECC */
12658
12659 const long vms_cc_features = (const long)set_features;
12660
12661 /*
12662 ** Force a reference to LIB$INITIALIZE to ensure it
12663 ** exists in the image.
12664 */
12665 int lib$initialize(void);
12666 #ifdef __DECC
12667 #pragma extern_model strict_refdef
12668 #endif
12669     int lib_init_ref = (int) lib$initialize;
12670
12671 #ifdef __DECC
12672 #pragma extern_model restore
12673 #pragma standard
12674 #endif
12675
12676 /*  End of vms.c */