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 #endif
  84 int sys$getdviw
  85        (unsigned long efn,
  86         unsigned short chan,
  87         const struct dsc$descriptor_s * devnam,
  88         const struct item_list_3 * itmlst,
  89         void * iosb,
  90         void * (astadr)(unsigned long),
  91         void * astprm,
  92         void * nullarg);
  93
  94 #ifdef USE_VMS_DECTERM
  95
  96 /* Routine to create a decterm for use with the Perl debugger */
  97 /* No headers, this information was found in the Programming Concepts Manual */
  98
  99 int decw$term_port
 100    (const struct dsc$descriptor_s * display,
 101     const struct dsc$descriptor_s * setup_file,
 102     const struct dsc$descriptor_s * customization,
 103     struct dsc$descriptor_s * result_device_name,
 104     unsigned short * result_device_name_length,
 105     void * controller,
 106     void * char_buffer,
 107     void * char_change_buffer);
 108 #endif
 109
 110 #if __CRTL_VER >= 70300000 && !defined(__VAX)
 111
 112 static int set_feature_default(const char *name, int value)
 113 {
 114     int status;
 115     int index;
 116
 117     index = decc$feature_get_index(name);
 118
 119     status = decc$feature_set_value(index, 1, value);
 120     if (index == -1 || (status == -1)) {
 121       return -1;
 122     }
 123
 124     status = decc$feature_get_value(index, 1);
 125     if (status != value) {
 126       return -1;
 127     }
 128
 129 return 0;
 130 }
 131 #endif
 132
 133 /* Older versions of ssdef.h don't have these */
 134 #ifndef SS$_INVFILFOROP
 135 #  define SS$_INVFILFOROP 3930
 136 #endif
 137 #ifndef SS$_NOSUCHOBJECT
 138 #  define SS$_NOSUCHOBJECT 2696
 139 #endif
 140
 141 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 142 #define PERLIO_NOT_STDIO 0
 143
 144 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 145  * code below needs to get to the underlying CRTL routines. */
 146 #define DONT_MASK_RTL_CALLS
 147 #include "EXTERN.h"
 148 #include "perl.h"
 149 #include "XSUB.h"
 150 /* Anticipating future expansion in lexical warnings . . . */
 151 #ifndef WARN_INTERNAL
 152 #  define WARN_INTERNAL WARN_MISC
 153 #endif
 154
 155 #ifdef VMS_LONGNAME_SUPPORT
 156 #include <libfildef.h>
 157 #endif
 158
 159 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 160 #  define RTL_USES_UTC 1
 161 #endif
 162
 163
 164 /* gcc's header files don't #define direct access macros
 165  * corresponding to VAXC's variant structs */
 166 #ifdef __GNUC__
 167 #  define uic$v_format uic$r_uic_form.uic$v_format
 168 #  define uic$v_group uic$r_uic_form.uic$v_group
 169 #  define uic$v_member uic$r_uic_form.uic$v_member
 170 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 171 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 172 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 173 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 174 #endif
 175
 176 #if defined(NEED_AN_H_ERRNO)
 177 dEXT int h_errno;
 178 #endif
 179
 180 #ifdef __DECC
 181 #pragma message disable pragma
 182 #pragma member_alignment save
 183 #pragma nomember_alignment longword
 184 #pragma message save
 185 #pragma message disable misalgndmem
 186 #endif
 187 struct itmlst_3 {
 188   unsigned short int buflen;
 189   unsigned short int itmcode;
 190   void *bufadr;
 191   unsigned short int *retlen;
 192 };
 193
 194 struct filescan_itmlst_2 {
 195     unsigned short length;
 196     unsigned short itmcode;
 197     char * component;
 198 };
 199
 200 struct vs_str_st {
 201     unsigned short length;
 202     char str[65536];
 203 };
 204
 205 #ifdef __DECC
 206 #pragma message restore
 207 #pragma member_alignment restore
 208 #endif
 209
 210 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 211 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 212 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 213 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 214 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 215 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 216 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 217 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 218 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 219 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 220 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 221
 222 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 223 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 224 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 225 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 226
 227 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 228 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 229
 230 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 231  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 232  * the Perl facility.
 233  */
 234 #define PERL_LNM_MAX_ITER 10
 235
 236   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 237 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 238 #define MAX_DCL_SYMBOL          (8192)
 239 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 240 #else
 241 #define MAX_DCL_SYMBOL          (1024)
 242 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 243 #endif
 244
 245 static char *__mystrtolower(char *str)
 246 {
 247   if (str) for (; *str; ++str) *str= tolower(*str);
 248   return str;
 249 }
 250
 251 static struct dsc$descriptor_s fildevdsc =
 252   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 253 static struct dsc$descriptor_s crtlenvdsc =
 254   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 255 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 256 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 257 static struct dsc$descriptor_s **env_tables = defenv;
 258 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 259
 260 /* True if we shouldn't treat barewords as logicals during directory */
 261 /* munching */
 262 static int no_translate_barewords;
 263
 264 #ifndef RTL_USES_UTC
 265 static int tz_updated = 1;
 266 #endif
 267
 268 /* DECC Features that may need to affect how Perl interprets
 269  * displays filename information
 270  */
 271 static int decc_disable_to_vms_logname_translation = 1;
 272 static int decc_disable_posix_root = 1;
 273 int decc_efs_case_preserve = 0;
 274 static int decc_efs_charset = 0;
 275 static int decc_filename_unix_no_version = 0;
 276 static int decc_filename_unix_only = 0;
 277 int decc_filename_unix_report = 0;
 278 int decc_posix_compliant_pathnames = 0;
 279 int decc_readdir_dropdotnotype = 0;
 280 static int vms_process_case_tolerant = 1;
 281 int vms_vtf7_filenames = 0;
 282 int gnv_unix_shell = 0;
 283
 284 /* bug workarounds if needed */
 285 int decc_bug_readdir_efs1 = 0;
 286 int decc_bug_devnull = 1;
 287 int decc_bug_fgetname = 0;
 288 int decc_dir_barename = 0;
 289
 290 static int vms_debug_on_exception = 0;
 291
 292 /* Is this a UNIX file specification?
 293  *   No longer a simple check with EFS file specs
 294  *   For now, not a full check, but need to
 295  *   handle POSIX ^UP^ specifications
 296  *   Fixing to handle ^/ cases would require
 297  *   changes to many other conversion routines.
 298  */
 299
 300 static int is_unix_filespec(const char *path)
 301 {
 302 int ret_val;
 303 const char * pch1;
 304
 305     ret_val = 0;
 306     if (strncmp(path,"\"^UP^",5) != 0) {
 307         pch1 = strchr(path, '/');
 308         if (pch1 != NULL)
 309             ret_val = 1;
 310         else {
 311
 312             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 313             if (decc_filename_unix_report || decc_filename_unix_only) {
 314             if (strcmp(path,".") == 0)
 315                 ret_val = 1;
 316             }
 317         }
 318     }
 319     return ret_val;
 320 }
 321
 322 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 323  */
 324
 325 static void ucs2_to_vtf7
 326    (char *outspec,
 327     unsigned long ucs2_char,
 328     int * output_cnt)
 329 {
 330 unsigned char * ucs_ptr;
 331 int hex;
 332
 333     ucs_ptr = (unsigned char *)&ucs2_char;
 334
 335     outspec[0] = '^';
 336     outspec[1] = 'U';
 337     hex = (ucs_ptr[1] >> 4) & 0xf;
 338     if (hex < 0xA)
 339         outspec[2] = hex + '0';
 340     else
 341         outspec[2] = (hex - 9) + 'A';
 342     hex = ucs_ptr[1] & 0xF;
 343     if (hex < 0xA)
 344         outspec[3] = hex + '0';
 345     else {
 346         outspec[3] = (hex - 9) + 'A';
 347     }
 348     hex = (ucs_ptr[0] >> 4) & 0xf;
 349     if (hex < 0xA)
 350         outspec[4] = hex + '0';
 351     else
 352         outspec[4] = (hex - 9) + 'A';
 353     hex = ucs_ptr[1] & 0xF;
 354     if (hex < 0xA)
 355         outspec[5] = hex + '0';
 356     else {
 357         outspec[5] = (hex - 9) + 'A';
 358     }
 359     *output_cnt = 6;
 360 }
 361
 362
 363 /* This handles the conversion of a UNIX extended character set to a ^
 364  * escaped VMS character.
 365  * in a UNIX file specification.
 366  *
 367  * The output count variable contains the number of characters added
 368  * to the output string.
 369  *
 370  * The return value is the number of characters read from the input string
 371  */
 372 static int copy_expand_unix_filename_escape
 373   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 374 {
 375 int count;
 376 int scnt;
 377 int utf8_flag;
 378
 379     utf8_flag = 0;
 380     if (utf8_fl)
 381       utf8_flag = *utf8_fl;
 382
 383     count = 0;
 384     *output_cnt = 0;
 385     if (*inspec >= 0x80) {
 386         if (utf8_fl && vms_vtf7_filenames) {
 387         unsigned long ucs_char;
 388
 389             ucs_char = 0;
 390
 391             if ((*inspec & 0xE0) == 0xC0) {
 392                 /* 2 byte Unicode */
 393                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 394                 if (ucs_char >= 0x80) {
 395                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 396                     return 2;
 397                 }
 398             } else if ((*inspec & 0xF0) == 0xE0) {
 399                 /* 3 byte Unicode */
 400                 ucs_char = ((inspec[0] & 0xF) << 12) +
 401                    ((inspec[1] & 0x3f) << 6) +
 402                    (inspec[2] & 0x3f);
 403                 if (ucs_char >= 0x800) {
 404                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 405                     return 3;
 406                 }
 407
 408 #if 0 /* I do not see longer sequences supported by OpenVMS */
 409       /* Maybe some one can fix this later */
 410             } else if ((*inspec & 0xF8) == 0xF0) {
 411                 /* 4 byte Unicode */
 412                 /* UCS-4 to UCS-2 */
 413             } else if ((*inspec & 0xFC) == 0xF8) {
 414                 /* 5 byte Unicode */
 415                 /* UCS-4 to UCS-2 */
 416             } else if ((*inspec & 0xFE) == 0xFC) {
 417                 /* 6 byte Unicode */
 418                 /* UCS-4 to UCS-2 */
 419 #endif
 420             }
 421         }
 422
 423         /* High bit set, but not a unicode character! */
 424
 425         /* Non printing DECMCS or ISO Latin-1 character? */
 426         if (*inspec <= 0x9F) {
 427         int hex;
 428             outspec[0] = '^';
 429             outspec++;
 430             hex = (*inspec >> 4) & 0xF;
 431             if (hex < 0xA)
 432                 outspec[1] = hex + '0';
 433             else {
 434                 outspec[1] = (hex - 9) + 'A';
 435             }
 436             hex = *inspec & 0xF;
 437             if (hex < 0xA)
 438                 outspec[2] = hex + '0';
 439             else {
 440                 outspec[2] = (hex - 9) + 'A';
 441             }
 442             *output_cnt = 3;
 443             return 1;
 444         } else if (*inspec == 0xA0) {
 445             outspec[0] = '^';
 446             outspec[1] = 'A';
 447             outspec[2] = '0';
 448             *output_cnt = 3;
 449             return 1;
 450         } else if (*inspec == 0xFF) {
 451             outspec[0] = '^';
 452             outspec[1] = 'F';
 453             outspec[2] = 'F';
 454             *output_cnt = 3;
 455             return 1;
 456         }
 457         *outspec = *inspec;
 458         *output_cnt = 1;
 459         return 1;
 460     }
 461
 462     /* Is this a macro that needs to be passed through?
 463      * Macros start with $( and an alpha character, followed
 464      * by a string of alpha numeric characters ending with a )
 465      * If this does not match, then encode it as ODS-5.
 466      */
 467     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 468     int tcnt;
 469
 470         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 471             tcnt = 3;
 472             outspec[0] = inspec[0];
 473             outspec[1] = inspec[1];
 474             outspec[2] = inspec[2];
 475
 476             while(isalnum(inspec[tcnt]) ||
 477                   (inspec[2] == '.') || (inspec[2] == '_')) {
 478                 outspec[tcnt] = inspec[tcnt];
 479                 tcnt++;
 480             }
 481             if (inspec[tcnt] == ')') {
 482                 outspec[tcnt] = inspec[tcnt];
 483                 tcnt++;
 484                 *output_cnt = tcnt;
 485                 return tcnt;
 486             }
 487         }
 488     }
 489
 490     switch (*inspec) {
 491     case 0x7f:
 492         outspec[0] = '^';
 493         outspec[1] = '7';
 494         outspec[2] = 'F';
 495         *output_cnt = 3;
 496         return 1;
 497         break;
 498     case '?':
 499         if (decc_efs_charset == 0)
 500           outspec[0] = '%';
 501         else
 502           outspec[0] = '?';
 503         *output_cnt = 1;
 504         return 1;
 505         break;
 506     case '.':
 507     case '~':
 508     case '!':
 509     case '#':
 510     case '&':
 511     case '\'':
 512     case '`':
 513     case '(':
 514     case ')':
 515     case '+':
 516     case '@':
 517     case '{':
 518     case '}':
 519     case ',':
 520     case ';':
 521     case '[':
 522     case ']':
 523     case '%':
 524     case '^':
 525     case '=':
 526         /* Assume that this is to be escaped */
 527         outspec[0] = '^';
 528         outspec[1] = *inspec;
 529         *output_cnt = 2;
 530         return 1;
 531         break;
 532     case ' ': /* space */
 533         /* Assume that this is to be escaped */
 534         outspec[0] = '^';
 535         outspec[1] = '_';
 536         *output_cnt = 2;
 537         return 1;
 538         break;
 539     default:
 540         *outspec = *inspec;
 541         *output_cnt = 1;
 542         return 1;
 543         break;
 544     }
 545 }
 546
 547
 548 /* This handles the expansion of a '^' prefix to the proper character
 549  * in a UNIX file specification.
 550  *
 551  * The output count variable contains the number of characters added
 552  * to the output string.
 553  *
 554  * The return value is the number of characters read from the input
 555  * string
 556  */
 557 static int copy_expand_vms_filename_escape
 558   (char *outspec, const char *inspec, int *output_cnt)
 559 {
 560 int count;
 561 int scnt;
 562
 563     count = 0;
 564     *output_cnt = 0;
 565     if (*inspec == '^') {
 566         inspec++;
 567         switch (*inspec) {
 568         case '.':
 569             /* Non trailing dots should just be passed through */
 570             *outspec = *inspec;
 571             count++;
 572             (*output_cnt)++;
 573             break;
 574         case '_': /* space */
 575             *outspec = ' ';
 576             inspec++;
 577             count++;
 578             (*output_cnt)++;
 579             break;
 580         case 'U': /* Unicode - FIX-ME this is wrong. */
 581             inspec++;
 582             count++;
 583             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 584             if (scnt == 4) {
 585                 unsigned int c1, c2;
 586                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 587                 outspec[0] == c1 & 0xff;
 588                 outspec[1] == c2 & 0xff;
 589                 if (scnt > 1) {
 590                     (*output_cnt) += 2;
 591                     count += 4;
 592                 }
 593             }
 594             else {
 595                 /* Error - do best we can to continue */
 596                 *outspec = 'U';
 597                 outspec++;
 598                 (*output_cnt++);
 599                 *outspec = *inspec;
 600                 count++;
 601                 (*output_cnt++);
 602             }
 603             break;
 604         default:
 605             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 606             if (scnt == 2) {
 607                 /* Hex encoded */
 608                 unsigned int c1;
 609                 scnt = sscanf(inspec, "%2x", &c1);
 610                 outspec[0] = c1 & 0xff;
 611                 if (scnt > 0) {
 612                     (*output_cnt++);
 613                     count += 2;
 614                 }
 615             }
 616             else {
 617                 *outspec = *inspec;
 618                 count++;
 619                 (*output_cnt++);
 620             }
 621         }
 622     }
 623     else {
 624         *outspec = *inspec;
 625         count++;
 626         (*output_cnt)++;
 627     }
 628     return count;
 629 }
 630
 631
 632 int SYS$FILESCAN
 633    (const struct dsc$descriptor_s * srcstr,
 634     struct filescan_itmlst_2 * valuelist,
 635     unsigned long * fldflags,
 636     struct dsc$descriptor_s *auxout,
 637     unsigned short * retlen);
 638
 639 /* vms_split_path - Verify that the input file specification is a
 640  * VMS format file specification, and provide pointers to the components of
 641  * it.  With EFS format filenames, this is virtually the only way to
 642  * parse a VMS path specification into components.
 643  *
 644  * If the sum of the components do not add up to the length of the
 645  * string, then the passed file specification is probably a UNIX style
 646  * path.
 647  */
 648 static int vms_split_path
 649    (const char * path,
 650     char * * volume,
 651     int * vol_len,
 652     char * * root,
 653     int * root_len,
 654     char * * dir,
 655     int * dir_len,
 656     char * * name,
 657     int * name_len,
 658     char * * ext,
 659     int * ext_len,
 660     char * * version,
 661     int * ver_len)
 662 {
 663 struct dsc$descriptor path_desc;
 664 int status;
 665 unsigned long flags;
 666 int ret_stat;
 667 struct filescan_itmlst_2 item_list[9];
 668 const int filespec = 0;
 669 const int nodespec = 1;
 670 const int devspec = 2;
 671 const int rootspec = 3;
 672 const int dirspec = 4;
 673 const int namespec = 5;
 674 const int typespec = 6;
 675 const int verspec = 7;
 676
 677     /* Assume the worst for an easy exit */
 678     ret_stat = -1;
 679     *volume = NULL;
 680     *vol_len = 0;
 681     *root = NULL;
 682     *root_len = 0;
 683     *dir = NULL;
 684     *dir_len;
 685     *name = NULL;
 686     *name_len = 0;
 687     *ext = NULL;
 688     *ext_len = 0;
 689     *version = NULL;
 690     *ver_len = 0;
 691
 692     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 693     path_desc.dsc$w_length = strlen(path);
 694     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 695     path_desc.dsc$b_class = DSC$K_CLASS_S;
 696
 697     /* Get the total length, if it is shorter than the string passed
 698      * then this was probably not a VMS formatted file specification
 699      */
 700     item_list[filespec].itmcode = FSCN$_FILESPEC;
 701     item_list[filespec].length = 0;
 702     item_list[filespec].component = NULL;
 703
 704     /* If the node is present, then it gets considered as part of the
 705      * volume name to hopefully make things simple.
 706      */
 707     item_list[nodespec].itmcode = FSCN$_NODE;
 708     item_list[nodespec].length = 0;
 709     item_list[nodespec].component = NULL;
 710
 711     item_list[devspec].itmcode = FSCN$_DEVICE;
 712     item_list[devspec].length = 0;
 713     item_list[devspec].component = NULL;
 714
 715     /* root is a special case,  adding it to either the directory or
 716      * the device components will probalby complicate things for the
 717      * callers of this routine, so leave it separate.
 718      */
 719     item_list[rootspec].itmcode = FSCN$_ROOT;
 720     item_list[rootspec].length = 0;
 721     item_list[rootspec].component = NULL;
 722
 723     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 724     item_list[dirspec].length = 0;
 725     item_list[dirspec].component = NULL;
 726
 727     item_list[namespec].itmcode = FSCN$_NAME;
 728     item_list[namespec].length = 0;
 729     item_list[namespec].component = NULL;
 730
 731     item_list[typespec].itmcode = FSCN$_TYPE;
 732     item_list[typespec].length = 0;
 733     item_list[typespec].component = NULL;
 734
 735     item_list[verspec].itmcode = FSCN$_VERSION;
 736     item_list[verspec].length = 0;
 737     item_list[verspec].component = NULL;
 738
 739     item_list[8].itmcode = 0;
 740     item_list[8].length = 0;
 741     item_list[8].component = NULL;
 742
 743     status = SYS$FILESCAN
 744        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 745         &flags, NULL, NULL);
 746     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 747
 748     /* If we parsed it successfully these two lengths should be the same */
 749     if (path_desc.dsc$w_length != item_list[filespec].length)
 750         return ret_stat;
 751
 752     /* If we got here, then it is a VMS file specification */
 753     ret_stat = 0;
 754
 755     /* set the volume name */
 756     if (item_list[nodespec].length > 0) {
 757         *volume = item_list[nodespec].component;
 758         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 759     }
 760     else {
 761         *volume = item_list[devspec].component;
 762         *vol_len = item_list[devspec].length;
 763     }
 764
 765     *root = item_list[rootspec].component;
 766     *root_len = item_list[rootspec].length;
 767
 768     *dir = item_list[dirspec].component;
 769     *dir_len = item_list[dirspec].length;
 770
 771     /* Now fun with versions and EFS file specifications
 772      * The parser can not tell the difference when a "." is a version
 773      * delimiter or a part of the file specification.
 774      */
 775     if ((decc_efs_charset) &&
 776         (item_list[verspec].length > 0) &&
 777         (item_list[verspec].component[0] == '.')) {
 778         *name = item_list[namespec].component;
 779         *name_len = item_list[namespec].length + item_list[typespec].length;
 780         *ext = item_list[verspec].component;
 781         *ext_len = item_list[verspec].length;
 782         *version = NULL;
 783         *ver_len = 0;
 784     }
 785     else {
 786         *name = item_list[namespec].component;
 787         *name_len = item_list[namespec].length;
 788         *ext = item_list[typespec].component;
 789         *ext_len = item_list[typespec].length;
 790         *version = item_list[verspec].component;
 791         *ver_len = item_list[verspec].length;
 792     }
 793     return ret_stat;
 794 }
 795
 796
 797 /* my_maxidx
 798  * Routine to retrieve the maximum equivalence index for an input
 799  * logical name.  Some calls to this routine have no knowledge if
 800  * the variable is a logical or not.  So on error we return a max
 801  * index of zero.
 802  */
 803 /*{{{int my_maxidx(const char *lnm) */
 804 static int
 805 my_maxidx(const char *lnm)
 806 {
 807     int status;
 808     int midx;
 809     int attr = LNM$M_CASE_BLIND;
 810     struct dsc$descriptor lnmdsc;
 811     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 812                                 {0, 0, 0, 0}};
 813
 814     lnmdsc.dsc$w_length = strlen(lnm);
 815     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 816     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 817     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 818
 819     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 820     if ((status & 1) == 0)
 821        midx = 0;
 822
 823     return (midx);
 824 }
 825 /*}}}*/
 826
 827 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 828 int
 829 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 830   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 831 {
 832     const char *cp1;
 833     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 834     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 835     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 836     int midx;
 837     unsigned char acmode;
 838     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 839                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 840     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 841                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 842                                  {0, 0, 0, 0}};
 843     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 844 #if defined(PERL_IMPLICIT_CONTEXT)
 845     pTHX = NULL;
 846     if (PL_curinterp) {
 847       aTHX = PERL_GET_INTERP;
 848     } else {
 849       aTHX = NULL;
 850     }
 851 #endif
 852
 853     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 854       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 855     }
 856     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 857       *cp2 = _toupper(*cp1);
 858       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 859         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 860         return 0;
 861       }
 862     }
 863     lnmdsc.dsc$w_length = cp1 - lnm;
 864     lnmdsc.dsc$a_pointer = uplnm;
 865     uplnm[lnmdsc.dsc$w_length] = '\0';
 866     secure = flags & PERL__TRNENV_SECURE;
 867     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 868     if (!tabvec || !*tabvec) tabvec = env_tables;
 869
 870     for (curtab = 0; tabvec[curtab]; curtab++) {
 871       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 872         if (!ivenv && !secure) {
 873           char *eq, *end;
 874           int i;
 875           if (!environ) {
 876             ivenv = 1;
 877             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 878             continue;
 879           }
 880           retsts = SS$_NOLOGNAM;
 881           for (i = 0; environ[i]; i++) {
 882             if ((eq = strchr(environ[i],'=')) &&
 883                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 884                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 885               eq++;
 886               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 887               if (!eqvlen) continue;
 888               retsts = SS$_NORMAL;
 889               break;
 890             }
 891           }
 892           if (retsts != SS$_NOLOGNAM) break;
 893         }
 894       }
 895       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 896                !str$case_blind_compare(&tmpdsc,&clisym)) {
 897         if (!ivsym && !secure) {
 898           unsigned short int deflen = LNM$C_NAMLENGTH;
 899           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 900           /* dynamic dsc to accomodate possible long value */
 901           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 902           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 903           if (retsts & 1) {
 904             if (eqvlen > MAX_DCL_SYMBOL) {
 905               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 906               eqvlen = MAX_DCL_SYMBOL;
 907               /* Special hack--we might be called before the interpreter's */
 908               /* fully initialized, in which case either thr or PL_curcop */
 909               /* might be bogus. We have to check, since ckWARN needs them */
 910               /* both to be valid if running threaded */
 911                 if (ckWARN(WARN_MISC)) {
 912                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 913                 }
 914             }
 915             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 916           }
 917           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 918           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 919           if (retsts == LIB$_NOSUCHSYM) continue;
 920           break;
 921         }
 922       }
 923       else if (!ivlnm) {
 924         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 925           midx = my_maxidx(lnm);
 926           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 927             lnmlst[1].bufadr = cp2;
 928             eqvlen = 0;
 929             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 930             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 931             if (retsts == SS$_NOLOGNAM) break;
 932             /* PPFs have a prefix */
 933             if (
 934 #if INTSIZE == 4
 935                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 936 #endif
 937                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 938                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 939                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 940                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 941                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 942               memmove(eqv,eqv+4,eqvlen-4);
 943               eqvlen -= 4;
 944             }
 945             cp2 += eqvlen;
 946             *cp2 = '\0';
 947           }
 948           if ((retsts == SS$_IVLOGNAM) ||
 949               (retsts == SS$_NOLOGNAM)) { continue; }
 950         }
 951         else {
 952           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 953           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 954           if (retsts == SS$_NOLOGNAM) continue;
 955           eqv[eqvlen] = '\0';
 956         }
 957         eqvlen = strlen(eqv);
 958         break;
 959       }
 960     }
 961     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 962     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 963              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 964              retsts == SS$_NOLOGNAM) {
 965       set_errno(EINVAL);  set_vaxc_errno(retsts);
 966     }
 967     else _ckvmssts(retsts);
 968     return 0;
 969 }  /* end of vmstrnenv */
 970 /*}}}*/
 971
 972 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 973 /* Define as a function so we can access statics. */
 974 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 975 {
 976   return vmstrnenv(lnm,eqv,idx,fildev,
 977 #ifdef SECURE_INTERNAL_GETENV
 978                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 979 #else
 980                    0
 981 #endif
 982                                                                               );
 983 }
 984 /*}}}*/
 985
 986 /* my_getenv
 987  * Note: Uses Perl temp to store result so char * can be returned to
 988  * caller; this pointer will be invalidated at next Perl statement
 989  * transition.
 990  * We define this as a function rather than a macro in terms of my_getenv_len()
 991  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 992  * allocate SVs).
 993  */
 994 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 995 char *
 996 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 997 {
 998     const char *cp1;
 999     static char *__my_getenv_eqv = NULL;
1000     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1001     unsigned long int idx = 0;
1002     int trnsuccess, success, secure, saverr, savvmserr;
1003     int midx, flags;
1004     SV *tmpsv;
1005
1006     midx = my_maxidx(lnm) + 1;
1007
1008     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1009       /* Set up a temporary buffer for the return value; Perl will
1010        * clean it up at the next statement transition */
1011       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1012       if (!tmpsv) return NULL;
1013       eqv = SvPVX(tmpsv);
1014     }
1015     else {
1016       /* Assume no interpreter ==> single thread */
1017       if (__my_getenv_eqv != NULL) {
1018         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1019       }
1020       else {
1021         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1022       }
1023       eqv = __my_getenv_eqv;
1024     }
1025
1026     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1027     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1028       int len;
1029       getcwd(eqv,LNM$C_NAMLENGTH);
1030
1031       len = strlen(eqv);
1032
1033       /* Get rid of "000000/ in rooted filespecs */
1034       if (len > 7) {
1035         char * zeros;
1036         zeros = strstr(eqv, "/000000/");
1037         if (zeros != NULL) {
1038           int mlen;
1039           mlen = len - (zeros - eqv) - 7;
1040           memmove(zeros, &zeros[7], mlen);
1041           len = len - 7;
1042           eqv[len] = '\0';
1043         }
1044       }
1045       return eqv;
1046     }
1047     else {
1048       /* Impose security constraints only if tainting */
1049       if (sys) {
1050         /* Impose security constraints only if tainting */
1051         secure = PL_curinterp ? PL_tainting : will_taint;
1052         saverr = errno;  savvmserr = vaxc$errno;
1053       }
1054       else {
1055         secure = 0;
1056       }
1057
1058       flags =
1059 #ifdef SECURE_INTERNAL_GETENV
1060               secure ? PERL__TRNENV_SECURE : 0
1061 #else
1062               0
1063 #endif
1064       ;
1065
1066       /* For the getenv interface we combine all the equivalence names
1067        * of a search list logical into one value to acquire a maximum
1068        * value length of 255*128 (assuming %ENV is using logicals).
1069        */
1070       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1071
1072       /* If the name contains a semicolon-delimited index, parse it
1073        * off and make sure we only retrieve the equivalence name for
1074        * that index.  */
1075       if ((cp2 = strchr(lnm,';')) != NULL) {
1076         strcpy(uplnm,lnm);
1077         uplnm[cp2-lnm] = '\0';
1078         idx = strtoul(cp2+1,NULL,0);
1079         lnm = uplnm;
1080         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1081       }
1082
1083       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1084
1085       /* Discard NOLOGNAM on internal calls since we're often looking
1086        * for an optional name, and this "error" often shows up as the
1087        * (bogus) exit status for a die() call later on.  */
1088       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1089       return success ? eqv : Nullch;
1090     }
1091
1092 }  /* end of my_getenv() */
1093 /*}}}*/
1094
1095
1096 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1097 char *
1098 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1099 {
1100     const char *cp1;
1101     char *buf, *cp2;
1102     unsigned long idx = 0;
1103     int midx, flags;
1104     static char *__my_getenv_len_eqv = NULL;
1105     int secure, saverr, savvmserr;
1106     SV *tmpsv;
1107
1108     midx = my_maxidx(lnm) + 1;
1109
1110     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1111       /* Set up a temporary buffer for the return value; Perl will
1112        * clean it up at the next statement transition */
1113       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1114       if (!tmpsv) return NULL;
1115       buf = SvPVX(tmpsv);
1116     }
1117     else {
1118       /* Assume no interpreter ==> single thread */
1119       if (__my_getenv_len_eqv != NULL) {
1120         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1121       }
1122       else {
1123         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1124       }
1125       buf = __my_getenv_len_eqv;
1126     }
1127
1128     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1129     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1130     char * zeros;
1131
1132       getcwd(buf,LNM$C_NAMLENGTH);
1133       *len = strlen(buf);
1134
1135       /* Get rid of "000000/ in rooted filespecs */
1136       if (*len > 7) {
1137       zeros = strstr(buf, "/000000/");
1138       if (zeros != NULL) {
1139         int mlen;
1140         mlen = *len - (zeros - buf) - 7;
1141         memmove(zeros, &zeros[7], mlen);
1142         *len = *len - 7;
1143         buf[*len] = '\0';
1144         }
1145       }
1146       return buf;
1147     }
1148     else {
1149       if (sys) {
1150         /* Impose security constraints only if tainting */
1151         secure = PL_curinterp ? PL_tainting : will_taint;
1152         saverr = errno;  savvmserr = vaxc$errno;
1153       }
1154       else {
1155         secure = 0;
1156       }
1157
1158       flags =
1159 #ifdef SECURE_INTERNAL_GETENV
1160               secure ? PERL__TRNENV_SECURE : 0
1161 #else
1162               0
1163 #endif
1164       ;
1165
1166       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1167
1168       if ((cp2 = strchr(lnm,';')) != NULL) {
1169         strcpy(buf,lnm);
1170         buf[cp2-lnm] = '\0';
1171         idx = strtoul(cp2+1,NULL,0);
1172         lnm = buf;
1173         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1174       }
1175
1176       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1177
1178       /* Get rid of "000000/ in rooted filespecs */
1179       if (*len > 7) {
1180       char * zeros;
1181         zeros = strstr(buf, "/000000/");
1182         if (zeros != NULL) {
1183           int mlen;
1184           mlen = *len - (zeros - buf) - 7;
1185           memmove(zeros, &zeros[7], mlen);
1186           *len = *len - 7;
1187           buf[*len] = '\0';
1188         }
1189       }
1190
1191       /* Discard NOLOGNAM on internal calls since we're often looking
1192        * for an optional name, and this "error" often shows up as the
1193        * (bogus) exit status for a die() call later on.  */
1194       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1195       return *len ? buf : Nullch;
1196     }
1197
1198 }  /* end of my_getenv_len() */
1199 /*}}}*/
1200
1201 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1202
1203 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1204
1205 /*{{{ void prime_env_iter() */
1206 void
1207 prime_env_iter(void)
1208 /* Fill the %ENV associative array with all logical names we can
1209  * find, in preparation for iterating over it.
1210  */
1211 {
1212   static int primed = 0;
1213   HV *seenhv = NULL, *envhv;
1214   SV *sv = NULL;
1215   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1216   unsigned short int chan;
1217 #ifndef CLI$M_TRUSTED
1218 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1219 #endif
1220   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1221   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1222   long int i;
1223   bool have_sym = FALSE, have_lnm = FALSE;
1224   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1225   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1226   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1227   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1228   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1229 #if defined(PERL_IMPLICIT_CONTEXT)
1230   pTHX;
1231 #endif
1232 #if defined(USE_ITHREADS)
1233   static perl_mutex primenv_mutex;
1234   MUTEX_INIT(&primenv_mutex);
1235 #endif
1236
1237 #if defined(PERL_IMPLICIT_CONTEXT)
1238     /* We jump through these hoops because we can be called at */
1239     /* platform-specific initialization time, which is before anything is */
1240     /* set up--we can't even do a plain dTHX since that relies on the */
1241     /* interpreter structure to be initialized */
1242     if (PL_curinterp) {
1243       aTHX = PERL_GET_INTERP;
1244     } else {
1245       aTHX = NULL;
1246     }
1247 #endif
1248
1249   if (primed || !PL_envgv) return;
1250   MUTEX_LOCK(&primenv_mutex);
1251   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1252   envhv = GvHVn(PL_envgv);
1253   /* Perform a dummy fetch as an lval to insure that the hash table is
1254    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1255   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1256
1257   for (i = 0; env_tables[i]; i++) {
1258      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1259          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1260      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1261   }
1262   if (have_sym || have_lnm) {
1263     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1264     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1265     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1266     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1267   }
1268
1269   for (i--; i >= 0; i--) {
1270     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1271       char *start;
1272       int j;
1273       for (j = 0; environ[j]; j++) {
1274         if (!(start = strchr(environ[j],'='))) {
1275           if (ckWARN(WARN_INTERNAL))
1276             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1277         }
1278         else {
1279           start++;
1280           sv = newSVpv(start,0);
1281           SvTAINTED_on(sv);
1282           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1283         }
1284       }
1285       continue;
1286     }
1287     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1288              !str$case_blind_compare(&tmpdsc,&clisym)) {
1289       strcpy(cmd,"Show Symbol/Global *");
1290       cmddsc.dsc$w_length = 20;
1291       if (env_tables[i]->dsc$w_length == 12 &&
1292           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1293           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1294       flags = defflags | CLI$M_NOLOGNAM;
1295     }
1296     else {
1297       strcpy(cmd,"Show Logical *");
1298       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1299         strcat(cmd," /Table=");
1300         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1301         cmddsc.dsc$w_length = strlen(cmd);
1302       }
1303       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1304       flags = defflags | CLI$M_NOCLISYM;
1305     }
1306
1307     /* Create a new subprocess to execute each command, to exclude the
1308      * remote possibility that someone could subvert a mbx or file used
1309      * to write multiple commands to a single subprocess.
1310      */
1311     do {
1312       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1313                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1314       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1315       defflags &= ~CLI$M_TRUSTED;
1316     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1317     _ckvmssts(retsts);
1318     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1319     if (seenhv) SvREFCNT_dec(seenhv);
1320     seenhv = newHV();
1321     while (1) {
1322       char *cp1, *cp2, *key;
1323       unsigned long int sts, iosb[2], retlen, keylen;
1324       register U32 hash;
1325
1326       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1327       if (sts & 1) sts = iosb[0] & 0xffff;
1328       if (sts == SS$_ENDOFFILE) {
1329         int wakect = 0;
1330         while (substs == 0) { sys$hiber(); wakect++;}
1331         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1332         _ckvmssts(substs);
1333         break;
1334       }
1335       _ckvmssts(sts);
1336       retlen = iosb[0] >> 16;
1337       if (!retlen) continue;  /* blank line */
1338       buf[retlen] = '\0';
1339       if (iosb[1] != subpid) {
1340         if (iosb[1]) {
1341           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1342         }
1343         continue;
1344       }
1345       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1346         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1347
1348       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1349       if (*cp1 == '(' || /* Logical name table name */
1350           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1351       if (*cp1 == '"') cp1++;
1352       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1353       key = cp1;  keylen = cp2 - cp1;
1354       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1355       while (*cp2 && *cp2 != '=') cp2++;
1356       while (*cp2 && *cp2 == '=') cp2++;
1357       while (*cp2 && *cp2 == ' ') cp2++;
1358       if (*cp2 == '"') {  /* String translation; may embed "" */
1359         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1360         cp2++;  cp1--; /* Skip "" surrounding translation */
1361       }
1362       else {  /* Numeric translation */
1363         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1364         cp1--;  /* stop on last non-space char */
1365       }
1366       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1367         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1368         continue;
1369       }
1370       PERL_HASH(hash,key,keylen);
1371
1372       if (cp1 == cp2 && *cp2 == '.') {
1373         /* A single dot usually means an unprintable character, such as a null
1374          * to indicate a zero-length value.  Get the actual value to make sure.
1375          */
1376         char lnm[LNM$C_NAMLENGTH+1];
1377         char eqv[MAX_DCL_SYMBOL+1];
1378         int trnlen;
1379         strncpy(lnm, key, keylen);
1380         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1381         sv = newSVpvn(eqv, strlen(eqv));
1382       }
1383       else {
1384         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1385       }
1386
1387       SvTAINTED_on(sv);
1388       hv_store(envhv,key,keylen,sv,hash);
1389       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1390     }
1391     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1392       /* get the PPFs for this process, not the subprocess */
1393       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1394       char eqv[LNM$C_NAMLENGTH+1];
1395       int trnlen, i;
1396       for (i = 0; ppfs[i]; i++) {
1397         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1398         sv = newSVpv(eqv,trnlen);
1399         SvTAINTED_on(sv);
1400         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1401       }
1402     }
1403   }
1404   primed = 1;
1405   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1406   if (buf) Safefree(buf);
1407   if (seenhv) SvREFCNT_dec(seenhv);
1408   MUTEX_UNLOCK(&primenv_mutex);
1409   return;
1410
1411 }  /* end of prime_env_iter */
1412 /*}}}*/
1413
1414
1415 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1416 /* Define or delete an element in the same "environment" as
1417  * vmstrnenv().  If an element is to be deleted, it's removed from
1418  * the first place it's found.  If it's to be set, it's set in the
1419  * place designated by the first element of the table vector.
1420  * Like setenv() returns 0 for success, non-zero on error.
1421  */
1422 int
1423 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1424 {
1425     const char *cp1;
1426     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1427     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1428     int nseg = 0, j;
1429     unsigned long int retsts, usermode = PSL$C_USER;
1430     struct itmlst_3 *ile, *ilist;
1431     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1432                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1433                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1434     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1435     $DESCRIPTOR(local,"_LOCAL");
1436
1437     if (!lnm) {
1438         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1439         return SS$_IVLOGNAM;
1440     }
1441
1442     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1443       *cp2 = _toupper(*cp1);
1444       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1445         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1446         return SS$_IVLOGNAM;
1447       }
1448     }
1449     lnmdsc.dsc$w_length = cp1 - lnm;
1450     if (!tabvec || !*tabvec) tabvec = env_tables;
1451
1452     if (!eqv) {  /* we're deleting n element */
1453       for (curtab = 0; tabvec[curtab]; curtab++) {
1454         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1455         int i;
1456           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1457             if ((cp1 = strchr(environ[i],'=')) &&
1458                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1459                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1460 #ifdef HAS_SETENV
1461               return setenv(lnm,"",1) ? vaxc$errno : 0;
1462             }
1463           }
1464           ivenv = 1; retsts = SS$_NOLOGNAM;
1465 #else
1466               if (ckWARN(WARN_INTERNAL))
1467                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1468               ivenv = 1; retsts = SS$_NOSUCHPGM;
1469               break;
1470             }
1471           }
1472 #endif
1473         }
1474         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1475                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1476           unsigned int symtype;
1477           if (tabvec[curtab]->dsc$w_length == 12 &&
1478               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1479               !str$case_blind_compare(&tmpdsc,&local))
1480             symtype = LIB$K_CLI_LOCAL_SYM;
1481           else symtype = LIB$K_CLI_GLOBAL_SYM;
1482           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1483           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1484           if (retsts == LIB$_NOSUCHSYM) continue;
1485           break;
1486         }
1487         else if (!ivlnm) {
1488           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1489           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1490           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1491           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1492           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1493         }
1494       }
1495     }
1496     else {  /* we're defining a value */
1497       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1498 #ifdef HAS_SETENV
1499         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1500 #else
1501         if (ckWARN(WARN_INTERNAL))
1502           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1503         retsts = SS$_NOSUCHPGM;
1504 #endif
1505       }
1506       else {
1507         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1508         eqvdsc.dsc$w_length  = strlen(eqv);
1509         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1510             !str$case_blind_compare(&tmpdsc,&clisym)) {
1511           unsigned int symtype;
1512           if (tabvec[0]->dsc$w_length == 12 &&
1513               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1514                !str$case_blind_compare(&tmpdsc,&local))
1515             symtype = LIB$K_CLI_LOCAL_SYM;
1516           else symtype = LIB$K_CLI_GLOBAL_SYM;
1517           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1518         }
1519         else {
1520           if (!*eqv) eqvdsc.dsc$w_length = 1;
1521           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1522
1523             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1524             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1525               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1526                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1527               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1528               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1529             }
1530
1531             Newx(ilist,nseg+1,struct itmlst_3);
1532             ile = ilist;
1533             if (!ile) {
1534               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1535               return SS$_INSFMEM;
1536             }
1537             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1538
1539             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1540               ile->itmcode = LNM$_STRING;
1541               ile->bufadr = c;
1542               if ((j+1) == nseg) {
1543                 ile->buflen = strlen(c);
1544                 /* in case we are truncating one that's too long */
1545                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1546               }
1547               else {
1548                 ile->buflen = LNM$C_NAMLENGTH;
1549               }
1550             }
1551
1552             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1553             Safefree (ilist);
1554           }
1555           else {
1556             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1557           }
1558         }
1559       }
1560     }
1561     if (!(retsts & 1)) {
1562       switch (retsts) {
1563         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1564         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1565           set_errno(EVMSERR); break;
1566         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1567         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1568           set_errno(EINVAL); break;
1569         case SS$_NOPRIV:
1570           set_errno(EACCES); break;
1571         default:
1572           _ckvmssts(retsts);
1573           set_errno(EVMSERR);
1574        }
1575        set_vaxc_errno(retsts);
1576        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1577     }
1578     else {
1579       /* We reset error values on success because Perl does an hv_fetch()
1580        * before each hv_store(), and if the thing we're setting didn't
1581        * previously exist, we've got a leftover error message.  (Of course,
1582        * this fails in the face of
1583        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1584        * in that the error reported in $! isn't spurious,
1585        * but it's right more often than not.)
1586        */
1587       set_errno(0); set_vaxc_errno(retsts);
1588       return 0;
1589     }
1590
1591 }  /* end of vmssetenv() */
1592 /*}}}*/
1593
1594 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1595 /* This has to be a function since there's a prototype for it in proto.h */
1596 void
1597 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1598 {
1599     if (lnm && *lnm) {
1600       int len = strlen(lnm);
1601       if  (len == 7) {
1602         char uplnm[8];
1603         int i;
1604         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1605         if (!strcmp(uplnm,"DEFAULT")) {
1606           if (eqv && *eqv) my_chdir(eqv);
1607           return;
1608         }
1609     }
1610 #ifndef RTL_USES_UTC
1611     if (len == 6 || len == 2) {
1612       char uplnm[7];
1613       int i;
1614       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1615       uplnm[len] = '\0';
1616       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1617       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1618     }
1619 #endif
1620   }
1621   (void) vmssetenv(lnm,eqv,NULL);
1622 }
1623 /*}}}*/
1624
1625 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1626 /*  vmssetuserlnm
1627  *  sets a user-mode logical in the process logical name table
1628  *  used for redirection of sys$error
1629  */
1630 void
1631 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1632 {
1633     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1634     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1635     unsigned long int iss, attr = LNM$M_CONFINE;
1636     unsigned char acmode = PSL$C_USER;
1637     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1638                                  {0, 0, 0, 0}};
1639     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1640     d_name.dsc$w_length = strlen(name);
1641
1642     lnmlst[0].buflen = strlen(eqv);
1643     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1644
1645     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1646     if (!(iss&1)) lib$signal(iss);
1647 }
1648 /*}}}*/
1649
1650
1651 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1652 /* my_crypt - VMS password hashing
1653  * my_crypt() provides an interface compatible with the Unix crypt()
1654  * C library function, and uses sys$hash_password() to perform VMS
1655  * password hashing.  The quadword hashed password value is returned
1656  * as a NUL-terminated 8 character string.  my_crypt() does not change
1657  * the case of its string arguments; in order to match the behavior
1658  * of LOGINOUT et al., alphabetic characters in both arguments must
1659  *  be upcased by the caller.
1660  *
1661  * - fix me to call ACM services when available
1662  */
1663 char *
1664 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1665 {
1666 #   ifndef UAI$C_PREFERRED_ALGORITHM
1667 #     define UAI$C_PREFERRED_ALGORITHM 127
1668 #   endif
1669     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1670     unsigned short int salt = 0;
1671     unsigned long int sts;
1672     struct const_dsc {
1673         unsigned short int dsc$w_length;
1674         unsigned char      dsc$b_type;
1675         unsigned char      dsc$b_class;
1676         const char *       dsc$a_pointer;
1677     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1678        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1679     struct itmlst_3 uailst[3] = {
1680         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1681         { sizeof salt, UAI$_SALT,    &salt, 0},
1682         { 0,           0,            NULL,  NULL}};
1683     static char hash[9];
1684
1685     usrdsc.dsc$w_length = strlen(usrname);
1686     usrdsc.dsc$a_pointer = usrname;
1687     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1688       switch (sts) {
1689         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1690           set_errno(EACCES);
1691           break;
1692         case RMS$_RNF:
1693           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1694           break;
1695         default:
1696           set_errno(EVMSERR);
1697       }
1698       set_vaxc_errno(sts);
1699       if (sts != RMS$_RNF) return NULL;
1700     }
1701
1702     txtdsc.dsc$w_length = strlen(textpasswd);
1703     txtdsc.dsc$a_pointer = textpasswd;
1704     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1705       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1706     }
1707
1708     return (char *) hash;
1709
1710 }  /* end of my_crypt() */
1711 /*}}}*/
1712
1713
1714 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1715 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1716 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1717
1718 /* fixup barenames that are directories for internal use.
1719  * There have been problems with the consistent handling of UNIX
1720  * style directory names when routines are presented with a name that
1721  * has no directory delimitors at all.  So this routine will eventually
1722  * fix the issue.
1723  */
1724 static char * fixup_bare_dirnames(const char * name)
1725 {
1726   if (decc_disable_to_vms_logname_translation) {
1727 /* fix me */
1728   }
1729   return NULL;
1730 }
1731
1732 /* mp_do_kill_file
1733  * A little hack to get around a bug in some implemenation of remove()
1734  * that do not know how to delete a directory
1735  *
1736  * Delete any file to which user has control access, regardless of whether
1737  * delete access is explicitly allowed.
1738  * Limitations: User must have write access to parent directory.
1739  *              Does not block signals or ASTs; if interrupted in midstream
1740  *              may leave file with an altered ACL.
1741  * HANDLE WITH CARE!
1742  */
1743 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1744 static int
1745 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1746 {
1747     char *vmsname, *rspec;
1748     char *remove_name;
1749     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1750     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1751     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1752     struct myacedef {
1753       unsigned char myace$b_length;
1754       unsigned char myace$b_type;
1755       unsigned short int myace$w_flags;
1756       unsigned long int myace$l_access;
1757       unsigned long int myace$l_ident;
1758     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1759                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1760       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1761      struct itmlst_3
1762        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1763                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1764        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1765        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1766        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1767        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1768
1769     /* Expand the input spec using RMS, since the CRTL remove() and
1770      * system services won't do this by themselves, so we may miss
1771      * a file "hiding" behind a logical name or search list. */
1772     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1773     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1774
1775     if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1776       PerlMem_free(vmsname);
1777       return -1;
1778     }
1779
1780     if (decc_posix_compliant_pathnames) {
1781       /* In POSIX mode, we prefer to remove the UNIX name */
1782       rspec = vmsname;
1783       remove_name = (char *)name;
1784     }
1785     else {
1786       rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1787       if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1788       if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1789         PerlMem_free(rspec);
1790         PerlMem_free(vmsname);
1791         return -1;
1792       }
1793       PerlMem_free(vmsname);
1794       remove_name = rspec;
1795     }
1796
1797 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1798     if (dirflag != 0) {
1799         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1800           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1801           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1802
1803           do_pathify_dirspec(name, remove_name, 0, NULL);
1804           if (!rmdir(remove_name)) {
1805
1806             PerlMem_free(remove_name);
1807             PerlMem_free(rspec);
1808             return 0;   /* Can we just get rid of it? */
1809           }
1810         }
1811         else {
1812           if (!rmdir(remove_name)) {
1813             PerlMem_free(rspec);
1814             return 0;   /* Can we just get rid of it? */
1815           }
1816         }
1817     }
1818     else
1819 #endif
1820       if (!remove(remove_name)) {
1821         PerlMem_free(rspec);
1822         return 0;   /* Can we just get rid of it? */
1823       }
1824
1825     /* If not, can changing protections help? */
1826     if (vaxc$errno != RMS$_PRV) {
1827       PerlMem_free(rspec);
1828       return -1;
1829     }
1830
1831     /* No, so we get our own UIC to use as a rights identifier,
1832      * and the insert an ACE at the head of the ACL which allows us
1833      * to delete the file.
1834      */
1835     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1836     fildsc.dsc$w_length = strlen(rspec);
1837     fildsc.dsc$a_pointer = rspec;
1838     cxt = 0;
1839     newace.myace$l_ident = oldace.myace$l_ident;
1840     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1841       switch (aclsts) {
1842         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1843           set_errno(ENOENT); break;
1844         case RMS$_DIR:
1845           set_errno(ENOTDIR); break;
1846         case RMS$_DEV:
1847           set_errno(ENODEV); break;
1848         case RMS$_SYN: case SS$_INVFILFOROP:
1849           set_errno(EINVAL); break;
1850         case RMS$_PRV:
1851           set_errno(EACCES); break;
1852         default:
1853           _ckvmssts(aclsts);
1854       }
1855       set_vaxc_errno(aclsts);
1856       PerlMem_free(rspec);
1857       return -1;
1858     }
1859     /* Grab any existing ACEs with this identifier in case we fail */
1860     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1861     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1862                     || fndsts == SS$_NOMOREACE ) {
1863       /* Add the new ACE . . . */
1864       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1865         goto yourroom;
1866
1867 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1868       if (dirflag != 0)
1869         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1870           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1871           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1872
1873           do_pathify_dirspec(name, remove_name, 0, NULL);
1874           rmsts = rmdir(remove_name);
1875           PerlMem_free(remove_name);
1876         }
1877         else {
1878         rmsts = rmdir(remove_name);
1879         }
1880       else
1881 #endif
1882         rmsts = remove(remove_name);
1883       if (rmsts) {
1884         /* We blew it - dir with files in it, no write priv for
1885          * parent directory, etc.  Put things back the way they were. */
1886         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1887           goto yourroom;
1888         if (fndsts & 1) {
1889           addlst[0].bufadr = &oldace;
1890           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1891             goto yourroom;
1892         }
1893       }
1894     }
1895
1896     yourroom:
1897     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1898     /* We just deleted it, so of course it's not there.  Some versions of
1899      * VMS seem to return success on the unlock operation anyhow (after all
1900      * the unlock is successful), but others don't.
1901      */
1902     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1903     if (aclsts & 1) aclsts = fndsts;
1904     if (!(aclsts & 1)) {
1905       set_errno(EVMSERR);
1906       set_vaxc_errno(aclsts);
1907       PerlMem_free(rspec);
1908       return -1;
1909     }
1910
1911     PerlMem_free(rspec);
1912     return rmsts;
1913
1914 }  /* end of kill_file() */
1915 /*}}}*/
1916
1917
1918 /*{{{int do_rmdir(char *name)*/
1919 int
1920 Perl_do_rmdir(pTHX_ const char *name)
1921 {
1922     char dirfile[NAM$C_MAXRSS+1];
1923     int retval;
1924     Stat_t st;
1925
1926     if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1927     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1928     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1929     return retval;
1930
1931 }  /* end of do_rmdir */
1932 /*}}}*/
1933
1934 /* kill_file
1935  * Delete any file to which user has control access, regardless of whether
1936  * delete access is explicitly allowed.
1937  * Limitations: User must have write access to parent directory.
1938  *              Does not block signals or ASTs; if interrupted in midstream
1939  *              may leave file with an altered ACL.
1940  * HANDLE WITH CARE!
1941  */
1942 /*{{{int kill_file(char *name)*/
1943 int
1944 Perl_kill_file(pTHX_ const char *name)
1945 {
1946     char rspec[NAM$C_MAXRSS+1];
1947     char *tspec;
1948     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1949     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1950     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1951     struct myacedef {
1952       unsigned char myace$b_length;
1953       unsigned char myace$b_type;
1954       unsigned short int myace$w_flags;
1955       unsigned long int myace$l_access;
1956       unsigned long int myace$l_ident;
1957     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1958                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1959       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1960      struct itmlst_3
1961        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1962                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1963        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1964        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1965        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1966        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1967
1968     /* Expand the input spec using RMS, since the CRTL remove() and
1969      * system services won't do this by themselves, so we may miss
1970      * a file "hiding" behind a logical name or search list. */
1971     tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1972     if (tspec == NULL) return -1;
1973     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1974     /* If not, can changing protections help? */
1975     if (vaxc$errno != RMS$_PRV) return -1;
1976
1977     /* No, so we get our own UIC to use as a rights identifier,
1978      * and the insert an ACE at the head of the ACL which allows us
1979      * to delete the file.
1980      */
1981     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1982     fildsc.dsc$w_length = strlen(rspec);
1983     fildsc.dsc$a_pointer = rspec;
1984     cxt = 0;
1985     newace.myace$l_ident = oldace.myace$l_ident;
1986     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1987       switch (aclsts) {
1988         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1989           set_errno(ENOENT); break;
1990         case RMS$_DIR:
1991           set_errno(ENOTDIR); break;
1992         case RMS$_DEV:
1993           set_errno(ENODEV); break;
1994         case RMS$_SYN: case SS$_INVFILFOROP:
1995           set_errno(EINVAL); break;
1996         case RMS$_PRV:
1997           set_errno(EACCES); break;
1998         default:
1999           _ckvmssts(aclsts);
2000       }
2001       set_vaxc_errno(aclsts);
2002       return -1;
2003     }
2004     /* Grab any existing ACEs with this identifier in case we fail */
2005     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2006     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2007                     || fndsts == SS$_NOMOREACE ) {
2008       /* Add the new ACE . . . */
2009       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2010         goto yourroom;
2011       if ((rmsts = remove(name))) {
2012         /* We blew it - dir with files in it, no write priv for
2013          * parent directory, etc.  Put things back the way they were. */
2014         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2015           goto yourroom;
2016         if (fndsts & 1) {
2017           addlst[0].bufadr = &oldace;
2018           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2019             goto yourroom;
2020         }
2021       }
2022     }
2023
2024     yourroom:
2025     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2026     /* We just deleted it, so of course it's not there.  Some versions of
2027      * VMS seem to return success on the unlock operation anyhow (after all
2028      * the unlock is successful), but others don't.
2029      */
2030     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2031     if (aclsts & 1) aclsts = fndsts;
2032     if (!(aclsts & 1)) {
2033       set_errno(EVMSERR);
2034       set_vaxc_errno(aclsts);
2035       return -1;
2036     }
2037
2038     return rmsts;
2039
2040 }  /* end of kill_file() */
2041 /*}}}*/
2042
2043
2044 /*{{{int my_mkdir(char *,Mode_t)*/
2045 int
2046 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2047 {
2048   STRLEN dirlen = strlen(dir);
2049
2050   /* zero length string sometimes gives ACCVIO */
2051   if (dirlen == 0) return -1;
2052
2053   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2054    * null file name/type.  However, it's commonplace under Unix,
2055    * so we'll allow it for a gain in portability.
2056    */
2057   if (dir[dirlen-1] == '/') {
2058     char *newdir = savepvn(dir,dirlen-1);
2059     int ret = mkdir(newdir,mode);
2060     Safefree(newdir);
2061     return ret;
2062   }
2063   else return mkdir(dir,mode);
2064 }  /* end of my_mkdir */
2065 /*}}}*/
2066
2067 /*{{{int my_chdir(char *)*/
2068 int
2069 Perl_my_chdir(pTHX_ const char *dir)
2070 {
2071   STRLEN dirlen = strlen(dir);
2072
2073   /* zero length string sometimes gives ACCVIO */
2074   if (dirlen == 0) return -1;
2075   const char *dir1;
2076
2077   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2078    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2079    * so that existing scripts do not need to be changed.
2080    */
2081   dir1 = dir;
2082   while ((dirlen > 0) && (*dir1 == ' ')) {
2083     dir1++;
2084     dirlen--;
2085   }
2086
2087   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2088    * that implies
2089    * null file name/type.  However, it's commonplace under Unix,
2090    * so we'll allow it for a gain in portability.
2091    *
2092    * - Preview- '/' will be valid soon on VMS
2093    */
2094   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2095     char *newdir = savepvn(dir1,dirlen-1);
2096     int ret = chdir(newdir);
2097     Safefree(newdir);
2098     return ret;
2099   }
2100   else return chdir(dir1);
2101 }  /* end of my_chdir */
2102 /*}}}*/
2103
2104
2105 /*{{{FILE *my_tmpfile()*/
2106 FILE *
2107 my_tmpfile(void)
2108 {
2109   FILE *fp;
2110   char *cp;
2111
2112   if ((fp = tmpfile())) return fp;
2113
2114   cp = PerlMem_malloc(L_tmpnam+24);
2115   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2116
2117   if (decc_filename_unix_only == 0)
2118     strcpy(cp,"Sys$Scratch:");
2119   else
2120     strcpy(cp,"/tmp/");
2121   tmpnam(cp+strlen(cp));
2122   strcat(cp,".Perltmp");
2123   fp = fopen(cp,"w+","fop=dlt");
2124   PerlMem_free(cp);
2125   return fp;
2126 }
2127 /*}}}*/
2128
2129
2130 #ifndef HOMEGROWN_POSIX_SIGNALS
2131 /*
2132  * The C RTL's sigaction fails to check for invalid signal numbers so we
2133  * help it out a bit.  The docs are correct, but the actual routine doesn't
2134  * do what the docs say it will.
2135  */
2136 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2137 int
2138 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2139                    struct sigaction* oact)
2140 {
2141   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2142         SETERRNO(EINVAL, SS$_INVARG);
2143         return -1;
2144   }
2145   return sigaction(sig, act, oact);
2146 }
2147 /*}}}*/
2148 #endif
2149
2150 #ifdef KILL_BY_SIGPRC
2151 #include <errnodef.h>
2152
2153 /* We implement our own kill() using the undocumented system service
2154    sys$sigprc for one of two reasons:
2155
2156    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2157    target process to do a sys$exit, which usually can't be handled
2158    gracefully...certainly not by Perl and the %SIG{} mechanism.
2159
2160    2.) If the kill() in the CRTL can't be called from a signal
2161    handler without disappearing into the ether, i.e., the signal
2162    it purportedly sends is never trapped. Still true as of VMS 7.3.
2163
2164    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2165    in the target process rather than calling sys$exit.
2166
2167    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2168    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2169    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2170    with condition codes C$_SIG0+nsig*8, catching the exception on the
2171    target process and resignaling with appropriate arguments.
2172
2173    But we don't have that VMS 7.0+ exception handler, so if you
2174    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2175
2176    Also note that SIGTERM is listed in the docs as being "unimplemented",
2177    yet always seems to be signaled with a VMS condition code of 4 (and
2178    correctly handled for that code).  So we hardwire it in.
2179
2180    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2181    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2182    than signalling with an unrecognized (and unhandled by CRTL) code.
2183 */
2184
2185 #define _MY_SIG_MAX 28
2186
2187 static unsigned int
2188 Perl_sig_to_vmscondition_int(int sig)
2189 {
2190     static unsigned int sig_code[_MY_SIG_MAX+1] =
2191     {
2192         0,                  /*  0 ZERO     */
2193         SS$_HANGUP,         /*  1 SIGHUP   */
2194         SS$_CONTROLC,       /*  2 SIGINT   */
2195         SS$_CONTROLY,       /*  3 SIGQUIT  */
2196         SS$_RADRMOD,        /*  4 SIGILL   */
2197         SS$_BREAK,          /*  5 SIGTRAP  */
2198         SS$_OPCCUS,         /*  6 SIGABRT  */
2199         SS$_COMPAT,         /*  7 SIGEMT   */
2200 #ifdef __VAX
2201         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2202 #else
2203         SS$_HPARITH,        /*  8 SIGFPE AXP */
2204 #endif
2205         SS$_ABORT,          /*  9 SIGKILL  */
2206         SS$_ACCVIO,         /* 10 SIGBUS   */
2207         SS$_ACCVIO,         /* 11 SIGSEGV  */
2208         SS$_BADPARAM,       /* 12 SIGSYS   */
2209         SS$_NOMBX,          /* 13 SIGPIPE  */
2210         SS$_ASTFLT,         /* 14 SIGALRM  */
2211         4,                  /* 15 SIGTERM  */
2212         0,                  /* 16 SIGUSR1  */
2213         0,                  /* 17 SIGUSR2  */
2214         0,                  /* 18 */
2215         0,                  /* 19 */
2216         0,                  /* 20 SIGCHLD  */
2217         0,                  /* 21 SIGCONT  */
2218         0,                  /* 22 SIGSTOP  */
2219         0,                  /* 23 SIGTSTP  */
2220         0,                  /* 24 SIGTTIN  */
2221         0,                  /* 25 SIGTTOU  */
2222         0,                  /* 26 */
2223         0,                  /* 27 */
2224         0                   /* 28 SIGWINCH  */
2225     };
2226
2227 #if __VMS_VER >= 60200000
2228     static int initted = 0;
2229     if (!initted) {
2230         initted = 1;
2231         sig_code[16] = C$_SIGUSR1;
2232         sig_code[17] = C$_SIGUSR2;
2233 #if __CRTL_VER >= 70000000
2234         sig_code[20] = C$_SIGCHLD;
2235 #endif
2236 #if __CRTL_VER >= 70300000
2237         sig_code[28] = C$_SIGWINCH;
2238 #endif
2239     }
2240 #endif
2241
2242     if (sig < _SIG_MIN) return 0;
2243     if (sig > _MY_SIG_MAX) return 0;
2244     return sig_code[sig];
2245 }
2246
2247 unsigned int
2248 Perl_sig_to_vmscondition(int sig)
2249 {
2250 #ifdef SS$_DEBUG
2251     if (vms_debug_on_exception != 0)
2252         lib$signal(SS$_DEBUG);
2253 #endif
2254     return Perl_sig_to_vmscondition_int(sig);
2255 }
2256
2257
2258 int
2259 Perl_my_kill(int pid, int sig)
2260 {
2261     dTHX;
2262     int iss;
2263     unsigned int code;
2264     int sys$sigprc(unsigned int *pidadr,
2265                      struct dsc$descriptor_s *prcname,
2266                      unsigned int code);
2267
2268      /* sig 0 means validate the PID */
2269     /*------------------------------*/
2270     if (sig == 0) {
2271         const unsigned long int jpicode = JPI$_PID;
2272         pid_t ret_pid;
2273         int status;
2274         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2275         if ($VMS_STATUS_SUCCESS(status))
2276            return 0;
2277         switch (status) {
2278         case SS$_NOSUCHNODE:
2279         case SS$_UNREACHABLE:
2280         case SS$_NONEXPR:
2281            errno = ESRCH;
2282            break;
2283         case SS$_NOPRIV:
2284            errno = EPERM;
2285            break;
2286         default:
2287            errno = EVMSERR;
2288         }
2289         vaxc$errno=status;
2290         return -1;
2291     }
2292
2293     code = Perl_sig_to_vmscondition_int(sig);
2294
2295     if (!code) {
2296         SETERRNO(EINVAL, SS$_BADPARAM);
2297         return -1;
2298     }
2299
2300     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2301      * signals are to be sent to multiple processes.
2302      *  pid = 0 - all processes in group except ones that the system exempts
2303      *  pid = -1 - all processes except ones that the system exempts
2304      *  pid = -n - all processes in group (abs(n)) except ...
2305      * For now, just report as not supported.
2306      */
2307
2308     if (pid <= 0) {
2309         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2310         return -1;
2311     }
2312
2313     iss = sys$sigprc((unsigned int *)&pid,0,code);
2314     if (iss&1) return 0;
2315
2316     switch (iss) {
2317       case SS$_NOPRIV:
2318         set_errno(EPERM);  break;
2319       case SS$_NONEXPR:
2320       case SS$_NOSUCHNODE:
2321       case SS$_UNREACHABLE:
2322         set_errno(ESRCH);  break;
2323       case SS$_INSFMEM:
2324         set_errno(ENOMEM); break;
2325       default:
2326         _ckvmssts(iss);
2327         set_errno(EVMSERR);
2328     }
2329     set_vaxc_errno(iss);
2330
2331     return -1;
2332 }
2333 #endif
2334
2335 /* Routine to convert a VMS status code to a UNIX status code.
2336 ** More tricky than it appears because of conflicting conventions with
2337 ** existing code.
2338 **
2339 ** VMS status codes are a bit mask, with the least significant bit set for
2340 ** success.
2341 **
2342 ** Special UNIX status of EVMSERR indicates that no translation is currently
2343 ** available, and programs should check the VMS status code.
2344 **
2345 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2346 ** decoding.
2347 */
2348
2349 #ifndef C_FACILITY_NO
2350 #define C_FACILITY_NO 0x350000
2351 #endif
2352 #ifndef DCL_IVVERB
2353 #define DCL_IVVERB 0x38090
2354 #endif
2355
2356 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2357 {
2358 int facility;
2359 int fac_sp;
2360 int msg_no;
2361 int msg_status;
2362 int unix_status;
2363
2364   /* Assume the best or the worst */
2365   if (vms_status & STS$M_SUCCESS)
2366     unix_status = 0;
2367   else
2368     unix_status = EVMSERR;
2369
2370   msg_status = vms_status & ~STS$M_CONTROL;
2371
2372   facility = vms_status & STS$M_FAC_NO;
2373   fac_sp = vms_status & STS$M_FAC_SP;
2374   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2375
2376   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2377     switch(msg_no) {
2378     case SS$_NORMAL:
2379         unix_status = 0;
2380         break;
2381     case SS$_ACCVIO:
2382         unix_status = EFAULT;
2383         break;
2384     case SS$_DEVOFFLINE:
2385         unix_status = EBUSY;
2386         break;
2387     case SS$_CLEARED:
2388         unix_status = ENOTCONN;
2389         break;
2390     case SS$_IVCHAN:
2391     case SS$_IVLOGNAM:
2392     case SS$_BADPARAM:
2393     case SS$_IVLOGTAB:
2394     case SS$_NOLOGNAM:
2395     case SS$_NOLOGTAB:
2396     case SS$_INVFILFOROP:
2397     case SS$_INVARG:
2398     case SS$_NOSUCHID:
2399     case SS$_IVIDENT:
2400         unix_status = EINVAL;
2401         break;
2402     case SS$_UNSUPPORTED:
2403         unix_status = ENOTSUP;
2404         break;
2405     case SS$_FILACCERR:
2406     case SS$_NOGRPPRV:
2407     case SS$_NOSYSPRV:
2408         unix_status = EACCES;
2409         break;
2410     case SS$_DEVICEFULL:
2411         unix_status = ENOSPC;
2412         break;
2413     case SS$_NOSUCHDEV:
2414         unix_status = ENODEV;
2415         break;
2416     case SS$_NOSUCHFILE:
2417     case SS$_NOSUCHOBJECT:
2418         unix_status = ENOENT;
2419         break;
2420     case SS$_ABORT:                                 /* Fatal case */
2421     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2422     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2423         unix_status = EINTR;
2424         break;
2425     case SS$_BUFFEROVF:
2426         unix_status = E2BIG;
2427         break;
2428     case SS$_INSFMEM:
2429         unix_status = ENOMEM;
2430         break;
2431     case SS$_NOPRIV:
2432         unix_status = EPERM;
2433         break;
2434     case SS$_NOSUCHNODE:
2435     case SS$_UNREACHABLE:
2436         unix_status = ESRCH;
2437         break;
2438     case SS$_NONEXPR:
2439         unix_status = ECHILD;
2440         break;
2441     default:
2442         if ((facility == 0) && (msg_no < 8)) {
2443           /* These are not real VMS status codes so assume that they are
2444           ** already UNIX status codes
2445           */
2446           unix_status = msg_no;
2447           break;
2448         }
2449     }
2450   }
2451   else {
2452     /* Translate a POSIX exit code to a UNIX exit code */
2453     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2454         unix_status = (msg_no & 0x07F8) >> 3;
2455     }
2456     else {
2457
2458          /* Documented traditional behavior for handling VMS child exits */
2459         /*--------------------------------------------------------------*/
2460         if (child_flag != 0) {
2461
2462              /* Success / Informational return 0 */
2463             /*----------------------------------*/
2464             if (msg_no & STS$K_SUCCESS)
2465                 return 0;
2466
2467              /* Warning returns 1 */
2468             /*-------------------*/
2469             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2470                 return 1;
2471
2472              /* Everything else pass through the severity bits */
2473             /*------------------------------------------------*/
2474             return (msg_no & STS$M_SEVERITY);
2475         }
2476
2477          /* Normal VMS status to ERRNO mapping attempt */
2478         /*--------------------------------------------*/
2479         switch(msg_status) {
2480         /* case RMS$_EOF: */ /* End of File */
2481         case RMS$_FNF:  /* File Not Found */
2482         case RMS$_DNF:  /* Dir Not Found */
2483                 unix_status = ENOENT;
2484                 break;
2485         case RMS$_RNF:  /* Record Not Found */
2486                 unix_status = ESRCH;
2487                 break;
2488         case RMS$_DIR:
2489                 unix_status = ENOTDIR;
2490                 break;
2491         case RMS$_DEV:
2492                 unix_status = ENODEV;
2493                 break;
2494         case RMS$_IFI:
2495         case RMS$_FAC:
2496         case RMS$_ISI:
2497                 unix_status = EBADF;
2498                 break;
2499         case RMS$_FEX:
2500                 unix_status = EEXIST;
2501                 break;
2502         case RMS$_SYN:
2503         case RMS$_FNM:
2504         case LIB$_INVSTRDES:
2505         case LIB$_INVARG:
2506         case LIB$_NOSUCHSYM:
2507         case LIB$_INVSYMNAM:
2508         case DCL_IVVERB:
2509                 unix_status = EINVAL;
2510                 break;
2511         case CLI$_BUFOVF:
2512         case RMS$_RTB:
2513         case CLI$_TKNOVF:
2514         case CLI$_RSLOVF:
2515                 unix_status = E2BIG;
2516                 break;
2517         case RMS$_PRV:  /* No privilege */
2518         case RMS$_ACC:  /* ACP file access failed */
2519         case RMS$_WLK:  /* Device write locked */
2520                 unix_status = EACCES;
2521                 break;
2522         /* case RMS$_NMF: */  /* No more files */
2523         }
2524     }
2525   }
2526
2527   return unix_status;
2528 }
2529
2530 /* Try to guess at what VMS error status should go with a UNIX errno
2531  * value.  This is hard to do as there could be many possible VMS
2532  * error statuses that caused the errno value to be set.
2533  */
2534
2535 int Perl_unix_status_to_vms(int unix_status)
2536 {
2537 int test_unix_status;
2538
2539      /* Trivial cases first */
2540     /*---------------------*/
2541     if (unix_status == EVMSERR)
2542         return vaxc$errno;
2543
2544      /* Is vaxc$errno sane? */
2545     /*---------------------*/
2546     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2547     if (test_unix_status == unix_status)
2548         return vaxc$errno;
2549
2550      /* If way out of range, must be VMS code already */
2551     /*-----------------------------------------------*/
2552     if (unix_status > EVMSERR)
2553         return unix_status;
2554
2555      /* If out of range, punt */
2556     /*-----------------------*/
2557     if (unix_status > __ERRNO_MAX)
2558         return SS$_ABORT;
2559
2560
2561      /* Ok, now we have to do it the hard way. */
2562     /*----------------------------------------*/
2563     switch(unix_status) {
2564     case 0:     return SS$_NORMAL;
2565     case EPERM: return SS$_NOPRIV;
2566     case ENOENT: return SS$_NOSUCHOBJECT;
2567     case ESRCH: return SS$_UNREACHABLE;
2568     case EINTR: return SS$_ABORT;
2569     /* case EIO: */
2570     /* case ENXIO:  */
2571     case E2BIG: return SS$_BUFFEROVF;
2572     /* case ENOEXEC */
2573     case EBADF: return RMS$_IFI;
2574     case ECHILD: return SS$_NONEXPR;
2575     /* case EAGAIN */
2576     case ENOMEM: return SS$_INSFMEM;
2577     case EACCES: return SS$_FILACCERR;
2578     case EFAULT: return SS$_ACCVIO;
2579     /* case ENOTBLK */
2580     case EBUSY: return SS$_DEVOFFLINE;
2581     case EEXIST: return RMS$_FEX;
2582     /* case EXDEV */
2583     case ENODEV: return SS$_NOSUCHDEV;
2584     case ENOTDIR: return RMS$_DIR;
2585     /* case EISDIR */
2586     case EINVAL: return SS$_INVARG;
2587     /* case ENFILE */
2588     /* case EMFILE */
2589     /* case ENOTTY */
2590     /* case ETXTBSY */
2591     /* case EFBIG */
2592     case ENOSPC: return SS$_DEVICEFULL;
2593     case ESPIPE: return LIB$_INVARG;
2594     /* case EROFS: */
2595     /* case EMLINK: */
2596     /* case EPIPE: */
2597     /* case EDOM */
2598     case ERANGE: return LIB$_INVARG;
2599     /* case EWOULDBLOCK */
2600     /* case EINPROGRESS */
2601     /* case EALREADY */
2602     /* case ENOTSOCK */
2603     /* case EDESTADDRREQ */
2604     /* case EMSGSIZE */
2605     /* case EPROTOTYPE */
2606     /* case ENOPROTOOPT */
2607     /* case EPROTONOSUPPORT */
2608     /* case ESOCKTNOSUPPORT */
2609     /* case EOPNOTSUPP */
2610     /* case EPFNOSUPPORT */
2611     /* case EAFNOSUPPORT */
2612     /* case EADDRINUSE */
2613     /* case EADDRNOTAVAIL */
2614     /* case ENETDOWN */
2615     /* case ENETUNREACH */
2616     /* case ENETRESET */
2617     /* case ECONNABORTED */
2618     /* case ECONNRESET */
2619     /* case ENOBUFS */
2620     /* case EISCONN */
2621     case ENOTCONN: return SS$_CLEARED;
2622     /* case ESHUTDOWN */
2623     /* case ETOOMANYREFS */
2624     /* case ETIMEDOUT */
2625     /* case ECONNREFUSED */
2626     /* case ELOOP */
2627     /* case ENAMETOOLONG */
2628     /* case EHOSTDOWN */
2629     /* case EHOSTUNREACH */
2630     /* case ENOTEMPTY */
2631     /* case EPROCLIM */
2632     /* case EUSERS  */
2633     /* case EDQUOT  */
2634     /* case ENOMSG  */
2635     /* case EIDRM */
2636     /* case EALIGN */
2637     /* case ESTALE */
2638     /* case EREMOTE */
2639     /* case ENOLCK */
2640     /* case ENOSYS */
2641     /* case EFTYPE */
2642     /* case ECANCELED */
2643     /* case EFAIL */
2644     /* case EINPROG */
2645     case ENOTSUP:
2646         return SS$_UNSUPPORTED;
2647     /* case EDEADLK */
2648     /* case ENWAIT */
2649     /* case EILSEQ */
2650     /* case EBADCAT */
2651     /* case EBADMSG */
2652     /* case EABANDONED */
2653     default:
2654         return SS$_ABORT; /* punt */
2655     }
2656
2657   return SS$_ABORT; /* Should not get here */
2658 }
2659
2660
2661 /* default piping mailbox size */
2662 #define PERL_BUFSIZ        512
2663
2664
2665 static void
2666 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2667 {
2668   unsigned long int mbxbufsiz;
2669   static unsigned long int syssize = 0;
2670   unsigned long int dviitm = DVI$_DEVNAM;
2671   char csize[LNM$C_NAMLENGTH+1];
2672   int sts;
2673
2674   if (!syssize) {
2675     unsigned long syiitm = SYI$_MAXBUF;
2676     /*
2677      * Get the SYSGEN parameter MAXBUF
2678      *
2679      * If the logical 'PERL_MBX_SIZE' is defined
2680      * use the value of the logical instead of PERL_BUFSIZ, but
2681      * keep the size between 128 and MAXBUF.
2682      *
2683      */
2684     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2685   }
2686
2687   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2688       mbxbufsiz = atoi(csize);
2689   } else {
2690       mbxbufsiz = PERL_BUFSIZ;
2691   }
2692   if (mbxbufsiz < 128) mbxbufsiz = 128;
2693   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2694
2695   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2696
2697   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2698   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2699
2700 }  /* end of create_mbx() */
2701
2702
2703 /*{{{  my_popen and my_pclose*/
2704
2705 typedef struct _iosb           IOSB;
2706 typedef struct _iosb*         pIOSB;
2707 typedef struct _pipe           Pipe;
2708 typedef struct _pipe*         pPipe;
2709 typedef struct pipe_details    Info;
2710 typedef struct pipe_details*  pInfo;
2711 typedef struct _srqp            RQE;
2712 typedef struct _srqp*          pRQE;
2713 typedef struct _tochildbuf      CBuf;
2714 typedef struct _tochildbuf*    pCBuf;
2715
2716 struct _iosb {
2717     unsigned short status;
2718     unsigned short count;
2719     unsigned long  dvispec;
2720 };
2721
2722 #pragma member_alignment save
2723 #pragma nomember_alignment quadword
2724 struct _srqp {          /* VMS self-relative queue entry */
2725     unsigned long qptr[2];
2726 };
2727 #pragma member_alignment restore
2728 static RQE  RQE_ZERO = {0,0};
2729
2730 struct _tochildbuf {
2731     RQE             q;
2732     int             eof;
2733     unsigned short  size;
2734     char            *buf;
2735 };
2736
2737 struct _pipe {
2738     RQE            free;
2739     RQE            wait;
2740     int            fd_out;
2741     unsigned short chan_in;
2742     unsigned short chan_out;
2743     char          *buf;
2744     unsigned int   bufsize;
2745     IOSB           iosb;
2746     IOSB           iosb2;
2747     int           *pipe_done;
2748     int            retry;
2749     int            type;
2750     int            shut_on_empty;
2751     int            need_wake;
2752     pPipe         *home;
2753     pInfo          info;
2754     pCBuf          curr;
2755     pCBuf          curr2;
2756 #if defined(PERL_IMPLICIT_CONTEXT)
2757     void            *thx;           /* Either a thread or an interpreter */
2758                                     /* pointer, depending on how we're built */
2759 #endif
2760 };
2761
2762
2763 struct pipe_details
2764 {
2765     pInfo           next;
2766     PerlIO *fp;  /* file pointer to pipe mailbox */
2767     int useFILE; /* using stdio, not perlio */
2768     int pid;   /* PID of subprocess */
2769     int mode;  /* == 'r' if pipe open for reading */
2770     int done;  /* subprocess has completed */
2771     int waiting; /* waiting for completion/closure */
2772     int             closing;        /* my_pclose is closing this pipe */
2773     unsigned long   completion;     /* termination status of subprocess */
2774     pPipe           in;             /* pipe in to sub */
2775     pPipe           out;            /* pipe out of sub */
2776     pPipe           err;            /* pipe of sub's sys$error */
2777     int             in_done;        /* true when in pipe finished */
2778     int             out_done;
2779     int             err_done;
2780     unsigned short  xchan;          /* channel to debug xterm */
2781     unsigned short  xchan_valid;    /* channel is assigned */
2782 };
2783
2784 struct exit_control_block
2785 {
2786     struct exit_control_block *flink;
2787     unsigned long int   (*exit_routine)();
2788     unsigned long int arg_count;
2789     unsigned long int *status_address;
2790     unsigned long int exit_status;
2791 };
2792
2793 typedef struct _closed_pipes    Xpipe;
2794 typedef struct _closed_pipes*  pXpipe;
2795
2796 struct _closed_pipes {
2797     int             pid;            /* PID of subprocess */
2798     unsigned long   completion;     /* termination status of subprocess */
2799 };
2800 #define NKEEPCLOSED 50
2801 static Xpipe closed_list[NKEEPCLOSED];
2802 static int   closed_index = 0;
2803 static int   closed_num = 0;
2804
2805 #define RETRY_DELAY     "0 ::0.20"
2806 #define MAX_RETRY              50
2807
2808 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2809 static unsigned long mypid;
2810 static unsigned long delaytime[2];
2811
2812 static pInfo open_pipes = NULL;
2813 static $DESCRIPTOR(nl_desc, "NL:");
2814
2815 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2816
2817
2818
2819 static unsigned long int
2820 pipe_exit_routine(pTHX)
2821 {
2822     pInfo info;
2823     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2824     int sts, did_stuff, need_eof, j;
2825
2826     /*
2827         flush any pending i/o
2828     */
2829     info = open_pipes;
2830     while (info) {
2831         if (info->fp) {
2832            if (!info->useFILE)
2833                PerlIO_flush(info->fp);   /* first, flush data */
2834            else
2835                fflush((FILE *)info->fp);
2836         }
2837         info = info->next;
2838     }
2839
2840     /*
2841      next we try sending an EOF...ignore if doesn't work, make sure we
2842      don't hang
2843     */
2844     did_stuff = 0;
2845     info = open_pipes;
2846
2847     while (info) {
2848       int need_eof;
2849       _ckvmssts_noperl(sys$setast(0));
2850       if (info->in && !info->in->shut_on_empty) {
2851         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2852                           0, 0, 0, 0, 0, 0));
2853         info->waiting = 1;
2854         did_stuff = 1;
2855       }
2856       _ckvmssts_noperl(sys$setast(1));
2857       info = info->next;
2858     }
2859
2860     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2861
2862     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2863         int nwait = 0;
2864
2865         info = open_pipes;
2866         while (info) {
2867           _ckvmssts_noperl(sys$setast(0));
2868           if (info->waiting && info->done)
2869                 info->waiting = 0;
2870           nwait += info->waiting;
2871           _ckvmssts_noperl(sys$setast(1));
2872           info = info->next;
2873         }
2874         if (!nwait) break;
2875         sleep(1);
2876     }
2877
2878     did_stuff = 0;
2879     info = open_pipes;
2880     while (info) {
2881       _ckvmssts_noperl(sys$setast(0));
2882       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2883         sts = sys$forcex(&info->pid,0,&abort);
2884         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2885         did_stuff = 1;
2886       }
2887       _ckvmssts_noperl(sys$setast(1));
2888       info = info->next;
2889     }
2890
2891     /* again, wait for effect */
2892
2893     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2894         int nwait = 0;
2895
2896         info = open_pipes;
2897         while (info) {
2898           _ckvmssts_noperl(sys$setast(0));
2899           if (info->waiting && info->done)
2900                 info->waiting = 0;
2901           nwait += info->waiting;
2902           _ckvmssts_noperl(sys$setast(1));
2903           info = info->next;
2904         }
2905         if (!nwait) break;
2906         sleep(1);
2907     }
2908
2909     info = open_pipes;
2910     while (info) {
2911       _ckvmssts_noperl(sys$setast(0));
2912       if (!info->done) {  /* We tried to be nice . . . */
2913         sts = sys$delprc(&info->pid,0);
2914         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2915         info->done = 1;  /* sys$delprc is as done as we're going to get. */
2916       }
2917       _ckvmssts_noperl(sys$setast(1));
2918       info = info->next;
2919     }
2920
2921     while(open_pipes) {
2922       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2923       else if (!(sts & 1)) retsts = sts;
2924     }
2925     return retsts;
2926 }
2927
2928 static struct exit_control_block pipe_exitblock =
2929        {(struct exit_control_block *) 0,
2930         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2931
2932 static void pipe_mbxtofd_ast(pPipe p);
2933 static void pipe_tochild1_ast(pPipe p);
2934 static void pipe_tochild2_ast(pPipe p);
2935
2936 static void
2937 popen_completion_ast(pInfo info)
2938 {
2939   pInfo i = open_pipes;
2940   int iss;
2941   int sts;
2942   pXpipe x;
2943
2944   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2945   closed_list[closed_index].pid = info->pid;
2946   closed_list[closed_index].completion = info->completion;
2947   closed_index++;
2948   if (closed_index == NKEEPCLOSED)
2949     closed_index = 0;
2950   closed_num++;
2951
2952   while (i) {
2953     if (i == info) break;
2954     i = i->next;
2955   }
2956   if (!i) return;       /* unlinked, probably freed too */
2957
2958   info->done = TRUE;
2959
2960 /*
2961     Writing to subprocess ...
2962             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2963
2964             chan_out may be waiting for "done" flag, or hung waiting
2965             for i/o completion to child...cancel the i/o.  This will
2966             put it into "snarf mode" (done but no EOF yet) that discards
2967             input.
2968
2969     Output from subprocess (stdout, stderr) needs to be flushed and
2970     shut down.   We try sending an EOF, but if the mbx is full the pipe
2971     routine should still catch the "shut_on_empty" flag, telling it to
2972     use immediate-style reads so that "mbx empty" -> EOF.
2973
2974
2975 */
2976   if (info->in && !info->in_done) {               /* only for mode=w */
2977         if (info->in->shut_on_empty && info->in->need_wake) {
2978             info->in->need_wake = FALSE;
2979             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2980         } else {
2981             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2982         }
2983   }
2984
2985   if (info->out && !info->out_done) {             /* were we also piping output? */
2986       info->out->shut_on_empty = TRUE;
2987       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2988       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2989       _ckvmssts_noperl(iss);
2990   }
2991
2992   if (info->err && !info->err_done) {        /* we were piping stderr */
2993         info->err->shut_on_empty = TRUE;
2994         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2995         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2996         _ckvmssts_noperl(iss);
2997   }
2998   _ckvmssts_noperl(sys$setef(pipe_ef));
2999
3000 }
3001
3002 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3003 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3004
3005 /*
3006     we actually differ from vmstrnenv since we use this to
3007     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3008     are pointing to the same thing
3009 */
3010
3011 static unsigned short
3012 popen_translate(pTHX_ char *logical, char *result)
3013 {
3014     int iss;
3015     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3016     $DESCRIPTOR(d_log,"");
3017     struct _il3 {
3018         unsigned short length;
3019         unsigned short code;
3020         char *         buffer_addr;
3021         unsigned short *retlenaddr;
3022     } itmlst[2];
3023     unsigned short l, ifi;
3024
3025     d_log.dsc$a_pointer = logical;
3026     d_log.dsc$w_length  = strlen(logical);
3027
3028     itmlst[0].code = LNM$_STRING;
3029     itmlst[0].length = 255;
3030     itmlst[0].buffer_addr = result;
3031     itmlst[0].retlenaddr = &l;
3032
3033     itmlst[1].code = 0;
3034     itmlst[1].length = 0;
3035     itmlst[1].buffer_addr = 0;
3036     itmlst[1].retlenaddr = 0;
3037
3038     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3039     if (iss == SS$_NOLOGNAM) {
3040         iss = SS$_NORMAL;
3041         l = 0;
3042     }
3043     if (!(iss&1)) lib$signal(iss);
3044     result[l] = '\0';
3045 /*
3046     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3047     strip it off and return the ifi, if any
3048 */
3049     ifi  = 0;
3050     if (result[0] == 0x1b && result[1] == 0x00) {
3051         memmove(&ifi,result+2,2);
3052         strcpy(result,result+4);
3053     }
3054     return ifi;     /* this is the RMS internal file id */
3055 }
3056
3057 static void pipe_infromchild_ast(pPipe p);
3058
3059 /*
3060     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3061     inside an AST routine without worrying about reentrancy and which Perl
3062     memory allocator is being used.
3063
3064     We read data and queue up the buffers, then spit them out one at a
3065     time to the output mailbox when the output mailbox is ready for one.
3066
3067 */
3068 #define INITIAL_TOCHILDQUEUE  2
3069
3070 static pPipe
3071 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3072 {
3073     pPipe p;
3074     pCBuf b;
3075     char mbx1[64], mbx2[64];
3076     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3077                                       DSC$K_CLASS_S, mbx1},
3078                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3079                                       DSC$K_CLASS_S, mbx2};
3080     unsigned int dviitm = DVI$_DEVBUFSIZ;
3081     int j, n;
3082
3083     n = sizeof(Pipe);
3084     _ckvmssts(lib$get_vm(&n, &p));
3085
3086     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3087     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3088     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3089
3090     p->buf           = 0;
3091     p->shut_on_empty = FALSE;
3092     p->need_wake     = FALSE;
3093     p->type          = 0;
3094     p->retry         = 0;
3095     p->iosb.status   = SS$_NORMAL;
3096     p->iosb2.status  = SS$_NORMAL;
3097     p->free          = RQE_ZERO;
3098     p->wait          = RQE_ZERO;
3099     p->curr          = 0;
3100     p->curr2         = 0;
3101     p->info          = 0;
3102 #ifdef PERL_IMPLICIT_CONTEXT
3103     p->thx           = aTHX;
3104 #endif
3105
3106     n = sizeof(CBuf) + p->bufsize;
3107
3108     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3109         _ckvmssts(lib$get_vm(&n, &b));
3110         b->buf = (char *) b + sizeof(CBuf);
3111         _ckvmssts(lib$insqhi(b, &p->free));
3112     }
3113
3114     pipe_tochild2_ast(p);
3115     pipe_tochild1_ast(p);
3116     strcpy(wmbx, mbx1);
3117     strcpy(rmbx, mbx2);
3118     return p;
3119 }
3120
3121 /*  reads the MBX Perl is writing, and queues */
3122
3123 static void
3124 pipe_tochild1_ast(pPipe p)
3125 {
3126     pCBuf b = p->curr;
3127     int iss = p->iosb.status;
3128     int eof = (iss == SS$_ENDOFFILE);
3129     int sts;
3130 #ifdef PERL_IMPLICIT_CONTEXT
3131     pTHX = p->thx;
3132 #endif
3133
3134     if (p->retry) {
3135         if (eof) {
3136             p->shut_on_empty = TRUE;
3137             b->eof     = TRUE;
3138             _ckvmssts(sys$dassgn(p->chan_in));
3139         } else  {
3140             _ckvmssts(iss);
3141         }
3142
3143         b->eof  = eof;
3144         b->size = p->iosb.count;
3145         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3146         if (p->need_wake) {
3147             p->need_wake = FALSE;
3148             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3149         }
3150     } else {
3151         p->retry = 1;   /* initial call */
3152     }
3153
3154     if (eof) {                  /* flush the free queue, return when done */
3155         int n = sizeof(CBuf) + p->bufsize;
3156         while (1) {
3157             iss = lib$remqti(&p->free, &b);
3158             if (iss == LIB$_QUEWASEMP) return;
3159             _ckvmssts(iss);
3160             _ckvmssts(lib$free_vm(&n, &b));
3161         }
3162     }
3163
3164     iss = lib$remqti(&p->free, &b);
3165     if (iss == LIB$_QUEWASEMP) {
3166         int n = sizeof(CBuf) + p->bufsize;
3167         _ckvmssts(lib$get_vm(&n, &b));
3168         b->buf = (char *) b + sizeof(CBuf);
3169     } else {
3170        _ckvmssts(iss);
3171     }
3172
3173     p->curr = b;
3174     iss = sys$qio(0,p->chan_in,
3175              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3176              &p->iosb,
3177              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3178     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3179     _ckvmssts(iss);
3180 }
3181
3182
3183 /* writes queued buffers to output, waits for each to complete before
3184    doing the next */
3185
3186 static void
3187 pipe_tochild2_ast(pPipe p)
3188 {
3189     pCBuf b = p->curr2;
3190     int iss = p->iosb2.status;
3191     int n = sizeof(CBuf) + p->bufsize;
3192     int done = (p->info && p->info->done) ||
3193               iss == SS$_CANCEL || iss == SS$_ABORT;
3194 #if defined(PERL_IMPLICIT_CONTEXT)
3195     pTHX = p->thx;
3196 #endif
3197
3198     do {
3199         if (p->type) {         /* type=1 has old buffer, dispose */
3200             if (p->shut_on_empty) {
3201                 _ckvmssts(lib$free_vm(&n, &b));
3202             } else {
3203                 _ckvmssts(lib$insqhi(b, &p->free));
3204             }
3205             p->type = 0;
3206         }
3207
3208         iss = lib$remqti(&p->wait, &b);
3209         if (iss == LIB$_QUEWASEMP) {
3210             if (p->shut_on_empty) {
3211                 if (done) {
3212                     _ckvmssts(sys$dassgn(p->chan_out));
3213                     *p->pipe_done = TRUE;
3214                     _ckvmssts(sys$setef(pipe_ef));
3215                 } else {
3216                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3217                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3218                 }
3219                 return;
3220             }
3221             p->need_wake = TRUE;
3222             return;
3223         }
3224         _ckvmssts(iss);
3225         p->type = 1;
3226     } while (done);
3227
3228
3229     p->curr2 = b;
3230     if (b->eof) {
3231         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3232             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3233     } else {
3234         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3235             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3236     }
3237
3238     return;
3239
3240 }
3241
3242
3243 static pPipe
3244 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3245 {
3246     pPipe p;
3247     char mbx1[64], mbx2[64];
3248     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3249                                       DSC$K_CLASS_S, mbx1},
3250                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3251                                       DSC$K_CLASS_S, mbx2};
3252     unsigned int dviitm = DVI$_DEVBUFSIZ;
3253
3254     int n = sizeof(Pipe);
3255     _ckvmssts(lib$get_vm(&n, &p));
3256     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3257     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3258
3259     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3260     n = p->bufsize * sizeof(char);
3261     _ckvmssts(lib$get_vm(&n, &p->buf));
3262     p->shut_on_empty = FALSE;
3263     p->info   = 0;
3264     p->type   = 0;
3265     p->iosb.status = SS$_NORMAL;
3266 #if defined(PERL_IMPLICIT_CONTEXT)
3267     p->thx = aTHX;
3268 #endif
3269     pipe_infromchild_ast(p);
3270
3271     strcpy(wmbx, mbx1);
3272     strcpy(rmbx, mbx2);
3273     return p;
3274 }
3275
3276 static void
3277 pipe_infromchild_ast(pPipe p)
3278 {
3279     int iss = p->iosb.status;
3280     int eof = (iss == SS$_ENDOFFILE);
3281     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3282     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3283 #if defined(PERL_IMPLICIT_CONTEXT)
3284     pTHX = p->thx;
3285 #endif
3286
3287     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3288         _ckvmssts(sys$dassgn(p->chan_out));
3289         p->chan_out = 0;
3290     }
3291
3292     /* read completed:
3293             input shutdown if EOF from self (done or shut_on_empty)
3294             output shutdown if closing flag set (my_pclose)
3295             send data/eof from child or eof from self
3296             otherwise, re-read (snarf of data from child)
3297     */
3298
3299     if (p->type == 1) {
3300         p->type = 0;
3301         if (myeof && p->chan_in) {                  /* input shutdown */
3302             _ckvmssts(sys$dassgn(p->chan_in));
3303             p->chan_in = 0;
3304         }
3305
3306         if (p->chan_out) {
3307             if (myeof || kideof) {      /* pass EOF to parent */
3308                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3309                               pipe_infromchild_ast, p,
3310                               0, 0, 0, 0, 0, 0));
3311                 return;
3312             } else if (eof) {       /* eat EOF --- fall through to read*/
3313
3314             } else {                /* transmit data */
3315                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3316                               pipe_infromchild_ast,p,
3317                               p->buf, p->iosb.count, 0, 0, 0, 0));
3318                 return;
3319             }
3320         }
3321     }
3322
3323     /*  everything shut? flag as done */
3324
3325     if (!p->chan_in && !p->chan_out) {
3326         *p->pipe_done = TRUE;
3327         _ckvmssts(sys$setef(pipe_ef));
3328         return;
3329     }
3330
3331     /* write completed (or read, if snarfing from child)
3332             if still have input active,
3333                queue read...immediate mode if shut_on_empty so we get EOF if empty
3334             otherwise,
3335                check if Perl reading, generate EOFs as needed
3336     */
3337
3338     if (p->type == 0) {
3339         p->type = 1;
3340         if (p->chan_in) {
3341             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3342                           pipe_infromchild_ast,p,
3343                           p->buf, p->bufsize, 0, 0, 0, 0);
3344             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3345             _ckvmssts(iss);
3346         } else {           /* send EOFs for extra reads */
3347             p->iosb.status = SS$_ENDOFFILE;
3348             p->iosb.dvispec = 0;
3349             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3350                       0, 0, 0,
3351                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3352         }
3353     }
3354 }
3355
3356 static pPipe
3357 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3358 {
3359     pPipe p;
3360     char mbx[64];
3361     unsigned long dviitm = DVI$_DEVBUFSIZ;
3362     struct stat s;
3363     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3364                                       DSC$K_CLASS_S, mbx};
3365     int n = sizeof(Pipe);
3366
3367     /* things like terminals and mbx's don't need this filter */
3368     if (fd && fstat(fd,&s) == 0) {
3369         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3370         char device[65];
3371         unsigned short dev_len;
3372         struct dsc$descriptor_s d_dev;
3373         char * cptr;
3374         struct item_list_3 items[3];
3375         int status;
3376         unsigned short dvi_iosb[4];
3377
3378         cptr = getname(fd, out, 1);
3379         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3380         d_dev.dsc$a_pointer = out;
3381         d_dev.dsc$w_length = strlen(out);
3382         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3383         d_dev.dsc$b_class = DSC$K_CLASS_S;
3384
3385         items[0].len = 4;
3386         items[0].code = DVI$_DEVCHAR;
3387         items[0].bufadr = &devchar;
3388         items[0].retadr = NULL;
3389         items[1].len = 64;
3390         items[1].code = DVI$_FULLDEVNAM;
3391         items[1].bufadr = device;
3392         items[1].retadr = &dev_len;
3393         items[2].len = 0;
3394         items[2].code = 0;
3395
3396         status = sys$getdviw
3397                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3398         _ckvmssts(status);
3399         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3400             device[dev_len] = 0;
3401
3402             if (!(devchar & DEV$M_DIR)) {
3403                 strcpy(out, device);
3404                 return 0;
3405             }
3406         }
3407     }
3408
3409     _ckvmssts(lib$get_vm(&n, &p));
3410     p->fd_out = dup(fd);
3411     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3412     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3413     n = (p->bufsize+1) * sizeof(char);
3414     _ckvmssts(lib$get_vm(&n, &p->buf));
3415     p->shut_on_empty = FALSE;
3416     p->retry = 0;
3417     p->info  = 0;
3418     strcpy(out, mbx);
3419
3420     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3421                   pipe_mbxtofd_ast, p,
3422                   p->buf, p->bufsize, 0, 0, 0, 0));
3423
3424     return p;
3425 }
3426
3427 static void
3428 pipe_mbxtofd_ast(pPipe p)
3429 {
3430     int iss = p->iosb.status;
3431     int done = p->info->done;
3432     int iss2;
3433     int eof = (iss == SS$_ENDOFFILE);
3434     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3435     int err = !(iss&1) && !eof;
3436 #if defined(PERL_IMPLICIT_CONTEXT)
3437     pTHX = p->thx;
3438 #endif
3439
3440     if (done && myeof) {               /* end piping */
3441         close(p->fd_out);
3442         sys$dassgn(p->chan_in);
3443         *p->pipe_done = TRUE;
3444         _ckvmssts(sys$setef(pipe_ef));
3445         return;
3446     }
3447
3448     if (!err && !eof) {             /* good data to send to file */
3449         p->buf[p->iosb.count] = '\n';
3450         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3451         if (iss2 < 0) {
3452             p->retry++;
3453             if (p->retry < MAX_RETRY) {
3454                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3455                 return;
3456             }
3457         }
3458         p->retry = 0;
3459     } else if (err) {
3460         _ckvmssts(iss);
3461     }
3462
3463
3464     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3465           pipe_mbxtofd_ast, p,
3466           p->buf, p->bufsize, 0, 0, 0, 0);
3467     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3468     _ckvmssts(iss);
3469 }
3470
3471
3472 typedef struct _pipeloc     PLOC;
3473 typedef struct _pipeloc*   pPLOC;
3474
3475 struct _pipeloc {
3476     pPLOC   next;
3477     char    dir[NAM$C_MAXRSS+1];
3478 };
3479 static pPLOC  head_PLOC = 0;
3480
3481 void
3482 free_pipelocs(pTHX_ void *head)
3483 {
3484     pPLOC p, pnext;
3485     pPLOC *pHead = (pPLOC *)head;
3486
3487     p = *pHead;
3488     while (p) {
3489         pnext = p->next;
3490         PerlMem_free(p);
3491         p = pnext;
3492     }
3493     *pHead = 0;
3494 }
3495
3496 static void
3497 store_pipelocs(pTHX)
3498 {
3499     int    i;
3500     pPLOC  p;
3501     AV    *av = 0;
3502     SV    *dirsv;
3503     GV    *gv;
3504     char  *dir, *x;
3505     char  *unixdir;
3506     char  temp[NAM$C_MAXRSS+1];
3507     STRLEN n_a;
3508
3509     if (head_PLOC)
3510         free_pipelocs(aTHX_ &head_PLOC);
3511
3512 /*  the . directory from @INC comes last */
3513
3514     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3515     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3516     p->next = head_PLOC;
3517     head_PLOC = p;
3518     strcpy(p->dir,"./");
3519
3520 /*  get the directory from $^X */
3521
3522     unixdir = PerlMem_malloc(VMS_MAXRSS);
3523     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3524
3525 #ifdef PERL_IMPLICIT_CONTEXT
3526     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3527 #else
3528     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3529 #endif
3530         strcpy(temp, PL_origargv[0]);
3531         x = strrchr(temp,']');
3532         if (x == NULL) {
3533         x = strrchr(temp,'>');
3534           if (x == NULL) {
3535             /* It could be a UNIX path */
3536             x = strrchr(temp,'/');
3537           }
3538         }
3539         if (x)
3540           x[1] = '\0';
3541         else {
3542           /* Got a bare name, so use default directory */
3543           temp[0] = '.';
3544           temp[1] = '\0';
3545         }
3546
3547         if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3548             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3549             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3550             p->next = head_PLOC;
3551             head_PLOC = p;
3552             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3553             p->dir[NAM$C_MAXRSS] = '\0';
3554         }
3555     }
3556
3557 /*  reverse order of @INC entries, skip "." since entered above */
3558
3559 #ifdef PERL_IMPLICIT_CONTEXT
3560     if (aTHX)
3561 #endif
3562     if (PL_incgv) av = GvAVn(PL_incgv);
3563
3564     for (i = 0; av && i <= AvFILL(av); i++) {
3565         dirsv = *av_fetch(av,i,TRUE);
3566
3567         if (SvROK(dirsv)) continue;
3568         dir = SvPVx(dirsv,n_a);
3569         if (strcmp(dir,".") == 0) continue;
3570         if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3571             continue;
3572
3573         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3574         p->next = head_PLOC;
3575         head_PLOC = p;
3576         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3577         p->dir[NAM$C_MAXRSS] = '\0';
3578     }
3579
3580 /* most likely spot (ARCHLIB) put first in the list */
3581
3582 #ifdef ARCHLIB_EXP
3583     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3584         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3585         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3586         p->next = head_PLOC;
3587         head_PLOC = p;
3588         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3589         p->dir[NAM$C_MAXRSS] = '\0';
3590     }
3591 #endif
3592     PerlMem_free(unixdir);
3593 }
3594
3595 static I32
3596 Perl_cando_by_name_int
3597    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3598 #if !defined(PERL_IMPLICIT_CONTEXT)
3599 #define cando_by_name_int               Perl_cando_by_name_int
3600 #else
3601 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3602 #endif
3603
3604 static char *
3605 find_vmspipe(pTHX)
3606 {
3607     static int   vmspipe_file_status = 0;
3608     static char  vmspipe_file[NAM$C_MAXRSS+1];
3609
3610     /* already found? Check and use ... need read+execute permission */
3611
3612     if (vmspipe_file_status == 1) {
3613         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3614          && cando_by_name_int
3615            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3616             return vmspipe_file;
3617         }
3618         vmspipe_file_status = 0;
3619     }
3620
3621     /* scan through stored @INC, $^X */
3622
3623     if (vmspipe_file_status == 0) {
3624         char file[NAM$C_MAXRSS+1];
3625         pPLOC  p = head_PLOC;
3626
3627         while (p) {
3628             char * exp_res;
3629             int dirlen;
3630             strcpy(file, p->dir);
3631             dirlen = strlen(file);
3632             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3633             file[NAM$C_MAXRSS] = '\0';
3634             p = p->next;
3635
3636             exp_res = do_rmsexpand
3637                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3638             if (!exp_res) continue;
3639
3640             if (cando_by_name_int
3641                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3642              && cando_by_name_int
3643                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3644                 vmspipe_file_status = 1;
3645                 return vmspipe_file;
3646             }
3647         }
3648         vmspipe_file_status = -1;   /* failed, use tempfiles */
3649     }
3650
3651     return 0;
3652 }
3653
3654 static FILE *
3655 vmspipe_tempfile(pTHX)
3656 {
3657     char file[NAM$C_MAXRSS+1];
3658     FILE *fp;
3659     static int index = 0;
3660     Stat_t s0, s1;
3661     int cmp_result;
3662
3663     /* create a tempfile */
3664
3665     /* we can't go from   W, shr=get to  R, shr=get without
3666        an intermediate vulnerable state, so don't bother trying...
3667
3668        and lib$spawn doesn't shr=put, so have to close the write
3669
3670        So... match up the creation date/time and the FID to
3671        make sure we're dealing with the same file
3672
3673     */
3674
3675     index++;
3676     if (!decc_filename_unix_only) {
3677       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3678       fp = fopen(file,"w");
3679       if (!fp) {
3680         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3681         fp = fopen(file,"w");
3682         if (!fp) {
3683             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3684             fp = fopen(file,"w");
3685         }
3686       }
3687      }
3688      else {
3689       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3690       fp = fopen(file,"w");
3691       if (!fp) {
3692         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3693         fp = fopen(file,"w");
3694         if (!fp) {
3695           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3696           fp = fopen(file,"w");
3697         }
3698       }
3699     }
3700     if (!fp) return 0;  /* we're hosed */
3701
3702     fprintf(fp,"$! 'f$verify(0)'\n");
3703     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3704     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3705     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3706     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3707     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3708     fprintf(fp,"$ perl_del    = \"delete\"\n");
3709     fprintf(fp,"$ pif         = \"if\"\n");
3710     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3711     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3712     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3713     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3714     fprintf(fp,"$!  --- build command line to get max possible length\n");
3715     fprintf(fp,"$c=perl_popen_cmd0\n");
3716     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3717     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3718     fprintf(fp,"$x=perl_popen_cmd3\n");
3719     fprintf(fp,"$c=c+x\n");
3720     fprintf(fp,"$ perl_on\n");
3721     fprintf(fp,"$ 'c'\n");
3722     fprintf(fp,"$ perl_status = $STATUS\n");
3723     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3724     fprintf(fp,"$ perl_exit 'perl_status'\n");
3725     fsync(fileno(fp));
3726
3727     fgetname(fp, file, 1);
3728     fstat(fileno(fp), (struct stat *)&s0);
3729     fclose(fp);
3730
3731     if (decc_filename_unix_only)
3732         do_tounixspec(file, file, 0, NULL);
3733     fp = fopen(file,"r","shr=get");
3734     if (!fp) return 0;
3735     fstat(fileno(fp), (struct stat *)&s1);
3736
3737     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3738     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3739         fclose(fp);
3740         return 0;
3741     }
3742
3743     return fp;
3744 }
3745
3746
3747 #ifdef USE_VMS_DECTERM
3748
3749 static int vms_is_syscommand_xterm(void)
3750 {
3751     const static struct dsc$descriptor_s syscommand_dsc =
3752       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3753
3754     const static struct dsc$descriptor_s decwdisplay_dsc =
3755       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3756
3757     struct item_list_3 items[2];
3758     unsigned short dvi_iosb[4];
3759     unsigned long devchar;
3760     unsigned long devclass;
3761     int status;
3762
3763     /* Very simple check to guess if sys$command is a decterm? */
3764     /* First see if the DECW$DISPLAY: device exists */
3765     items[0].len = 4;
3766     items[0].code = DVI$_DEVCHAR;
3767     items[0].bufadr = &devchar;
3768     items[0].retadr = NULL;
3769     items[1].len = 0;
3770     items[1].code = 0;
3771
3772     status = sys$getdviw
3773         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3774
3775     if ($VMS_STATUS_SUCCESS(status)) {
3776         status = dvi_iosb[0];
3777     }
3778
3779     if (!$VMS_STATUS_SUCCESS(status)) {
3780         SETERRNO(EVMSERR, status);
3781         return -1;
3782     }
3783
3784     /* If it does, then for now assume that we are on a workstation */
3785     /* Now verify that SYS$COMMAND is a terminal */
3786     /* for creating the debugger DECTerm */
3787
3788     items[0].len = 4;
3789     items[0].code = DVI$_DEVCLASS;
3790     items[0].bufadr = &devclass;
3791     items[0].retadr = NULL;
3792     items[1].len = 0;
3793     items[1].code = 0;
3794
3795     status = sys$getdviw
3796         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3797
3798     if ($VMS_STATUS_SUCCESS(status)) {
3799         status = dvi_iosb[0];
3800     }
3801
3802     if (!$VMS_STATUS_SUCCESS(status)) {
3803         SETERRNO(EVMSERR, status);
3804         return -1;
3805     }
3806     else {
3807         if (devclass == DC$_TERM) {
3808             return 0;
3809         }
3810     }
3811     return -1;
3812 }
3813
3814 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3815 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3816 {
3817     int status;
3818     int ret_stat;
3819     char * ret_char;
3820     char device_name[65];
3821     unsigned short device_name_len;
3822     struct dsc$descriptor_s customization_dsc;
3823     struct dsc$descriptor_s device_name_dsc;
3824     const char * cptr;
3825     char * tptr;
3826     char customization[200];
3827     char title[40];
3828     pInfo info = NULL;
3829     char mbx1[64];
3830     unsigned short p_chan;
3831     int n;
3832     unsigned short iosb[4];
3833     struct item_list_3 items[2];
3834     const char * cust_str =
3835         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3836     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3837                                           DSC$K_CLASS_S, mbx1};
3838
3839     ret_char = strstr(cmd," xterm ");
3840     if (ret_char == NULL)
3841         return NULL;
3842     cptr = ret_char + 7;
3843     ret_char = strstr(cmd,"tty");
3844     if (ret_char == NULL)
3845         return NULL;
3846     ret_char = strstr(cmd,"sleep");
3847     if (ret_char == NULL)
3848         return NULL;
3849
3850     /* Are we on a workstation? */
3851     /* to do: capture the rows / columns and pass their properties */
3852     ret_stat = vms_is_syscommand_xterm();
3853     if (ret_stat < 0)
3854         return NULL;
3855
3856     /* Make the title: */
3857     ret_char = strstr(cptr,"-title");
3858     if (ret_char != NULL) {
3859         while ((*cptr != 0) && (*cptr != '\"')) {
3860             cptr++;
3861         }
3862         if (*cptr == '\"')
3863             cptr++;
3864         n = 0;
3865         while ((*cptr != 0) && (*cptr != '\"')) {
3866             title[n] = *cptr;
3867             n++;
3868             if (n == 39) {
3869                 title[39] == 0;
3870                 break;
3871             }
3872             cptr++;
3873         }
3874         title[n] = 0;
3875     }
3876     else {
3877             /* Default title */
3878             strcpy(title,"Perl Debug DECTerm");
3879     }
3880     sprintf(customization, cust_str, title);
3881
3882     customization_dsc.dsc$a_pointer = customization;
3883     customization_dsc.dsc$w_length = strlen(customization);
3884     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3885     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3886
3887     device_name_dsc.dsc$a_pointer = device_name;
3888     device_name_dsc.dsc$w_length = sizeof device_name -1;
3889     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3890     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3891
3892     device_name_len = 0;
3893
3894     /* Try to create the window */
3895      status = decw$term_port
3896        (NULL,
3897         NULL,
3898         &customization_dsc,
3899         &device_name_dsc,
3900         &device_name_len,
3901         NULL,
3902         NULL,
3903         NULL);
3904     if (!$VMS_STATUS_SUCCESS(status)) {
3905         SETERRNO(EVMSERR, status);
3906         return NULL;
3907     }
3908
3909     device_name[device_name_len] = '\0';
3910
3911     /* Need to set this up to look like a pipe for cleanup */
3912     n = sizeof(Info);
3913     status = lib$get_vm(&n, &info);
3914     if (!$VMS_STATUS_SUCCESS(status)) {
3915         SETERRNO(ENOMEM, status);
3916         return NULL;
3917     }
3918
3919     info->mode = *mode;
3920     info->done = FALSE;
3921     info->completion = 0;
3922     info->closing    = FALSE;
3923     info->in         = 0;
3924     info->out        = 0;
3925     info->err        = 0;
3926     info->fp         = Nullfp;
3927     info->useFILE    = 0;
3928     info->waiting    = 0;
3929     info->in_done    = TRUE;
3930     info->out_done   = TRUE;
3931     info->err_done   = TRUE;
3932
3933     /* Assign a channel on this so that it will persist, and not login */
3934     /* We stash this channel in the info structure for reference. */
3935     /* The created xterm self destructs when the last channel is removed */
3936     /* and it appears that perl5db.pl (perl debugger) does this routinely */
3937     /* So leave this assigned. */
3938     device_name_dsc.dsc$w_length = device_name_len;
3939     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
3940     if (!$VMS_STATUS_SUCCESS(status)) {
3941         SETERRNO(EVMSERR, status);
3942         return NULL;
3943     }
3944     info->xchan_valid = 1;
3945
3946     /* Now create a mailbox to be read by the application */
3947
3948     create_mbx(aTHX_ &p_chan, &d_mbx1);
3949
3950     /* write the name of the created terminal to the mailbox */
3951     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
3952             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
3953
3954     if (!$VMS_STATUS_SUCCESS(status)) {
3955         SETERRNO(EVMSERR, status);
3956         return NULL;
3957     }
3958
3959     info->fp  = PerlIO_open(mbx1, mode);
3960
3961     /* Done with this channel */
3962     sys$dassgn(p_chan);
3963
3964     /* If any errors, then clean up */
3965     if (!info->fp) {
3966         n = sizeof(Info);
3967         _ckvmssts(lib$free_vm(&n, &info));
3968         return NULL;
3969         }
3970
3971     /* All done */
3972     return info->fp;
3973 }
3974 #endif
3975
3976 static PerlIO *
3977 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3978 {
3979     static int handler_set_up = FALSE;
3980     unsigned long int sts, flags = CLI$M_NOWAIT;
3981     /* The use of a GLOBAL table (as was done previously) rendered
3982      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3983      * environment.  Hence we've switched to LOCAL symbol table.
3984      */
3985     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3986     int j, wait = 0, n;
3987     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3988     char *in, *out, *err, mbx[512];
3989     FILE *tpipe = 0;
3990     char tfilebuf[NAM$C_MAXRSS+1];
3991     pInfo info = NULL;
3992     char cmd_sym_name[20];
3993     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3994                                       DSC$K_CLASS_S, symbol};
3995     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3996                                       DSC$K_CLASS_S, 0};
3997     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3998                                       DSC$K_CLASS_S, cmd_sym_name};
3999     struct dsc$descriptor_s *vmscmd;
4000     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4001     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4002     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4003
4004 #ifdef USE_VMS_DECTERM
4005     /* Check here for Xterm create request.  This means looking for
4006      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4007      *  is possible to create an xterm.
4008      */
4009     if (*in_mode == 'r') {
4010         PerlIO * xterm_fd;
4011
4012         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4013         if (xterm_fd != Nullfp)
4014             return xterm_fd;
4015     }
4016 #endif
4017
4018     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4019
4020     /* once-per-program initialization...
4021        note that the SETAST calls and the dual test of pipe_ef
4022        makes sure that only the FIRST thread through here does
4023        the initialization...all other threads wait until it's
4024        done.
4025
4026        Yeah, uglier than a pthread call, it's got all the stuff inline
4027        rather than in a separate routine.
4028     */
4029
4030     if (!pipe_ef) {
4031         _ckvmssts(sys$setast(0));
4032         if (!pipe_ef) {
4033             unsigned long int pidcode = JPI$_PID;
4034             $DESCRIPTOR(d_delay, RETRY_DELAY);
4035             _ckvmssts(lib$get_ef(&pipe_ef));
4036             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4037             _ckvmssts(sys$bintim(&d_delay, delaytime));
4038         }
4039         if (!handler_set_up) {
4040           _ckvmssts(sys$dclexh(&pipe_exitblock));
4041           handler_set_up = TRUE;
4042         }
4043         _ckvmssts(sys$setast(1));
4044     }
4045
4046     /* see if we can find a VMSPIPE.COM */
4047
4048     tfilebuf[0] = '@';
4049     vmspipe = find_vmspipe(aTHX);
4050     if (vmspipe) {
4051         strcpy(tfilebuf+1,vmspipe);
4052     } else {        /* uh, oh...we're in tempfile hell */
4053         tpipe = vmspipe_tempfile(aTHX);
4054         if (!tpipe) {       /* a fish popular in Boston */
4055             if (ckWARN(WARN_PIPE)) {
4056                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4057             }
4058         return Nullfp;
4059         }
4060         fgetname(tpipe,tfilebuf+1,1);
4061     }
4062     vmspipedsc.dsc$a_pointer = tfilebuf;
4063     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4064
4065     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4066     if (!(sts & 1)) {
4067       switch (sts) {
4068         case RMS$_FNF:  case RMS$_DNF:
4069           set_errno(ENOENT); break;
4070         case RMS$_DIR:
4071           set_errno(ENOTDIR); break;
4072         case RMS$_DEV:
4073           set_errno(ENODEV); break;
4074         case RMS$_PRV:
4075           set_errno(EACCES); break;
4076         case RMS$_SYN:
4077           set_errno(EINVAL); break;
4078         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4079           set_errno(E2BIG); break;
4080         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4081           _ckvmssts(sts); /* fall through */
4082         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4083           set_errno(EVMSERR);
4084       }
4085       set_vaxc_errno(sts);
4086       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4087         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4088       }
4089       *psts = sts;
4090       return Nullfp;
4091     }
4092     n = sizeof(Info);
4093     _ckvmssts(lib$get_vm(&n, &info));
4094
4095     strcpy(mode,in_mode);
4096     info->mode = *mode;
4097     info->done = FALSE;
4098     info->completion = 0;
4099     info->closing    = FALSE;
4100     info->in         = 0;
4101     info->out        = 0;
4102     info->err        = 0;
4103     info->fp         = Nullfp;
4104     info->useFILE    = 0;
4105     info->waiting    = 0;
4106     info->in_done    = TRUE;
4107     info->out_done   = TRUE;
4108     info->err_done   = TRUE;
4109     info->xchan      = 0;
4110     info->xchan_valid = 0;
4111
4112     in = PerlMem_malloc(VMS_MAXRSS);
4113     if (in == NULL) _ckvmssts(SS$_INSFMEM);
4114     out = PerlMem_malloc(VMS_MAXRSS);
4115     if (out == NULL) _ckvmssts(SS$_INSFMEM);
4116     err = PerlMem_malloc(VMS_MAXRSS);
4117     if (err == NULL) _ckvmssts(SS$_INSFMEM);
4118
4119     in[0] = out[0] = err[0] = '\0';
4120
4121     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4122         info->useFILE = 1;
4123         strcpy(p,p+1);
4124     }
4125     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4126         wait = 1;
4127         strcpy(p,p+1);
4128     }
4129
4130     if (*mode == 'r') {             /* piping from subroutine */
4131
4132         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4133         if (info->out) {
4134             info->out->pipe_done = &info->out_done;
4135             info->out_done = FALSE;
4136             info->out->info = info;
4137         }
4138         if (!info->useFILE) {
4139             info->fp  = PerlIO_open(mbx, mode);
4140         } else {
4141             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4142             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4143         }
4144
4145         if (!info->fp && info->out) {
4146             sys$cancel(info->out->chan_out);
4147
4148             while (!info->out_done) {
4149                 int done;
4150                 _ckvmssts(sys$setast(0));
4151                 done = info->out_done;
4152                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4153                 _ckvmssts(sys$setast(1));
4154                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4155             }
4156
4157             if (info->out->buf) {
4158                 n = info->out->bufsize * sizeof(char);
4159                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4160             }
4161             n = sizeof(Pipe);
4162             _ckvmssts(lib$free_vm(&n, &info->out));
4163             n = sizeof(Info);
4164             _ckvmssts(lib$free_vm(&n, &info));
4165             *psts = RMS$_FNF;
4166             return Nullfp;
4167         }
4168
4169         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4170         if (info->err) {
4171             info->err->pipe_done = &info->err_done;
4172             info->err_done = FALSE;
4173             info->err->info = info;
4174         }
4175
4176     } else if (*mode == 'w') {      /* piping to subroutine */
4177
4178         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4179         if (info->out) {
4180             info->out->pipe_done = &info->out_done;
4181             info->out_done = FALSE;
4182             info->out->info = info;
4183         }
4184
4185         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4186         if (info->err) {
4187             info->err->pipe_done = &info->err_done;
4188             info->err_done = FALSE;
4189             info->err->info = info;
4190         }
4191
4192         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4193         if (!info->useFILE) {
4194             info->fp  = PerlIO_open(mbx, mode);
4195         } else {
4196             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4197             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4198         }
4199
4200         if (info->in) {
4201             info->in->pipe_done = &info->in_done;
4202             info->in_done = FALSE;
4203             info->in->info = info;
4204         }
4205
4206         /* error cleanup */
4207         if (!info->fp && info->in) {
4208             info->done = TRUE;
4209             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4210                               0, 0, 0, 0, 0, 0, 0, 0));
4211
4212             while (!info->in_done) {
4213                 int done;
4214                 _ckvmssts(sys$setast(0));
4215                 done = info->in_done;
4216                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4217                 _ckvmssts(sys$setast(1));
4218                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4219             }
4220
4221             if (info->in->buf) {
4222                 n = info->in->bufsize * sizeof(char);
4223                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4224             }
4225             n = sizeof(Pipe);
4226             _ckvmssts(lib$free_vm(&n, &info->in));
4227             n = sizeof(Info);
4228             _ckvmssts(lib$free_vm(&n, &info));
4229             *psts = RMS$_FNF;
4230             return Nullfp;
4231         }
4232
4233
4234     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4235         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4236         if (info->out) {
4237             info->out->pipe_done = &info->out_done;
4238             info->out_done = FALSE;
4239             info->out->info = info;
4240         }
4241
4242         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4243         if (info->err) {
4244             info->err->pipe_done = &info->err_done;
4245             info->err_done = FALSE;
4246             info->err->info = info;
4247         }
4248     }
4249
4250     symbol[MAX_DCL_SYMBOL] = '\0';
4251
4252     strncpy(symbol, in, MAX_DCL_SYMBOL);
4253     d_symbol.dsc$w_length = strlen(symbol);
4254     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4255
4256     strncpy(symbol, err, MAX_DCL_SYMBOL);
4257     d_symbol.dsc$w_length = strlen(symbol);
4258     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4259
4260     strncpy(symbol, out, MAX_DCL_SYMBOL);
4261     d_symbol.dsc$w_length = strlen(symbol);
4262     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4263
4264     /* Done with the names for the pipes */
4265     PerlMem_free(err);
4266     PerlMem_free(out);
4267     PerlMem_free(in);
4268
4269     p = vmscmd->dsc$a_pointer;
4270     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4271     if (*p == '$') p++;                         /* remove leading $ */
4272     while (*p == ' ' || *p == '\t') p++;
4273
4274     for (j = 0; j < 4; j++) {
4275         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4276         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4277
4278     strncpy(symbol, p, MAX_DCL_SYMBOL);
4279     d_symbol.dsc$w_length = strlen(symbol);
4280     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4281
4282         if (strlen(p) > MAX_DCL_SYMBOL) {
4283             p += MAX_DCL_SYMBOL;
4284         } else {
4285             p += strlen(p);
4286         }
4287     }
4288     _ckvmssts(sys$setast(0));
4289     info->next=open_pipes;  /* prepend to list */
4290     open_pipes=info;
4291     _ckvmssts(sys$setast(1));
4292     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4293      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4294      * have SYS$COMMAND if we need it.
4295      */
4296     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4297                       0, &info->pid, &info->completion,
4298                       0, popen_completion_ast,info,0,0,0));
4299
4300     /* if we were using a tempfile, close it now */
4301
4302     if (tpipe) fclose(tpipe);
4303
4304     /* once the subprocess is spawned, it has copied the symbols and
4305        we can get rid of ours */
4306
4307     for (j = 0; j < 4; j++) {
4308         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4309         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4310     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4311     }
4312     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4313     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4314     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4315     vms_execfree(vmscmd);
4316
4317 #ifdef PERL_IMPLICIT_CONTEXT
4318     if (aTHX)
4319 #endif
4320     PL_forkprocess = info->pid;
4321
4322     if (wait) {
4323          int done = 0;
4324          while (!done) {
4325              _ckvmssts(sys$setast(0));
4326              done = info->done;
4327              if (!done) _ckvmssts(sys$clref(pipe_ef));
4328              _ckvmssts(sys$setast(1));
4329              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4330          }
4331         *psts = info->completion;
4332 /* Caller thinks it is open and tries to close it. */
4333 /* This causes some problems, as it changes the error status */
4334 /*        my_pclose(info->fp); */
4335     } else {
4336         *psts = SS$_NORMAL;
4337     }
4338     return info->fp;
4339 }  /* end of safe_popen */
4340
4341
4342 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4343 PerlIO *
4344 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4345 {
4346     int sts;
4347     TAINT_ENV();
4348     TAINT_PROPER("popen");
4349     PERL_FLUSHALL_FOR_CHILD;
4350     return safe_popen(aTHX_ cmd,mode,&sts);
4351 }
4352
4353 /*}}}*/
4354
4355 /*{{{  I32 my_pclose(PerlIO *fp)*/
4356 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4357 {
4358     pInfo info, last = NULL;
4359     unsigned long int retsts;
4360     int done, iss, n;
4361     int status;
4362
4363     for (info = open_pipes; info != NULL; last = info, info = info->next)
4364         if (info->fp == fp) break;
4365
4366     if (info == NULL) {  /* no such pipe open */
4367       set_errno(ECHILD); /* quoth POSIX */
4368       set_vaxc_errno(SS$_NONEXPR);
4369       return -1;
4370     }
4371
4372     /* If we were writing to a subprocess, insure that someone reading from
4373      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4374      * produce an EOF record in the mailbox.
4375      *
4376      *  well, at least sometimes it *does*, so we have to watch out for
4377      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4378      */
4379      if (info->fp) {
4380         if (!info->useFILE)
4381             PerlIO_flush(info->fp);   /* first, flush data */
4382         else
4383             fflush((FILE *)info->fp);
4384     }
4385
4386     _ckvmssts(sys$setast(0));
4387      info->closing = TRUE;
4388      done = info->done && info->in_done && info->out_done && info->err_done;
4389      /* hanging on write to Perl's input? cancel it */
4390      if (info->mode == 'r' && info->out && !info->out_done) {
4391         if (info->out->chan_out) {
4392             _ckvmssts(sys$cancel(info->out->chan_out));
4393             if (!info->out->chan_in) {   /* EOF generation, need AST */
4394                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4395             }
4396         }
4397      }
4398      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4399          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4400                            0, 0, 0, 0, 0, 0));
4401     _ckvmssts(sys$setast(1));
4402     if (info->fp) {
4403      if (!info->useFILE)
4404         PerlIO_close(info->fp);
4405      else
4406         fclose((FILE *)info->fp);
4407     }
4408      /*
4409         we have to wait until subprocess completes, but ALSO wait until all
4410         the i/o completes...otherwise we'll be freeing the "info" structure
4411         that the i/o ASTs could still be using...
4412      */
4413
4414      while (!done) {
4415          _ckvmssts(sys$setast(0));
4416          done = info->done && info->in_done && info->out_done && info->err_done;
4417          if (!done) _ckvmssts(sys$clref(pipe_ef));
4418          _ckvmssts(sys$setast(1));
4419          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4420      }
4421      retsts = info->completion;
4422
4423     /* remove from list of open pipes */
4424     _ckvmssts(sys$setast(0));
4425     if (last) last->next = info->next;
4426     else open_pipes = info->next;
4427     _ckvmssts(sys$setast(1));
4428
4429     /* free buffers and structures */
4430
4431     if (info->in) {
4432         if (info->in->buf) {
4433             n = info->in->bufsize * sizeof(char);
4434             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4435         }
4436         n = sizeof(Pipe);
4437         _ckvmssts(lib$free_vm(&n, &info->in));
4438     }
4439     if (info->out) {
4440         if (info->out->buf) {
4441             n = info->out->bufsize * sizeof(char);
4442             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4443         }
4444         n = sizeof(Pipe);
4445         _ckvmssts(lib$free_vm(&n, &info->out));
4446     }
4447     if (info->err) {
4448         if (info->err->buf) {
4449             n = info->err->bufsize * sizeof(char);
4450             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4451         }
4452         n = sizeof(Pipe);
4453         _ckvmssts(lib$free_vm(&n, &info->err));
4454     }
4455     n = sizeof(Info);
4456     _ckvmssts(lib$free_vm(&n, &info));
4457
4458     return retsts;
4459
4460 }  /* end of my_pclose() */
4461
4462 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4463   /* Roll our own prototype because we want this regardless of whether
4464    * _VMS_WAIT is defined.
4465    */
4466   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4467 #endif
4468 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4469    created with popen(); otherwise partially emulate waitpid() unless
4470    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4471    Also check processes not considered by the CRTL waitpid().
4472  */
4473 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4474 Pid_t
4475 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4476 {
4477     pInfo info;
4478     int done;
4479     int sts;
4480     int j;
4481
4482     if (statusp) *statusp = 0;
4483
4484     for (info = open_pipes; info != NULL; info = info->next)
4485         if (info->pid == pid) break;
4486
4487     if (info != NULL) {  /* we know about this child */
4488       while (!info->done) {
4489           _ckvmssts(sys$setast(0));
4490           done = info->done;
4491           if (!done) _ckvmssts(sys$clref(pipe_ef));
4492           _ckvmssts(sys$setast(1));
4493           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4494       }
4495
4496       if (statusp) *statusp = info->completion;
4497       return pid;
4498     }
4499
4500     /* child that already terminated? */
4501
4502     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4503         if (closed_list[j].pid == pid) {
4504             if (statusp) *statusp = closed_list[j].completion;
4505             return pid;
4506         }
4507     }
4508
4509     /* fall through if this child is not one of our own pipe children */
4510
4511 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4512
4513       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4514        * in 7.2 did we get a version that fills in the VMS completion
4515        * status as Perl has always tried to do.
4516        */
4517
4518       sts = __vms_waitpid( pid, statusp, flags );
4519
4520       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4521          return sts;
4522
4523       /* If the real waitpid tells us the child does not exist, we
4524        * fall through here to implement waiting for a child that
4525        * was created by some means other than exec() (say, spawned
4526        * from DCL) or to wait for a process that is not a subprocess
4527        * of the current process.
4528        */
4529
4530 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4531
4532     {
4533       $DESCRIPTOR(intdsc,"0 00:00:01");
4534       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4535       unsigned long int pidcode = JPI$_PID, mypid;
4536       unsigned long int interval[2];
4537       unsigned int jpi_iosb[2];
4538       struct itmlst_3 jpilist[2] = {
4539           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4540           {                      0,         0,                 0, 0}
4541       };
4542
4543       if (pid <= 0) {
4544         /* Sorry folks, we don't presently implement rooting around for
4545            the first child we can find, and we definitely don't want to
4546            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4547          */
4548         set_errno(ENOTSUP);
4549         return -1;
4550       }
4551
4552       /* Get the owner of the child so I can warn if it's not mine. If the
4553        * process doesn't exist or I don't have the privs to look at it,
4554        * I can go home early.
4555        */
4556       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4557       if (sts & 1) sts = jpi_iosb[0];
4558       if (!(sts & 1)) {
4559         switch (sts) {
4560             case SS$_NONEXPR:
4561                 set_errno(ECHILD);
4562                 break;
4563             case SS$_NOPRIV:
4564                 set_errno(EACCES);
4565                 break;
4566             default:
4567                 _ckvmssts(sts);
4568         }
4569         set_vaxc_errno(sts);
4570         return -1;
4571       }
4572
4573       if (ckWARN(WARN_EXEC)) {
4574         /* remind folks they are asking for non-standard waitpid behavior */
4575         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4576         if (ownerpid != mypid)
4577           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4578                       "waitpid: process %x is not a child of process %x",
4579                       pid,mypid);
4580       }
4581
4582       /* simply check on it once a second until it's not there anymore. */
4583
4584       _ckvmssts(sys$bintim(&intdsc,interval));
4585       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4586             _ckvmssts(sys$schdwk(0,0,interval,0));
4587             _ckvmssts(sys$hiber());
4588       }
4589       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4590
4591       _ckvmssts(sts);
4592       return pid;
4593     }
4594 }  /* end of waitpid() */
4595 /*}}}*/
4596 /*}}}*/
4597 /*}}}*/
4598
4599 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4600 char *
4601 my_gconvert(double val, int ndig, int trail, char *buf)
4602 {
4603   static char __gcvtbuf[DBL_DIG+1];
4604   char *loc;
4605
4606   loc = buf ? buf : __gcvtbuf;
4607
4608 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4609   if (val < 1) {
4610     sprintf(loc,"%.*g",ndig,val);
4611     return loc;
4612   }
4613 #endif
4614
4615   if (val) {
4616     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4617     return gcvt(val,ndig,loc);
4618   }
4619   else {
4620     loc[0] = '0'; loc[1] = '\0';
4621     return loc;
4622   }
4623
4624 }
4625 /*}}}*/
4626
4627 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4628 static int rms_free_search_context(struct FAB * fab)
4629 {
4630 struct NAM * nam;
4631
4632     nam = fab->fab$l_nam;
4633     nam->nam$b_nop |= NAM$M_SYNCHK;
4634     nam->nam$l_rlf = NULL;
4635     fab->fab$b_dns = 0;
4636     return sys$parse(fab, NULL, NULL);
4637 }
4638
4639 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4640 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4641 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4642 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4643 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4644 #define rms_nam_esll(nam) nam.nam$b_esl
4645 #define rms_nam_esl(nam) nam.nam$b_esl
4646 #define rms_nam_name(nam) nam.nam$l_name
4647 #define rms_nam_namel(nam) nam.nam$l_name
4648 #define rms_nam_type(nam) nam.nam$l_type
4649 #define rms_nam_typel(nam) nam.nam$l_type
4650 #define rms_nam_ver(nam) nam.nam$l_ver
4651 #define rms_nam_verl(nam) nam.nam$l_ver
4652 #define rms_nam_rsll(nam) nam.nam$b_rsl
4653 #define rms_nam_rsl(nam) nam.nam$b_rsl
4654 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4655 #define rms_set_fna(fab, nam, name, size) \
4656         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4657 #define rms_get_fna(fab, nam) fab.fab$l_fna
4658 #define rms_set_dna(fab, nam, name, size) \
4659         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4660 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4661 #define rms_set_esa(fab, nam, name, size) \
4662         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4663 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4664         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4665 #define rms_set_rsa(nam, name, size) \
4666         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4667 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4668         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4669 #define rms_nam_name_type_l_size(nam) \
4670         (nam.nam$b_name + nam.nam$b_type)
4671 #else
4672 static int rms_free_search_context(struct FAB * fab)
4673 {
4674 struct NAML * nam;
4675
4676     nam = fab->fab$l_naml;
4677     nam->naml$b_nop |= NAM$M_SYNCHK;
4678     nam->naml$l_rlf = NULL;
4679     nam->naml$l_long_defname_size = 0;
4680
4681     fab->fab$b_dns = 0;
4682     return sys$parse(fab, NULL, NULL);
4683 }
4684
4685 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4686 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4687 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4688 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4689 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4690 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4691 #define rms_nam_esl(nam) nam.naml$b_esl
4692 #define rms_nam_name(nam) nam.naml$l_name
4693 #define rms_nam_namel(nam) nam.naml$l_long_name
4694 #define rms_nam_type(nam) nam.naml$l_type
4695 #define rms_nam_typel(nam) nam.naml$l_long_type
4696 #define rms_nam_ver(nam) nam.naml$l_ver
4697 #define rms_nam_verl(nam) nam.naml$l_long_ver
4698 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4699 #define rms_nam_rsl(nam) nam.naml$b_rsl
4700 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4701 #define rms_set_fna(fab, nam, name, size) \
4702         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4703         nam.naml$l_long_filename_size = size; \
4704         nam.naml$l_long_filename = name;}
4705 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4706 #define rms_set_dna(fab, nam, name, size) \
4707         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4708         nam.naml$l_long_defname_size = size; \
4709         nam.naml$l_long_defname = name; }
4710 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4711 #define rms_set_esa(fab, nam, name, size) \
4712         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4713         nam.naml$l_long_expand_alloc = size; \
4714         nam.naml$l_long_expand = name; }
4715 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4716         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4717         nam.naml$l_long_expand = l_name; \
4718         nam.naml$l_long_expand_alloc = l_size; }
4719 #define rms_set_rsa(nam, name, size) \
4720         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4721         nam.naml$l_long_result = name; \
4722         nam.naml$l_long_result_alloc = size; }
4723 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4724         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4725         nam.naml$l_long_result = l_name; \
4726         nam.naml$l_long_result_alloc = l_size; }
4727 #define rms_nam_name_type_l_size(nam) \
4728         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4729 #endif
4730
4731
4732 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4733 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4734  * to expand file specification.  Allows for a single default file
4735  * specification and a simple mask of options.  If outbuf is non-NULL,
4736  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4737  * the resultant file specification is placed.  If outbuf is NULL, the
4738  * resultant file specification is placed into a static buffer.
4739  * The third argument, if non-NULL, is taken to be a default file
4740  * specification string.  The fourth argument is unused at present.
4741  * rmesexpand() returns the address of the resultant string if
4742  * successful, and NULL on error.
4743  *
4744  * New functionality for previously unused opts value:
4745  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4746  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
4747  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4748  */
4749 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4750
4751 static char *
4752 mp_do_rmsexpand
4753    (pTHX_ const char *filespec,
4754     char *outbuf,
4755     int ts,
4756     const char *defspec,
4757     unsigned opts,
4758     int * fs_utf8,
4759     int * dfs_utf8)
4760 {
4761   static char __rmsexpand_retbuf[VMS_MAXRSS];
4762   char * vmsfspec, *tmpfspec;
4763   char * esa, *cp, *out = NULL;
4764   char * tbuf;
4765   char * esal;
4766   char * outbufl;
4767   struct FAB myfab = cc$rms_fab;
4768   rms_setup_nam(mynam);
4769   STRLEN speclen;
4770   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4771   int sts;
4772
4773   /* temp hack until UTF8 is actually implemented */
4774   if (fs_utf8 != NULL)
4775     *fs_utf8 = 0;
4776
4777   if (!filespec || !*filespec) {
4778     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4779     return NULL;
4780   }
4781   if (!outbuf) {
4782     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4783     else    outbuf = __rmsexpand_retbuf;
4784   }
4785
4786   vmsfspec = NULL;
4787   tmpfspec = NULL;
4788   outbufl = NULL;
4789
4790   isunix = 0;
4791   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4792     isunix = is_unix_filespec(filespec);
4793     if (isunix) {
4794       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4795       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4796       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4797         PerlMem_free(vmsfspec);
4798         if (out)
4799            Safefree(out);
4800         return NULL;
4801       }
4802       filespec = vmsfspec;
4803
4804       /* Unless we are forcing to VMS format, a UNIX input means
4805        * UNIX output, and that requires long names to be used
4806        */
4807       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4808         opts |= PERL_RMSEXPAND_M_LONG;
4809       else {
4810         isunix = 0;
4811       }
4812     }
4813   }
4814
4815   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4816   rms_bind_fab_nam(myfab, mynam);
4817
4818   if (defspec && *defspec) {
4819     int t_isunix;
4820     t_isunix = is_unix_filespec(defspec);
4821     if (t_isunix) {
4822       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4823       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4824       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4825         PerlMem_free(tmpfspec);
4826         if (vmsfspec != NULL)
4827             PerlMem_free(vmsfspec);
4828         if (out)
4829            Safefree(out);
4830         return NULL;
4831       }
4832       defspec = tmpfspec;
4833     }
4834     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4835   }
4836
4837   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4838   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4839 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4840   esal = PerlMem_malloc(VMS_MAXRSS);
4841   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4842 #endif
4843   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4844
4845   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4846     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4847   }
4848   else {
4849 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4850     outbufl = PerlMem_malloc(VMS_MAXRSS);
4851     if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4852     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4853 #else
4854     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4855 #endif
4856   }
4857
4858 #ifdef NAM$M_NO_SHORT_UPCASE
4859   if (decc_efs_case_preserve)
4860     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4861 #endif
4862
4863   /* First attempt to parse as an existing file */
4864   retsts = sys$parse(&myfab,0,0);
4865   if (!(retsts & STS$K_SUCCESS)) {
4866
4867     /* Could not find the file, try as syntax only if error is not fatal */
4868     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4869     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4870       retsts = sys$parse(&myfab,0,0);
4871       if (retsts & STS$K_SUCCESS) goto expanded;
4872     }
4873
4874      /* Still could not parse the file specification */
4875     /*----------------------------------------------*/
4876     sts = rms_free_search_context(&myfab); /* Free search context */
4877     if (out) Safefree(out);
4878     if (tmpfspec != NULL)
4879         PerlMem_free(tmpfspec);
4880     if (vmsfspec != NULL)
4881         PerlMem_free(vmsfspec);
4882     if (outbufl != NULL)
4883         PerlMem_free(outbufl);
4884     PerlMem_free(esa);
4885     PerlMem_free(esal);
4886     set_vaxc_errno(retsts);
4887     if      (retsts == RMS$_PRV) set_errno(EACCES);
4888     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4889     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4890     else                         set_errno(EVMSERR);
4891     return NULL;
4892   }
4893   retsts = sys$search(&myfab,0,0);
4894   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4895     sts = rms_free_search_context(&myfab); /* Free search context */
4896     if (out) Safefree(out);
4897     if (tmpfspec != NULL)
4898         PerlMem_free(tmpfspec);
4899     if (vmsfspec != NULL)
4900         PerlMem_free(vmsfspec);
4901     if (outbufl != NULL)
4902         PerlMem_free(outbufl);
4903     PerlMem_free(esa);
4904     PerlMem_free(esal);
4905     set_vaxc_errno(retsts);
4906     if      (retsts == RMS$_PRV) set_errno(EACCES);
4907     else                         set_errno(EVMSERR);
4908     return NULL;
4909   }
4910
4911   /* If the input filespec contained any lowercase characters,
4912    * downcase the result for compatibility with Unix-minded code. */
4913   expanded:
4914   if (!decc_efs_case_preserve) {
4915     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4916       if (islower(*tbuf)) { haslower = 1; break; }
4917   }
4918
4919    /* Is a long or a short name expected */
4920   /*------------------------------------*/
4921   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4922     if (rms_nam_rsll(mynam)) {
4923         tbuf = outbuf;
4924         speclen = rms_nam_rsll(mynam);
4925     }
4926     else {
4927         tbuf = esal; /* Not esa */
4928         speclen = rms_nam_esll(mynam);
4929     }
4930   }
4931   else {
4932     if (rms_nam_rsl(mynam)) {
4933         tbuf = outbuf;
4934         speclen = rms_nam_rsl(mynam);
4935     }
4936     else {
4937         tbuf = esa; /* Not esal */
4938         speclen = rms_nam_esl(mynam);
4939     }
4940   }
4941   tbuf[speclen] = '\0';
4942
4943   /* Trim off null fields added by $PARSE
4944    * If type > 1 char, must have been specified in original or default spec
4945    * (not true for version; $SEARCH may have added version of existing file).
4946    */
4947   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4948   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4949     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4950              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4951   }
4952   else {
4953     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4954              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4955   }
4956   if (trimver || trimtype) {
4957     if (defspec && *defspec) {
4958       char *defesal = NULL;
4959       defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4960       if (defesal != NULL) {
4961         struct FAB deffab = cc$rms_fab;
4962         rms_setup_nam(defnam);
4963
4964         rms_bind_fab_nam(deffab, defnam);
4965
4966         /* Cast ok */
4967         rms_set_fna
4968             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4969
4970         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4971
4972         rms_clear_nam_nop(defnam);
4973         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4974 #ifdef NAM$M_NO_SHORT_UPCASE
4975         if (decc_efs_case_preserve)
4976           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4977 #endif
4978         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4979           if (trimver) {
4980              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4981           }
4982           if (trimtype) {
4983             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4984           }
4985         }
4986         PerlMem_free(defesal);
4987       }
4988     }
4989     if (trimver) {
4990       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4991         if (*(rms_nam_verl(mynam)) != '\"')
4992           speclen = rms_nam_verl(mynam) - tbuf;
4993       }
4994       else {
4995         if (*(rms_nam_ver(mynam)) != '\"')
4996           speclen = rms_nam_ver(mynam) - tbuf;
4997       }
4998     }
4999     if (trimtype) {
5000       /* If we didn't already trim version, copy down */
5001       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5002         if (speclen > rms_nam_verl(mynam) - tbuf)
5003           memmove
5004            (rms_nam_typel(mynam),
5005             rms_nam_verl(mynam),
5006             speclen - (rms_nam_verl(mynam) - tbuf));
5007           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5008       }
5009       else {
5010         if (speclen > rms_nam_ver(mynam) - tbuf)
5011           memmove
5012            (rms_nam_type(mynam),
5013             rms_nam_ver(mynam),
5014             speclen - (rms_nam_ver(mynam) - tbuf));
5015           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5016       }
5017     }
5018   }
5019
5020    /* Done with these copies of the input files */
5021   /*-------------------------------------------*/
5022   if (vmsfspec != NULL)
5023         PerlMem_free(vmsfspec);
5024   if (tmpfspec != NULL)
5025         PerlMem_free(tmpfspec);
5026
5027   /* If we just had a directory spec on input, $PARSE "helpfully"
5028    * adds an empty name and type for us */
5029   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5030     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5031         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5032         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5033       speclen = rms_nam_namel(mynam) - tbuf;
5034   }
5035   else {
5036     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5037         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5038         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5039       speclen = rms_nam_name(mynam) - tbuf;
5040   }
5041
5042   /* Posix format specifications must have matching quotes */
5043   if (speclen < (VMS_MAXRSS - 1)) {
5044     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5045       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5046         tbuf[speclen] = '\"';
5047         speclen++;
5048       }
5049     }
5050   }
5051   tbuf[speclen] = '\0';
5052   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5053
5054   /* Have we been working with an expanded, but not resultant, spec? */
5055   /* Also, convert back to Unix syntax if necessary. */
5056
5057   if (!rms_nam_rsll(mynam)) {
5058     if (isunix) {
5059       if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
5060         if (out) Safefree(out);
5061         PerlMem_free(esal);
5062         PerlMem_free(esa);
5063         if (outbufl != NULL)
5064             PerlMem_free(outbufl);
5065         return NULL;
5066       }
5067     }
5068     else strcpy(outbuf,esa);
5069   }
5070   else if (isunix) {
5071     tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5072     if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5073     if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
5074         if (out) Safefree(out);
5075         PerlMem_free(esa);
5076         PerlMem_free(esal);
5077         PerlMem_free(tmpfspec);
5078         if (outbufl != NULL)
5079             PerlMem_free(outbufl);
5080         return NULL;
5081     }
5082     strcpy(outbuf,tmpfspec);
5083     PerlMem_free(tmpfspec);
5084   }
5085
5086   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5087   sts = rms_free_search_context(&myfab); /* Free search context */
5088   PerlMem_free(esa);
5089   PerlMem_free(esal);
5090   if (outbufl != NULL)
5091      PerlMem_free(outbufl);
5092   return outbuf;
5093 }
5094 /*}}}*/
5095 /* External entry points */
5096 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5097 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5098 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5099 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5100 char *Perl_rmsexpand_utf8
5101   (pTHX_ const char *spec, char *buf, const char *def,
5102    unsigned opt, int * fs_utf8, int * dfs_utf8)
5103 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5104 char *Perl_rmsexpand_utf8_ts
5105   (pTHX_ const char *spec, char *buf, const char *def,
5106    unsigned opt, int * fs_utf8, int * dfs_utf8)
5107 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5108
5109
5110 /*
5111 ** The following routines are provided to make life easier when
5112 ** converting among VMS-style and Unix-style directory specifications.
5113 ** All will take input specifications in either VMS or Unix syntax. On
5114 ** failure, all return NULL.  If successful, the routines listed below
5115 ** return a pointer to a buffer containing the appropriately
5116 ** reformatted spec (and, therefore, subsequent calls to that routine
5117 ** will clobber the result), while the routines of the same names with
5118 ** a _ts suffix appended will return a pointer to a mallocd string
5119 ** containing the appropriately reformatted spec.
5120 ** In all cases, only explicit syntax is altered; no check is made that
5121 ** the resulting string is valid or that the directory in question
5122 ** actually exists.
5123 **
5124 **   fileify_dirspec() - convert a directory spec into the name of the
5125 **     directory file (i.e. what you can stat() to see if it's a dir).
5126 **     The style (VMS or Unix) of the result is the same as the style
5127 **     of the parameter passed in.
5128 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5129 **     what you prepend to a filename to indicate what directory it's in).
5130 **     The style (VMS or Unix) of the result is the same as the style
5131 **     of the parameter passed in.
5132 **   tounixpath() - convert a directory spec into a Unix-style path.
5133 **   tovmspath() - convert a directory spec into a VMS-style path.
5134 **   tounixspec() - convert any file spec into a Unix-style file spec.
5135 **   tovmsspec() - convert any file spec into a VMS-style spec.
5136 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5137 **
5138 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5139 ** Permission is given to distribute this code as part of the Perl
5140 ** standard distribution under the terms of the GNU General Public
5141 ** License or the Perl Artistic License.  Copies of each may be
5142 ** found in the Perl standard distribution.
5143  */
5144
5145 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5146 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5147 {
5148     static char __fileify_retbuf[VMS_MAXRSS];
5149     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5150     char *retspec, *cp1, *cp2, *lastdir;
5151     char *trndir, *vmsdir;
5152     unsigned short int trnlnm_iter_count;
5153     int sts;
5154     if (utf8_fl != NULL)
5155         *utf8_fl = 0;
5156
5157     if (!dir || !*dir) {
5158       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5159     }
5160     dirlen = strlen(dir);
5161     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5162     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5163       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5164         dir = "/sys$disk";
5165         dirlen = 9;
5166       }
5167       else
5168         dirlen = 1;
5169     }
5170     if (dirlen > (VMS_MAXRSS - 1)) {
5171       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5172       return NULL;
5173     }
5174     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5175     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5176     if (!strpbrk(dir+1,"/]>:")  &&
5177         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5178       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5179       trnlnm_iter_count = 0;
5180       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
5181         trnlnm_iter_count++;
5182         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5183       }
5184       dirlen = strlen(trndir);
5185     }
5186     else {
5187       strncpy(trndir,dir,dirlen);
5188       trndir[dirlen] = '\0';
5189     }
5190
5191     /* At this point we are done with *dir and use *trndir which is a
5192      * copy that can be modified.  *dir must not be modified.
5193      */
5194
5195     /* If we were handed a rooted logical name or spec, treat it like a
5196      * simple directory, so that
5197      *    $ Define myroot dev:[dir.]
5198      *    ... do_fileify_dirspec("myroot",buf,1) ...
5199      * does something useful.
5200      */
5201     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5202       trndir[--dirlen] = '\0';
5203       trndir[dirlen-1] = ']';
5204     }
5205     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5206       trndir[--dirlen] = '\0';
5207       trndir[dirlen-1] = '>';
5208     }
5209
5210     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5211       /* If we've got an explicit filename, we can just shuffle the string. */
5212       if (*(cp1+1)) hasfilename = 1;
5213       /* Similarly, we can just back up a level if we've got multiple levels
5214          of explicit directories in a VMS spec which ends with directories. */
5215       else {
5216         for (cp2 = cp1; cp2 > trndir; cp2--) {
5217           if (*cp2 == '.') {
5218             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5219 /* fix-me, can not scan EFS file specs backward like this */
5220               *cp2 = *cp1; *cp1 = '\0';
5221               hasfilename = 1;
5222               break;
5223             }
5224           }
5225           if (*cp2 == '[' || *cp2 == '<') break;
5226         }
5227       }
5228     }
5229
5230     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5231     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5232     cp1 = strpbrk(trndir,"]:>");
5233     if (hasfilename || !cp1) { /* Unix-style path or filename */
5234       if (trndir[0] == '.') {
5235         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5236           PerlMem_free(trndir);
5237           PerlMem_free(vmsdir);
5238           return do_fileify_dirspec("[]",buf,ts,NULL);
5239         }
5240         else if (trndir[1] == '.' &&
5241                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5242           PerlMem_free(trndir);
5243           PerlMem_free(vmsdir);
5244           return do_fileify_dirspec("[-]",buf,ts,NULL);
5245         }
5246       }
5247       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5248         dirlen -= 1;                 /* to last element */
5249         lastdir = strrchr(trndir,'/');
5250       }
5251       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5252         /* If we have "/." or "/..", VMSify it and let the VMS code
5253          * below expand it, rather than repeating the code to handle
5254          * relative components of a filespec here */
5255         do {
5256           if (*(cp1+2) == '.') cp1++;
5257           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5258             char * ret_chr;
5259             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5260                 PerlMem_free(trndir);
5261                 PerlMem_free(vmsdir);
5262                 return NULL;
5263             }
5264             if (strchr(vmsdir,'/') != NULL) {
5265               /* If do_tovmsspec() returned it, it must have VMS syntax
5266                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5267                * the time to check this here only so we avoid a recursion
5268                * loop; otherwise, gigo.
5269                */
5270               PerlMem_free(trndir);
5271               PerlMem_free(vmsdir);
5272               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5273               return NULL;
5274             }
5275             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5276                 PerlMem_free(trndir);
5277                 PerlMem_free(vmsdir);
5278                 return NULL;
5279             }
5280             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5281             PerlMem_free(trndir);
5282             PerlMem_free(vmsdir);
5283             return ret_chr;
5284           }
5285           cp1++;
5286         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5287         lastdir = strrchr(trndir,'/');
5288       }
5289       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5290         char * ret_chr;
5291         /* Ditto for specs that end in an MFD -- let the VMS code
5292          * figure out whether it's a real device or a rooted logical. */
5293
5294         /* This should not happen any more.  Allowing the fake /000000
5295          * in a UNIX pathname causes all sorts of problems when trying
5296          * to run in UNIX emulation.  So the VMS to UNIX conversions
5297          * now remove the fake /000000 directories.
5298          */
5299
5300         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5301         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5302             PerlMem_free(trndir);
5303             PerlMem_free(vmsdir);
5304             return NULL;
5305         }
5306         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5307             PerlMem_free(trndir);
5308             PerlMem_free(vmsdir);
5309             return NULL;
5310         }
5311         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5312         PerlMem_free(trndir);
5313         PerlMem_free(vmsdir);
5314         return ret_chr;
5315       }
5316       else {
5317
5318         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5319              !(lastdir = cp1 = strrchr(trndir,']')) &&
5320              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5321         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5322           int ver; char *cp3;
5323
5324           /* For EFS or ODS-5 look for the last dot */
5325           if (decc_efs_charset) {
5326               cp2 = strrchr(cp1,'.');
5327           }
5328           if (vms_process_case_tolerant) {
5329               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5330                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5331                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5332                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5333                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5334                             (ver || *cp3)))))) {
5335                   PerlMem_free(trndir);
5336                   PerlMem_free(vmsdir);
5337                   set_errno(ENOTDIR);
5338                   set_vaxc_errno(RMS$_DIR);
5339                   return NULL;
5340               }
5341           }
5342           else {
5343               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5344                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5345                   !*(cp2+3) || *(cp2+3) != 'R' ||
5346                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5347                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5348                             (ver || *cp3)))))) {
5349                  PerlMem_free(trndir);
5350                  PerlMem_free(vmsdir);
5351                  set_errno(ENOTDIR);
5352                  set_vaxc_errno(RMS$_DIR);
5353                  return NULL;
5354               }
5355           }
5356           dirlen = cp2 - trndir;
5357         }
5358       }
5359
5360       retlen = dirlen + 6;
5361       if (buf) retspec = buf;
5362       else if (ts) Newx(retspec,retlen+1,char);
5363       else retspec = __fileify_retbuf;
5364       memcpy(retspec,trndir,dirlen);
5365       retspec[dirlen] = '\0';
5366
5367       /* We've picked up everything up to the directory file name.
5368          Now just add the type and version, and we're set. */
5369       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5370         strcat(retspec,".dir;1");
5371       else
5372         strcat(retspec,".DIR;1");
5373       PerlMem_free(trndir);
5374       PerlMem_free(vmsdir);
5375       return retspec;
5376     }
5377     else {  /* VMS-style directory spec */
5378
5379       char *esa, term, *cp;
5380       unsigned long int sts, cmplen, haslower = 0;
5381       unsigned int nam_fnb;
5382       char * nam_type;
5383       struct FAB dirfab = cc$rms_fab;
5384       rms_setup_nam(savnam);
5385       rms_setup_nam(dirnam);
5386
5387       esa = PerlMem_malloc(VMS_MAXRSS + 1);
5388       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5389       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5390       rms_bind_fab_nam(dirfab, dirnam);
5391       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5392       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5393 #ifdef NAM$M_NO_SHORT_UPCASE
5394       if (decc_efs_case_preserve)
5395         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5396 #endif
5397
5398       for (cp = trndir; *cp; cp++)
5399         if (islower(*cp)) { haslower = 1; break; }
5400       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5401         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5402           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5403           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5404         }
5405         if (!sts) {
5406           PerlMem_free(esa);
5407           PerlMem_free(trndir);
5408           PerlMem_free(vmsdir);
5409           set_errno(EVMSERR);
5410           set_vaxc_errno(dirfab.fab$l_sts);
5411           return NULL;
5412         }
5413       }
5414       else {
5415         savnam = dirnam;
5416         /* Does the file really exist? */
5417         if (sys$search(&dirfab)& STS$K_SUCCESS) {
5418           /* Yes; fake the fnb bits so we'll check type below */
5419         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5420         }
5421         else { /* No; just work with potential name */
5422           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5423           else {
5424             int fab_sts;
5425             fab_sts = dirfab.fab$l_sts;
5426             sts = rms_free_search_context(&dirfab);
5427             PerlMem_free(esa);
5428             PerlMem_free(trndir);
5429             PerlMem_free(vmsdir);
5430             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
5431             return NULL;
5432           }
5433         }
5434       }
5435       esa[rms_nam_esll(dirnam)] = '\0';
5436       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5437         cp1 = strchr(esa,']');
5438         if (!cp1) cp1 = strchr(esa,'>');
5439         if (cp1) {  /* Should always be true */
5440           rms_nam_esll(dirnam) -= cp1 - esa - 1;
5441           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5442         }
5443       }
5444       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5445         /* Yep; check version while we're at it, if it's there. */
5446         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5447         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5448           /* Something other than .DIR[;1].  Bzzt. */
5449           sts = rms_free_search_context(&dirfab);
5450           PerlMem_free(esa);
5451           PerlMem_free(trndir);
5452           PerlMem_free(vmsdir);
5453           set_errno(ENOTDIR);
5454           set_vaxc_errno(RMS$_DIR);
5455           return NULL;
5456         }
5457       }
5458
5459       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5460         /* They provided at least the name; we added the type, if necessary, */
5461         if (buf) retspec = buf;                            /* in sys$parse() */
5462         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5463         else retspec = __fileify_retbuf;
5464         strcpy(retspec,esa);
5465         sts = rms_free_search_context(&dirfab);
5466         PerlMem_free(trndir);
5467         PerlMem_free(esa);
5468         PerlMem_free(vmsdir);
5469         return retspec;
5470       }
5471       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5472         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5473         *cp1 = '\0';
5474         rms_nam_esll(dirnam) -= 9;
5475       }
5476       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5477       if (cp1 == NULL) { /* should never happen */
5478         sts = rms_free_search_context(&dirfab);
5479         PerlMem_free(trndir);
5480         PerlMem_free(esa);
5481         PerlMem_free(vmsdir);
5482         return NULL;
5483       }
5484       term = *cp1;
5485       *cp1 = '\0';
5486       retlen = strlen(esa);
5487       cp1 = strrchr(esa,'.');
5488       /* ODS-5 directory specifications can have extra "." in them. */
5489       /* Fix-me, can not scan EFS file specifications backwards */
5490       while (cp1 != NULL) {
5491         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5492           break;
5493         else {
5494            cp1--;
5495            while ((cp1 > esa) && (*cp1 != '.'))
5496              cp1--;
5497         }
5498         if (cp1 == esa)
5499           cp1 = NULL;
5500       }
5501
5502       if ((cp1) != NULL) {
5503         /* There's more than one directory in the path.  Just roll back. */
5504         *cp1 = term;
5505         if (buf) retspec = buf;
5506         else if (ts) Newx(retspec,retlen+7,char);
5507         else retspec = __fileify_retbuf;
5508         strcpy(retspec,esa);
5509       }
5510       else {
5511         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5512           /* Go back and expand rooted logical name */
5513           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5514 #ifdef NAM$M_NO_SHORT_UPCASE
5515           if (decc_efs_case_preserve)
5516             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5517 #endif
5518           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5519             sts = rms_free_search_context(&dirfab);
5520             PerlMem_free(esa);
5521             PerlMem_free(trndir);
5522             PerlMem_free(vmsdir);
5523             set_errno(EVMSERR);
5524             set_vaxc_errno(dirfab.fab$l_sts);
5525             return NULL;
5526           }
5527           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5528           if (buf) retspec = buf;
5529           else if (ts) Newx(retspec,retlen+16,char);
5530           else retspec = __fileify_retbuf;
5531           cp1 = strstr(esa,"][");
5532           if (!cp1) cp1 = strstr(esa,"]<");
5533           dirlen = cp1 - esa;
5534           memcpy(retspec,esa,dirlen);
5535           if (!strncmp(cp1+2,"000000]",7)) {
5536             retspec[dirlen-1] = '\0';
5537             /* fix-me Not full ODS-5, just extra dots in directories for now */
5538             cp1 = retspec + dirlen - 1;
5539             while (cp1 > retspec)
5540             {
5541               if (*cp1 == '[')
5542                 break;
5543               if (*cp1 == '.') {
5544                 if (*(cp1-1) != '^')
5545                   break;
5546               }
5547               cp1--;
5548             }
5549             if (*cp1 == '.') *cp1 = ']';
5550             else {
5551               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5552               memmove(cp1+1,"000000]",7);
5553             }
5554           }
5555           else {
5556             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5557             retspec[retlen] = '\0';
5558             /* Convert last '.' to ']' */
5559             cp1 = retspec+retlen-1;
5560             while (*cp != '[') {
5561               cp1--;
5562               if (*cp1 == '.') {
5563                 /* Do not trip on extra dots in ODS-5 directories */
5564                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5565                 break;
5566               }
5567             }
5568             if (*cp1 == '.') *cp1 = ']';
5569             else {
5570               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5571               memmove(cp1+1,"000000]",7);
5572             }
5573           }
5574         }
5575         else {  /* This is a top-level dir.  Add the MFD to the path. */
5576           if (buf) retspec = buf;
5577           else if (ts) Newx(retspec,retlen+16,char);
5578           else retspec = __fileify_retbuf;
5579           cp1 = esa;
5580           cp2 = retspec;
5581           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5582           strcpy(cp2,":[000000]");
5583           cp1 += 2;
5584           strcpy(cp2+9,cp1);
5585         }
5586       }
5587       sts = rms_free_search_context(&dirfab);
5588       /* We've set up the string up through the filename.  Add the
5589          type and version, and we're done. */
5590       strcat(retspec,".DIR;1");
5591
5592       /* $PARSE may have upcased filespec, so convert output to lower
5593        * case if input contained any lowercase characters. */
5594       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5595       PerlMem_free(trndir);
5596       PerlMem_free(esa);
5597       PerlMem_free(vmsdir);
5598       return retspec;
5599     }
5600 }  /* end of do_fileify_dirspec() */
5601 /*}}}*/
5602 /* External entry points */
5603 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5604 { return do_fileify_dirspec(dir,buf,0,NULL); }
5605 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5606 { return do_fileify_dirspec(dir,buf,1,NULL); }
5607 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5608 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5609 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5610 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5611
5612 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5613 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5614 {
5615     static char __pathify_retbuf[VMS_MAXRSS];
5616     unsigned long int retlen;
5617     char *retpath, *cp1, *cp2, *trndir;
5618     unsigned short int trnlnm_iter_count;
5619     STRLEN trnlen;
5620     int sts;
5621     if (utf8_fl != NULL)
5622         *utf8_fl = 0;
5623
5624     if (!dir || !*dir) {
5625       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5626     }
5627
5628     trndir = PerlMem_malloc(VMS_MAXRSS);
5629     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5630     if (*dir) strcpy(trndir,dir);
5631     else getcwd(trndir,VMS_MAXRSS - 1);
5632
5633     trnlnm_iter_count = 0;
5634     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5635            && my_trnlnm(trndir,trndir,0)) {
5636       trnlnm_iter_count++;
5637       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5638       trnlen = strlen(trndir);
5639
5640       /* Trap simple rooted lnms, and return lnm:[000000] */
5641       if (!strcmp(trndir+trnlen-2,".]")) {
5642         if (buf) retpath = buf;
5643         else if (ts) Newx(retpath,strlen(dir)+10,char);
5644         else retpath = __pathify_retbuf;
5645         strcpy(retpath,dir);
5646         strcat(retpath,":[000000]");
5647         PerlMem_free(trndir);
5648         return retpath;
5649       }
5650     }
5651
5652     /* At this point we do not work with *dir, but the copy in
5653      * *trndir that is modifiable.
5654      */
5655
5656     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5657       if (*trndir == '.' && (*(trndir+1) == '\0' ||
5658                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5659         retlen = 2 + (*(trndir+1) != '\0');
5660       else {
5661         if ( !(cp1 = strrchr(trndir,'/')) &&
5662              !(cp1 = strrchr(trndir,']')) &&
5663              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5664         if ((cp2 = strchr(cp1,'.')) != NULL &&
5665             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
5666              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
5667               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5668               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5669           int ver; char *cp3;
5670
5671           /* For EFS or ODS-5 look for the last dot */
5672           if (decc_efs_charset) {
5673             cp2 = strrchr(cp1,'.');
5674           }
5675           if (vms_process_case_tolerant) {
5676               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5677                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5678                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5679                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5680                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5681                             (ver || *cp3)))))) {
5682                 PerlMem_free(trndir);
5683                 set_errno(ENOTDIR);
5684                 set_vaxc_errno(RMS$_DIR);
5685                 return NULL;
5686               }
5687           }
5688           else {
5689               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5690                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5691                   !*(cp2+3) || *(cp2+3) != 'R' ||
5692                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5693                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5694                             (ver || *cp3)))))) {
5695                 PerlMem_free(trndir);
5696                 set_errno(ENOTDIR);
5697                 set_vaxc_errno(RMS$_DIR);
5698                 return NULL;
5699               }
5700           }
5701           retlen = cp2 - trndir + 1;
5702         }
5703         else {  /* No file type present.  Treat the filename as a directory. */
5704           retlen = strlen(trndir) + 1;
5705         }
5706       }
5707       if (buf) retpath = buf;
5708       else if (ts) Newx(retpath,retlen+1,char);
5709       else retpath = __pathify_retbuf;
5710       strncpy(retpath, trndir, retlen-1);
5711       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5712         retpath[retlen-1] = '/';      /* with '/', add it. */
5713         retpath[retlen] = '\0';
5714       }
5715       else retpath[retlen-1] = '\0';
5716     }
5717     else {  /* VMS-style directory spec */
5718       char *esa, *cp;
5719       unsigned long int sts, cmplen, haslower;
5720       struct FAB dirfab = cc$rms_fab;
5721       int dirlen;
5722       rms_setup_nam(savnam);
5723       rms_setup_nam(dirnam);
5724
5725       /* If we've got an explicit filename, we can just shuffle the string. */
5726       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5727              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
5728         if ((cp2 = strchr(cp1,'.')) != NULL) {
5729           int ver; char *cp3;
5730           if (vms_process_case_tolerant) {
5731               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5732                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5733                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5734                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5735                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5736                             (ver || *cp3)))))) {
5737                PerlMem_free(trndir);
5738                set_errno(ENOTDIR);
5739                set_vaxc_errno(RMS$_DIR);
5740                return NULL;
5741              }
5742           }
5743           else {
5744               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5745                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5746                   !*(cp2+3) || *(cp2+3) != 'R' ||
5747                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5748                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5749                             (ver || *cp3)))))) {
5750                PerlMem_free(trndir);
5751                set_errno(ENOTDIR);
5752                set_vaxc_errno(RMS$_DIR);
5753                return NULL;
5754              }
5755           }
5756         }
5757         else {  /* No file type, so just draw name into directory part */
5758           for (cp2 = cp1; *cp2; cp2++) ;
5759         }
5760         *cp2 = *cp1;
5761         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5762         *cp1 = '.';
5763         /* We've now got a VMS 'path'; fall through */
5764       }
5765
5766       dirlen = strlen(trndir);
5767       if (trndir[dirlen-1] == ']' ||
5768           trndir[dirlen-1] == '>' ||
5769           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5770         if (buf) retpath = buf;
5771         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5772         else retpath = __pathify_retbuf;
5773         strcpy(retpath,trndir);
5774         PerlMem_free(trndir);
5775         return retpath;
5776       }
5777       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5778       esa = PerlMem_malloc(VMS_MAXRSS);
5779       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5780       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5781       rms_bind_fab_nam(dirfab, dirnam);
5782       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5783 #ifdef NAM$M_NO_SHORT_UPCASE
5784       if (decc_efs_case_preserve)
5785           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5786 #endif
5787
5788       for (cp = trndir; *cp; cp++)
5789         if (islower(*cp)) { haslower = 1; break; }
5790
5791       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5792         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5793           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5794           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5795         }
5796         if (!sts) {
5797           PerlMem_free(trndir);
5798           PerlMem_free(esa);
5799           set_errno(EVMSERR);
5800           set_vaxc_errno(dirfab.fab$l_sts);
5801           return NULL;
5802         }
5803       }
5804       else {
5805         savnam = dirnam;
5806         /* Does the file really exist? */
5807         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5808           if (dirfab.fab$l_sts != RMS$_FNF) {
5809             int sts1;
5810             sts1 = rms_free_search_context(&dirfab);
5811             PerlMem_free(trndir);
5812             PerlMem_free(esa);
5813             set_errno(EVMSERR);
5814             set_vaxc_errno(dirfab.fab$l_sts);
5815             return NULL;
5816           }
5817           dirnam = savnam; /* No; just work with potential name */
5818         }
5819       }
5820       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5821         /* Yep; check version while we're at it, if it's there. */
5822         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5823         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5824           int sts2;
5825           /* Something other than .DIR[;1].  Bzzt. */
5826           sts2 = rms_free_search_context(&dirfab);
5827           PerlMem_free(trndir);
5828           PerlMem_free(esa);
5829           set_errno(ENOTDIR);
5830           set_vaxc_errno(RMS$_DIR);
5831           return NULL;
5832         }
5833       }
5834       /* OK, the type was fine.  Now pull any file name into the
5835          directory path. */
5836       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5837       else {
5838         cp1 = strrchr(esa,'>');
5839         *(rms_nam_typel(dirnam)) = '>';
5840       }
5841       *cp1 = '.';
5842       *(rms_nam_typel(dirnam) + 1) = '\0';
5843       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5844       if (buf) retpath = buf;
5845       else if (ts) Newx(retpath,retlen,char);
5846       else retpath = __pathify_retbuf;
5847       strcpy(retpath,esa);
5848       PerlMem_free(esa);
5849       sts = rms_free_search_context(&dirfab);
5850       /* $PARSE may have upcased filespec, so convert output to lower
5851        * case if input contained any lowercase characters. */
5852       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5853     }
5854
5855     PerlMem_free(trndir);
5856     return retpath;
5857 }  /* end of do_pathify_dirspec() */
5858 /*}}}*/
5859 /* External entry points */
5860 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5861 { return do_pathify_dirspec(dir,buf,0,NULL); }
5862 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5863 { return do_pathify_dirspec(dir,buf,1,NULL); }
5864 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5865 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5866 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5867 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5868
5869 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5870 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5871 {
5872   static char __tounixspec_retbuf[VMS_MAXRSS];
5873   char *dirend, *rslt, *cp1, *cp3, *tmp;
5874   const char *cp2;
5875   int devlen, dirlen, retlen = VMS_MAXRSS;
5876   int expand = 1; /* guarantee room for leading and trailing slashes */
5877   unsigned short int trnlnm_iter_count;
5878   int cmp_rslt;
5879   if (utf8_fl != NULL)
5880     *utf8_fl = 0;
5881
5882   if (spec == NULL) return NULL;
5883   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5884   if (buf) rslt = buf;
5885   else if (ts) {
5886     Newx(rslt, VMS_MAXRSS, char);
5887   }
5888   else rslt = __tounixspec_retbuf;
5889
5890   /* New VMS specific format needs translation
5891    * glob passes filenames with trailing '\n' and expects this preserved.
5892    */
5893   if (decc_posix_compliant_pathnames) {
5894     if (strncmp(spec, "\"^UP^", 5) == 0) {
5895       char * uspec;
5896       char *tunix;
5897       int tunix_len;
5898       int nl_flag;
5899
5900       tunix = PerlMem_malloc(VMS_MAXRSS);
5901       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5902       strcpy(tunix, spec);
5903       tunix_len = strlen(tunix);
5904       nl_flag = 0;
5905       if (tunix[tunix_len - 1] == '\n') {
5906         tunix[tunix_len - 1] = '\"';
5907         tunix[tunix_len] = '\0';
5908         tunix_len--;
5909         nl_flag = 1;
5910       }
5911       uspec = decc$translate_vms(tunix);
5912       PerlMem_free(tunix);
5913       if ((int)uspec > 0) {
5914         strcpy(rslt,uspec);
5915         if (nl_flag) {
5916           strcat(rslt,"\n");
5917         }
5918         else {
5919           /* If we can not translate it, makemaker wants as-is */
5920           strcpy(rslt, spec);
5921         }
5922         return rslt;
5923       }
5924     }
5925   }
5926
5927   cmp_rslt = 0; /* Presume VMS */
5928   cp1 = strchr(spec, '/');
5929   if (cp1 == NULL)
5930     cmp_rslt = 0;
5931
5932     /* Look for EFS ^/ */
5933     if (decc_efs_charset) {
5934       while (cp1 != NULL) {
5935         cp2 = cp1 - 1;
5936         if (*cp2 != '^') {
5937           /* Found illegal VMS, assume UNIX */
5938           cmp_rslt = 1;
5939           break;
5940         }
5941       cp1++;
5942       cp1 = strchr(cp1, '/');
5943     }
5944   }
5945
5946   /* Look for "." and ".." */
5947   if (decc_filename_unix_report) {
5948     if (spec[0] == '.') {
5949       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5950         cmp_rslt = 1;
5951       }
5952       else {
5953         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5954           cmp_rslt = 1;
5955         }
5956       }
5957     }
5958   }
5959   /* This is already UNIX or at least nothing VMS understands */
5960   if (cmp_rslt) {
5961     strcpy(rslt,spec);
5962     return rslt;
5963   }
5964
5965   cp1 = rslt;
5966   cp2 = spec;
5967   dirend = strrchr(spec,']');
5968   if (dirend == NULL) dirend = strrchr(spec,'>');
5969   if (dirend == NULL) dirend = strchr(spec,':');
5970   if (dirend == NULL) {
5971     strcpy(rslt,spec);
5972     return rslt;
5973   }
5974
5975   /* Special case 1 - sys$posix_root = / */
5976 #if __CRTL_VER >= 70000000
5977   if (!decc_disable_posix_root) {
5978     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5979       *cp1 = '/';
5980       cp1++;
5981       cp2 = cp2 + 15;
5982       }
5983   }
5984 #endif
5985
5986   /* Special case 2 - Convert NLA0: to /dev/null */
5987 #if __CRTL_VER < 70000000
5988   cmp_rslt = strncmp(spec,"NLA0:", 5);
5989   if (cmp_rslt != 0)
5990      cmp_rslt = strncmp(spec,"nla0:", 5);
5991 #else
5992   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5993 #endif
5994   if (cmp_rslt == 0) {
5995     strcpy(rslt, "/dev/null");
5996     cp1 = cp1 + 9;
5997     cp2 = cp2 + 5;
5998     if (spec[6] != '\0') {
5999       cp1[9] == '/';
6000       cp1++;
6001       cp2++;
6002     }
6003   }
6004
6005    /* Also handle special case "SYS$SCRATCH:" */
6006 #if __CRTL_VER < 70000000
6007   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6008   if (cmp_rslt != 0)
6009      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6010 #else
6011   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6012 #endif
6013   tmp = PerlMem_malloc(VMS_MAXRSS);
6014   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6015   if (cmp_rslt == 0) {
6016   int islnm;
6017
6018     islnm = my_trnlnm(tmp, "TMP", 0);
6019     if (!islnm) {
6020       strcpy(rslt, "/tmp");
6021       cp1 = cp1 + 4;
6022       cp2 = cp2 + 12;
6023       if (spec[12] != '\0') {
6024         cp1[4] == '/';
6025         cp1++;
6026         cp2++;
6027       }
6028     }
6029   }
6030
6031   if (*cp2 != '[' && *cp2 != '<') {
6032     *(cp1++) = '/';
6033   }
6034   else {  /* the VMS spec begins with directories */
6035     cp2++;
6036     if (*cp2 == ']' || *cp2 == '>') {
6037       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6038       PerlMem_free(tmp);
6039       return rslt;
6040     }
6041     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6042       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6043         if (ts) Safefree(rslt);
6044         PerlMem_free(tmp);
6045         return NULL;
6046       }
6047       trnlnm_iter_count = 0;
6048       do {
6049         cp3 = tmp;
6050         while (*cp3 != ':' && *cp3) cp3++;
6051         *(cp3++) = '\0';
6052         if (strchr(cp3,']') != NULL) break;
6053         trnlnm_iter_count++;
6054         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6055       } while (vmstrnenv(tmp,tmp,0,fildev,0));
6056       if (ts && !buf &&
6057           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6058         retlen = devlen + dirlen;
6059         Renew(rslt,retlen+1+2*expand,char);
6060         cp1 = rslt;
6061       }
6062       cp3 = tmp;
6063       *(cp1++) = '/';
6064       while (*cp3) {
6065         *(cp1++) = *(cp3++);
6066         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6067             PerlMem_free(tmp);
6068             return NULL; /* No room */
6069         }
6070       }
6071       *(cp1++) = '/';
6072     }
6073     if ((*cp2 == '^')) {
6074         /* EFS file escape, pass the next character as is */
6075         /* Fix me: HEX encoding for UNICODE not implemented */
6076         cp2++;
6077     }
6078     else if ( *cp2 == '.') {
6079       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6080         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6081         cp2 += 3;
6082       }
6083       else cp2++;
6084     }
6085   }
6086   PerlMem_free(tmp);
6087   for (; cp2 <= dirend; cp2++) {
6088     if ((*cp2 == '^')) {
6089         /* EFS file escape, pass the next character as is */
6090         /* Fix me: HEX encoding for UNICODE not implemented */
6091         cp2++;
6092         *(cp1++) = *cp2;
6093     }
6094     if (*cp2 == ':') {
6095       *(cp1++) = '/';
6096       if (*(cp2+1) == '[') cp2++;
6097     }
6098     else if (*cp2 == ']' || *cp2 == '>') {
6099       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6100     }
6101     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6102       *(cp1++) = '/';
6103       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6104         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6105                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6106         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6107             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6108       }
6109       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6110         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6111         cp2 += 2;
6112       }
6113     }
6114     else if (*cp2 == '-') {
6115       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6116         while (*cp2 == '-') {
6117           cp2++;
6118           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6119         }
6120         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6121           if (ts) Safefree(rslt);                        /* filespecs like */
6122           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
6123           return NULL;
6124         }
6125       }
6126       else *(cp1++) = *cp2;
6127     }
6128     else *(cp1++) = *cp2;
6129   }
6130   while (*cp2) *(cp1++) = *(cp2++);
6131   *cp1 = '\0';
6132
6133   /* This still leaves /000000/ when working with a
6134    * VMS device root or concealed root.
6135    */
6136   {
6137   int ulen;
6138   char * zeros;
6139
6140       ulen = strlen(rslt);
6141
6142       /* Get rid of "000000/ in rooted filespecs */
6143       if (ulen > 7) {
6144         zeros = strstr(rslt, "/000000/");
6145         if (zeros != NULL) {
6146           int mlen;
6147           mlen = ulen - (zeros - rslt) - 7;
6148           memmove(zeros, &zeros[7], mlen);
6149           ulen = ulen - 7;
6150           rslt[ulen] = '\0';
6151         }
6152       }
6153   }
6154
6155   return rslt;
6156
6157 }  /* end of do_tounixspec() */
6158 /*}}}*/
6159 /* External entry points */
6160 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6161   { return do_tounixspec(spec,buf,0, NULL); }
6162 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6163   { return do_tounixspec(spec,buf,1, NULL); }
6164 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6165   { return do_tounixspec(spec,buf,0, utf8_fl); }
6166 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6167   { return do_tounixspec(spec,buf,1, utf8_fl); }
6168
6169 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6170
6171 /*
6172  This procedure is used to identify if a path is based in either
6173  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6174  it returns the OpenVMS format directory for it.
6175
6176  It is expecting specifications of only '/' or '/xxxx/'
6177
6178  If a posix root does not exist, or 'xxxx' is not a directory
6179  in the posix root, it returns a failure.
6180
6181  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6182
6183  It is used only internally by posix_to_vmsspec_hardway().
6184  */
6185
6186 static int posix_root_to_vms
6187   (char *vmspath, int vmspath_len,
6188    const char *unixpath,
6189    const int * utf8_fl) {
6190 int sts;
6191 struct FAB myfab = cc$rms_fab;
6192 struct NAML mynam = cc$rms_naml;
6193 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6194  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6195 char *esa;
6196 char *vms_delim;
6197 int dir_flag;
6198 int unixlen;
6199
6200     dir_flag = 0;
6201     unixlen = strlen(unixpath);
6202     if (unixlen == 0) {
6203       vmspath[0] = '\0';
6204       return RMS$_FNF;
6205     }
6206
6207 #if __CRTL_VER >= 80200000
6208   /* If not a posix spec already, convert it */
6209   if (decc_posix_compliant_pathnames) {
6210     if (strncmp(unixpath,"\"^UP^",5) != 0) {
6211       sprintf(vmspath,"\"^UP^%s\"",unixpath);
6212     }
6213     else {
6214       /* This is already a VMS specification, no conversion */
6215       unixlen--;
6216       strncpy(vmspath,unixpath, vmspath_len);
6217     }
6218   }
6219   else
6220 #endif
6221   {
6222   int path_len;
6223   int i,j;
6224
6225      /* Check to see if this is under the POSIX root */
6226      if (decc_disable_posix_root) {
6227         return RMS$_FNF;
6228      }
6229
6230      /* Skip leading / */
6231      if (unixpath[0] == '/') {
6232         unixpath++;
6233         unixlen--;
6234      }
6235
6236
6237      strcpy(vmspath,"SYS$POSIX_ROOT:");
6238
6239      /* If this is only the / , or blank, then... */
6240      if (unixpath[0] == '\0') {
6241         /* by definition, this is the answer */
6242         return SS$_NORMAL;
6243      }
6244
6245      /* Need to look up a directory */
6246      vmspath[15] = '[';
6247      vmspath[16] = '\0';
6248
6249      /* Copy and add '^' escape characters as needed */
6250      j = 16;
6251      i = 0;
6252      while (unixpath[i] != 0) {
6253      int k;
6254
6255         j += copy_expand_unix_filename_escape
6256             (&vmspath[j], &unixpath[i], &k, utf8_fl);
6257         i += k;
6258      }
6259
6260      path_len = strlen(vmspath);
6261      if (vmspath[path_len - 1] == '/')
6262         path_len--;
6263      vmspath[path_len] = ']';
6264      path_len++;
6265      vmspath[path_len] = '\0';
6266
6267   }
6268   vmspath[vmspath_len] = 0;
6269   if (unixpath[unixlen - 1] == '/')
6270   dir_flag = 1;
6271   esa = PerlMem_malloc(VMS_MAXRSS);
6272   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6273   myfab.fab$l_fna = vmspath;
6274   myfab.fab$b_fns = strlen(vmspath);
6275   myfab.fab$l_naml = &mynam;
6276   mynam.naml$l_esa = NULL;
6277   mynam.naml$b_ess = 0;
6278   mynam.naml$l_long_expand = esa;
6279   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6280   mynam.naml$l_rsa = NULL;
6281   mynam.naml$b_rss = 0;
6282   if (decc_efs_case_preserve)
6283     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6284 #ifdef NAML$M_OPEN_SPECIAL
6285   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6286 #endif
6287
6288   /* Set up the remaining naml fields */
6289   sts = sys$parse(&myfab);
6290
6291   /* It failed! Try again as a UNIX filespec */
6292   if (!(sts & 1)) {
6293     PerlMem_free(esa);
6294     return sts;
6295   }
6296
6297    /* get the Device ID and the FID */
6298    sts = sys$search(&myfab);
6299    /* on any failure, returned the POSIX ^UP^ filespec */
6300    if (!(sts & 1)) {
6301       PerlMem_free(esa);
6302       return sts;
6303    }
6304    specdsc.dsc$a_pointer = vmspath;
6305    specdsc.dsc$w_length = vmspath_len;
6306
6307    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6308    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6309    sts = lib$fid_to_name
6310       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6311
6312   /* on any failure, returned the POSIX ^UP^ filespec */
6313   if (!(sts & 1)) {
6314      /* This can happen if user does not have permission to read directories */
6315      if (strncmp(unixpath,"\"^UP^",5) != 0)
6316        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6317      else
6318        strcpy(vmspath, unixpath);
6319   }
6320   else {
6321     vmspath[specdsc.dsc$w_length] = 0;
6322
6323     /* Are we expecting a directory? */
6324     if (dir_flag != 0) {
6325     int i;
6326     char *eptr;
6327
6328       eptr = NULL;
6329
6330       i = specdsc.dsc$w_length - 1;
6331       while (i > 0) {
6332       int zercnt;
6333         zercnt = 0;
6334         /* Version must be '1' */
6335         if (vmspath[i--] != '1')
6336           break;
6337         /* Version delimiter is one of ".;" */
6338         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6339           break;
6340         i--;
6341         if (vmspath[i--] != 'R')
6342           break;
6343         if (vmspath[i--] != 'I')
6344           break;
6345         if (vmspath[i--] != 'D')
6346           break;
6347         if (vmspath[i--] != '.')
6348           break;
6349         eptr = &vmspath[i+1];
6350         while (i > 0) {
6351           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6352             if (vmspath[i-1] != '^') {
6353               if (zercnt != 6) {
6354                 *eptr = vmspath[i];
6355                 eptr[1] = '\0';
6356                 vmspath[i] = '.';
6357                 break;
6358               }
6359               else {
6360                 /* Get rid of 6 imaginary zero directory filename */
6361                 vmspath[i+1] = '\0';
6362               }
6363             }
6364           }
6365           if (vmspath[i] == '0')
6366             zercnt++;
6367           else
6368             zercnt = 10;
6369           i--;
6370         }
6371         break;
6372       }
6373     }
6374   }
6375   PerlMem_free(esa);
6376   return sts;
6377 }
6378
6379 /* /dev/mumble needs to be handled special.
6380    /dev/null becomes NLA0:, And there is the potential for other stuff
6381    like /dev/tty which may need to be mapped to something.
6382 */
6383
6384 static int
6385 slash_dev_special_to_vms
6386    (const char * unixptr,
6387     char * vmspath,
6388     int vmspath_len)
6389 {
6390 char * nextslash;
6391 int len;
6392 int cmp;
6393 int islnm;
6394
6395     unixptr += 4;
6396     nextslash = strchr(unixptr, '/');
6397     len = strlen(unixptr);
6398     if (nextslash != NULL)
6399         len = nextslash - unixptr;
6400     cmp = strncmp("null", unixptr, 5);
6401     if (cmp == 0) {
6402         if (vmspath_len >= 6) {
6403             strcpy(vmspath, "_NLA0:");
6404             return SS$_NORMAL;
6405         }
6406     }
6407 }
6408
6409
6410 /* The built in routines do not understand perl's special needs, so
6411     doing a manual conversion from UNIX to VMS
6412
6413     If the utf8_fl is not null and points to a non-zero value, then
6414     treat 8 bit characters as UTF-8.
6415
6416     The sequence starting with '$(' and ending with ')' will be passed
6417     through with out interpretation instead of being escaped.
6418
6419   */
6420 static int posix_to_vmsspec_hardway
6421   (char *vmspath, int vmspath_len,
6422    const char *unixpath,
6423    int dir_flag,
6424    int * utf8_fl) {
6425
6426 char *esa;
6427 const char *unixptr;
6428 const char *unixend;
6429 char *vmsptr;
6430 const char *lastslash;
6431 const char *lastdot;
6432 int unixlen;
6433 int vmslen;
6434 int dir_start;
6435 int dir_dot;
6436 int quoted;
6437 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6438 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6439
6440   if (utf8_fl != NULL)
6441     *utf8_fl = 0;
6442
6443   unixptr = unixpath;
6444   dir_dot = 0;
6445
6446   /* Ignore leading "/" characters */
6447   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6448     unixptr++;
6449   }
6450   unixlen = strlen(unixptr);
6451
6452   /* Do nothing with blank paths */
6453   if (unixlen == 0) {
6454     vmspath[0] = '\0';
6455     return SS$_NORMAL;
6456   }
6457
6458   quoted = 0;
6459   /* This could have a "^UP^ on the front */
6460   if (strncmp(unixptr,"\"^UP^",5) == 0) {
6461     quoted = 1;
6462     unixptr+= 5;
6463     unixlen-= 5;
6464   }
6465
6466   lastslash = strrchr(unixptr,'/');
6467   lastdot = strrchr(unixptr,'.');
6468   unixend = strrchr(unixptr,'\"');
6469   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6470     unixend = unixptr + unixlen;
6471   }
6472
6473   /* last dot is last dot or past end of string */
6474   if (lastdot == NULL)
6475     lastdot = unixptr + unixlen;
6476
6477   /* if no directories, set last slash to beginning of string */
6478   if (lastslash == NULL) {
6479     lastslash = unixptr;
6480   }
6481   else {
6482     /* Watch out for trailing "." after last slash, still a directory */
6483     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6484       lastslash = unixptr + unixlen;
6485     }
6486
6487     /* Watch out for traiing ".." after last slash, still a directory */
6488     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6489       lastslash = unixptr + unixlen;
6490     }
6491
6492     /* dots in directories are aways escaped */
6493     if (lastdot < lastslash)
6494       lastdot = unixptr + unixlen;
6495   }
6496
6497   /* if (unixptr < lastslash) then we are in a directory */
6498
6499   dir_start = 0;
6500
6501   vmsptr = vmspath;
6502   vmslen = 0;
6503
6504   /* Start with the UNIX path */
6505   if (*unixptr != '/') {
6506     /* relative paths */
6507
6508     /* If allowing logical names on relative pathnames, then handle here */
6509     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6510         !decc_posix_compliant_pathnames) {
6511     char * nextslash;
6512     int seg_len;
6513     char * trn;
6514     int islnm;
6515
6516         /* Find the next slash */
6517         nextslash = strchr(unixptr,'/');
6518
6519         esa = PerlMem_malloc(vmspath_len);
6520         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6521
6522         trn = PerlMem_malloc(VMS_MAXRSS);
6523         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6524
6525         if (nextslash != NULL) {
6526
6527             seg_len = nextslash - unixptr;
6528             strncpy(esa, unixptr, seg_len);
6529             esa[seg_len] = 0;
6530         }
6531         else {
6532             strcpy(esa, unixptr);
6533             seg_len = strlen(unixptr);
6534         }
6535         /* trnlnm(section) */
6536         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6537
6538         if (islnm) {
6539             /* Now fix up the directory */
6540
6541             /* Split up the path to find the components */
6542             sts = vms_split_path
6543                   (trn,
6544                    &v_spec,
6545                    &v_len,
6546                    &r_spec,
6547                    &r_len,
6548                    &d_spec,
6549                    &d_len,
6550                    &n_spec,
6551                    &n_len,
6552                    &e_spec,
6553                    &e_len,
6554                    &vs_spec,
6555                    &vs_len);
6556
6557             while (sts == 0) {
6558             char * strt;
6559             int cmp;
6560
6561                 /* A logical name must be a directory  or the full
6562                    specification.  It is only a full specification if
6563                    it is the only component */
6564                 if ((unixptr[seg_len] == '\0') ||
6565                     (unixptr[seg_len+1] == '\0')) {
6566
6567                     /* Is a directory being required? */
6568                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6569                         /* Not a logical name */
6570                         break;
6571                     }
6572
6573
6574                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6575                         /* This must be a directory */
6576                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6577                             strcpy(vmsptr, esa);
6578                             vmslen=strlen(vmsptr);
6579                             vmsptr[vmslen] = ':';
6580                             vmslen++;
6581                             vmsptr[vmslen] = '\0';
6582                             return SS$_NORMAL;
6583                         }
6584                     }
6585
6586                 }
6587
6588
6589                 /* must be dev/directory - ignore version */
6590                 if ((n_len + e_len) != 0)
6591                     break;
6592
6593                 /* transfer the volume */
6594                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6595                     strncpy(vmsptr, v_spec, v_len);
6596                     vmsptr += v_len;
6597                     vmsptr[0] = '\0';
6598                     vmslen += v_len;
6599                 }
6600
6601                 /* unroot the rooted directory */
6602                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6603                     r_spec[0] = '[';
6604                     r_spec[r_len - 1] = ']';
6605
6606                     /* This should not be there, but nothing is perfect */
6607                     if (r_len > 9) {
6608                         cmp = strcmp(&r_spec[1], "000000.");
6609                         if (cmp == 0) {
6610                             r_spec += 7;
6611                             r_spec[7] = '[';
6612                             r_len -= 7;
6613                             if (r_len == 2)
6614                                 r_len = 0;
6615                         }
6616                     }
6617                     if (r_len > 0) {
6618                         strncpy(vmsptr, r_spec, r_len);
6619                         vmsptr += r_len;
6620                         vmslen += r_len;
6621                         vmsptr[0] = '\0';
6622                     }
6623                 }
6624                 /* Bring over the directory. */
6625                 if ((d_len > 0) &&
6626                     ((d_len + vmslen) < vmspath_len)) {
6627                     d_spec[0] = '[';
6628                     d_spec[d_len - 1] = ']';
6629                     if (d_len > 9) {
6630                         cmp = strcmp(&d_spec[1], "000000.");
6631                         if (cmp == 0) {
6632                             d_spec += 7;
6633                             d_spec[7] = '[';
6634                             d_len -= 7;
6635                             if (d_len == 2)
6636                                 d_len = 0;
6637                         }
6638                     }
6639
6640                     if (r_len > 0) {
6641                         /* Remove the redundant root */
6642                         if (r_len > 0) {
6643                             /* remove the ][ */
6644                             vmsptr--;
6645                             vmslen--;
6646                             d_spec++;
6647                             d_len--;
6648                         }
6649                         strncpy(vmsptr, d_spec, d_len);
6650                             vmsptr += d_len;
6651                             vmslen += d_len;
6652                             vmsptr[0] = '\0';
6653                     }
6654                 }
6655                 break;
6656             }
6657         }
6658
6659         PerlMem_free(esa);
6660         PerlMem_free(trn);
6661     }
6662
6663     if (lastslash > unixptr) {
6664     int dotdir_seen;
6665
6666       /* skip leading ./ */
6667       dotdir_seen = 0;
6668       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6669         dotdir_seen = 1;
6670         unixptr++;
6671         unixptr++;
6672       }
6673
6674       /* Are we still in a directory? */
6675       if (unixptr <= lastslash) {
6676         *vmsptr++ = '[';
6677         vmslen = 1;
6678         dir_start = 1;
6679
6680         /* if not backing up, then it is relative forward. */
6681         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6682               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6683           *vmsptr++ = '.';
6684           vmslen++;
6685           dir_dot = 1;
6686           }
6687        }
6688        else {
6689          if (dotdir_seen) {
6690            /* Perl wants an empty directory here to tell the difference
6691             * between a DCL commmand and a filename
6692             */
6693           *vmsptr++ = '[';
6694           *vmsptr++ = ']';
6695           vmslen = 2;
6696         }
6697       }
6698     }
6699     else {
6700       /* Handle two special files . and .. */
6701       if (unixptr[0] == '.') {
6702         if (&unixptr[1] == unixend) {
6703           *vmsptr++ = '[';
6704           *vmsptr++ = ']';
6705           vmslen += 2;
6706           *vmsptr++ = '\0';
6707           return SS$_NORMAL;
6708         }
6709         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6710           *vmsptr++ = '[';
6711           *vmsptr++ = '-';
6712           *vmsptr++ = ']';
6713           vmslen += 3;
6714           *vmsptr++ = '\0';
6715           return SS$_NORMAL;
6716         }
6717       }
6718     }
6719   }
6720   else {        /* Absolute PATH handling */
6721   int sts;
6722   char * nextslash;
6723   int seg_len;
6724     /* Need to find out where root is */
6725
6726     /* In theory, this procedure should never get an absolute POSIX pathname
6727      * that can not be found on the POSIX root.
6728      * In practice, that can not be relied on, and things will show up
6729      * here that are a VMS device name or concealed logical name instead.
6730      * So to make things work, this procedure must be tolerant.
6731      */
6732     esa = PerlMem_malloc(vmspath_len);
6733     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6734
6735     sts = SS$_NORMAL;
6736     nextslash = strchr(&unixptr[1],'/');
6737     seg_len = 0;
6738     if (nextslash != NULL) {
6739     int cmp;
6740       seg_len = nextslash - &unixptr[1];
6741       strncpy(vmspath, unixptr, seg_len + 1);
6742       vmspath[seg_len+1] = 0;
6743       cmp = 1;
6744       if (seg_len == 3) {
6745         cmp = strncmp(vmspath, "dev", 4);
6746         if (cmp == 0) {
6747             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6748             if (sts = SS$_NORMAL)
6749                 return SS$_NORMAL;
6750         }
6751       }
6752       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6753     }
6754
6755     if ($VMS_STATUS_SUCCESS(sts)) {
6756       /* This is verified to be a real path */
6757
6758       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6759       if ($VMS_STATUS_SUCCESS(sts)) {
6760         strcpy(vmspath, esa);
6761         vmslen = strlen(vmspath);
6762         vmsptr = vmspath + vmslen;
6763         unixptr++;
6764         if (unixptr < lastslash) {
6765         char * rptr;
6766           vmsptr--;
6767           *vmsptr++ = '.';
6768           dir_start = 1;
6769           dir_dot = 1;
6770           if (vmslen > 7) {
6771           int cmp;
6772             rptr = vmsptr - 7;
6773             cmp = strcmp(rptr,"000000.");
6774             if (cmp == 0) {
6775               vmslen -= 7;
6776               vmsptr -= 7;
6777               vmsptr[1] = '\0';
6778             } /* removing 6 zeros */
6779           } /* vmslen < 7, no 6 zeros possible */
6780         } /* Not in a directory */
6781       } /* Posix root found */
6782       else {
6783         /* No posix root, fall back to default directory */
6784         strcpy(vmspath, "SYS$DISK:[");
6785         vmsptr = &vmspath[10];
6786         vmslen = 10;
6787         if (unixptr > lastslash) {
6788            *vmsptr = ']';
6789            vmsptr++;
6790            vmslen++;
6791         }
6792         else {
6793            dir_start = 1;
6794         }
6795       }
6796     } /* end of verified real path handling */
6797     else {
6798     int add_6zero;
6799     int islnm;
6800
6801       /* Ok, we have a device or a concealed root that is not in POSIX
6802        * or we have garbage.  Make the best of it.
6803        */
6804
6805       /* Posix to VMS destroyed this, so copy it again */
6806       strncpy(vmspath, &unixptr[1], seg_len);
6807       vmspath[seg_len] = 0;
6808       vmslen = seg_len;
6809       vmsptr = &vmsptr[vmslen];
6810       islnm = 0;
6811
6812       /* Now do we need to add the fake 6 zero directory to it? */
6813       add_6zero = 1;
6814       if ((*lastslash == '/') && (nextslash < lastslash)) {
6815         /* No there is another directory */
6816         add_6zero = 0;
6817       }
6818       else {
6819       int trnend;
6820       int cmp;
6821
6822         /* now we have foo:bar or foo:[000000]bar to decide from */
6823         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6824
6825         if (!islnm && !decc_posix_compliant_pathnames) {
6826
6827             cmp = strncmp("bin", vmspath, 4);
6828             if (cmp == 0) {
6829                 /* bin => SYS$SYSTEM: */
6830                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6831             }
6832             else {
6833                 /* tmp => SYS$SCRATCH: */
6834                 cmp = strncmp("tmp", vmspath, 4);
6835                 if (cmp == 0) {
6836                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6837                 }
6838             }
6839         }
6840
6841         trnend = islnm ? islnm - 1 : 0;
6842
6843         /* if this was a logical name, ']' or '>' must be present */
6844         /* if not a logical name, then assume a device and hope. */
6845         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6846
6847         /* if log name and trailing '.' then rooted - treat as device */
6848         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6849
6850         /* Fix me, if not a logical name, a device lookup should be
6851          * done to see if the device is file structured.  If the device
6852          * is not file structured, the 6 zeros should not be put on.
6853          *
6854          * As it is, perl is occasionally looking for dev:[000000]tty.
6855          * which looks a little strange.
6856          *
6857          * Not that easy to detect as "/dev" may be file structured with
6858          * special device files.
6859          */
6860
6861         if ((add_6zero == 0) && (*nextslash == '/') &&
6862             (&nextslash[1] == unixend)) {
6863           /* No real directory present */
6864           add_6zero = 1;
6865         }
6866       }
6867
6868       /* Put the device delimiter on */
6869       *vmsptr++ = ':';
6870       vmslen++;
6871       unixptr = nextslash;
6872       unixptr++;
6873
6874       /* Start directory if needed */
6875       if (!islnm || add_6zero) {
6876         *vmsptr++ = '[';
6877         vmslen++;
6878         dir_start = 1;
6879       }
6880
6881       /* add fake 000000] if needed */
6882       if (add_6zero) {
6883         *vmsptr++ = '0';
6884         *vmsptr++ = '0';
6885         *vmsptr++ = '0';
6886         *vmsptr++ = '0';
6887         *vmsptr++ = '0';
6888         *vmsptr++ = '0';
6889         *vmsptr++ = ']';
6890         vmslen += 7;
6891         dir_start = 0;
6892       }
6893
6894     } /* non-POSIX translation */
6895     PerlMem_free(esa);
6896   } /* End of relative/absolute path handling */
6897
6898   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6899   int dash_flag;
6900   int in_cnt;
6901   int out_cnt;
6902
6903     dash_flag = 0;
6904
6905     if (dir_start != 0) {
6906
6907       /* First characters in a directory are handled special */
6908       while ((*unixptr == '/') ||
6909              ((*unixptr == '.') &&
6910               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6911                 (&unixptr[1]==unixend)))) {
6912       int loop_flag;
6913
6914         loop_flag = 0;
6915
6916         /* Skip redundant / in specification */
6917         while ((*unixptr == '/') && (dir_start != 0)) {
6918           loop_flag = 1;
6919           unixptr++;
6920           if (unixptr == lastslash)
6921             break;
6922         }
6923         if (unixptr == lastslash)
6924           break;
6925
6926         /* Skip redundant ./ characters */
6927         while ((*unixptr == '.') &&
6928                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6929           loop_flag = 1;
6930           unixptr++;
6931           if (unixptr == lastslash)
6932             break;
6933           if (*unixptr == '/')
6934             unixptr++;
6935         }
6936         if (unixptr == lastslash)
6937           break;
6938
6939         /* Skip redundant ../ characters */
6940         while ((*unixptr == '.') && (unixptr[1] == '.') &&
6941              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6942           /* Set the backing up flag */
6943           loop_flag = 1;
6944           dir_dot = 0;
6945           dash_flag = 1;
6946           *vmsptr++ = '-';
6947           vmslen++;
6948           unixptr++; /* first . */
6949           unixptr++; /* second . */
6950           if (unixptr == lastslash)
6951             break;
6952           if (*unixptr == '/') /* The slash */
6953             unixptr++;
6954         }
6955         if (unixptr == lastslash)
6956           break;
6957
6958         /* To do: Perl expects /.../ to be translated to [...] on VMS */
6959         /* Not needed when VMS is pretending to be UNIX. */
6960
6961         /* Is this loop stuck because of too many dots? */
6962         if (loop_flag == 0) {
6963           /* Exit the loop and pass the rest through */
6964           break;
6965         }
6966       }
6967
6968       /* Are we done with directories yet? */
6969       if (unixptr >= lastslash) {
6970
6971         /* Watch out for trailing dots */
6972         if (dir_dot != 0) {
6973             vmslen --;
6974             vmsptr--;
6975         }
6976         *vmsptr++ = ']';
6977         vmslen++;
6978         dash_flag = 0;
6979         dir_start = 0;
6980         if (*unixptr == '/')
6981           unixptr++;
6982       }
6983       else {
6984         /* Have we stopped backing up? */
6985         if (dash_flag) {
6986           *vmsptr++ = '.';
6987           vmslen++;
6988           dash_flag = 0;
6989           /* dir_start continues to be = 1 */
6990         }
6991         if (*unixptr == '-') {
6992           *vmsptr++ = '^';
6993           *vmsptr++ = *unixptr++;
6994           vmslen += 2;
6995           dir_start = 0;
6996
6997           /* Now are we done with directories yet? */
6998           if (unixptr >= lastslash) {
6999
7000             /* Watch out for trailing dots */
7001             if (dir_dot != 0) {
7002               vmslen --;
7003               vmsptr--;
7004             }
7005
7006             *vmsptr++ = ']';
7007             vmslen++;
7008             dash_flag = 0;
7009             dir_start = 0;
7010           }
7011         }
7012       }
7013     }
7014
7015     /* All done? */
7016     if (unixptr >= unixend)
7017       break;
7018
7019     /* Normal characters - More EFS work probably needed */
7020     dir_start = 0;
7021     dir_dot = 0;
7022
7023     switch(*unixptr) {
7024     case '/':
7025         /* remove multiple / */
7026         while (unixptr[1] == '/') {
7027            unixptr++;
7028         }
7029         if (unixptr == lastslash) {
7030           /* Watch out for trailing dots */
7031           if (dir_dot != 0) {
7032             vmslen --;
7033             vmsptr--;
7034           }
7035           *vmsptr++ = ']';
7036         }
7037         else {
7038           dir_start = 1;
7039           *vmsptr++ = '.';
7040           dir_dot = 1;
7041
7042           /* To do: Perl expects /.../ to be translated to [...] on VMS */
7043           /* Not needed when VMS is pretending to be UNIX. */
7044
7045         }
7046         dash_flag = 0;
7047         if (unixptr != unixend)
7048           unixptr++;
7049         vmslen++;
7050         break;
7051     case '.':
7052         if ((unixptr < lastdot) || (unixptr < lastslash) ||
7053             (&unixptr[1] == unixend)) {
7054           *vmsptr++ = '^';
7055           *vmsptr++ = '.';
7056           vmslen += 2;
7057           unixptr++;
7058
7059           /* trailing dot ==> '^..' on VMS */
7060           if (unixptr == unixend) {
7061             *vmsptr++ = '.';
7062             vmslen++;
7063             unixptr++;
7064           }
7065           break;
7066         }
7067
7068         *vmsptr++ = *unixptr++;
7069         vmslen ++;
7070         break;
7071     case '"':
7072         if (quoted && (&unixptr[1] == unixend)) {
7073             unixptr++;
7074             break;
7075         }
7076         in_cnt = copy_expand_unix_filename_escape
7077                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7078         vmsptr += out_cnt;
7079         unixptr += in_cnt;
7080         break;
7081     case '~':
7082     case ';':
7083     case '\\':
7084     case '?':
7085     case ' ':
7086     default:
7087         in_cnt = copy_expand_unix_filename_escape
7088                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7089         vmsptr += out_cnt;
7090         unixptr += in_cnt;
7091         break;
7092     }
7093   }
7094
7095   /* Make sure directory is closed */
7096   if (unixptr == lastslash) {
7097     char *vmsptr2;
7098     vmsptr2 = vmsptr - 1;
7099
7100     if (*vmsptr2 != ']') {
7101       *vmsptr2--;
7102
7103       /* directories do not end in a dot bracket */
7104       if (*vmsptr2 == '.') {
7105         vmsptr2--;
7106
7107         /* ^. is allowed */
7108         if (*vmsptr2 != '^') {
7109           vmsptr--; /* back up over the dot */
7110         }
7111       }
7112       *vmsptr++ = ']';
7113     }
7114   }
7115   else {
7116     char *vmsptr2;
7117     /* Add a trailing dot if a file with no extension */
7118     vmsptr2 = vmsptr - 1;
7119     if ((vmslen > 1) &&
7120         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7121         (*vmsptr2 != ')') && (*lastdot != '.')) {
7122         *vmsptr++ = '.';
7123         vmslen++;
7124     }
7125   }
7126
7127   *vmsptr = '\0';
7128   return SS$_NORMAL;
7129 }
7130 #endif
7131
7132  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7133 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7134 {
7135 char * result;
7136 int utf8_flag;
7137
7138    /* If a UTF8 flag is being passed, honor it */
7139    utf8_flag = 0;
7140    if (utf8_fl != NULL) {
7141      utf8_flag = *utf8_fl;
7142     *utf8_fl = 0;
7143    }
7144
7145    if (utf8_flag) {
7146      /* If there is a possibility of UTF8, then if any UTF8 characters
7147         are present, then they must be converted to VTF-7
7148       */
7149      result = strcpy(rslt, path); /* FIX-ME */
7150    }
7151    else
7152      result = strcpy(rslt, path);
7153
7154    return result;
7155 }
7156
7157
7158 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7159 static char *mp_do_tovmsspec
7160    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7161   static char __tovmsspec_retbuf[VMS_MAXRSS];
7162   char *rslt, *dirend;
7163   char *lastdot;
7164   char *vms_delim;
7165   register char *cp1;
7166   const char *cp2;
7167   unsigned long int infront = 0, hasdir = 1;
7168   int rslt_len;
7169   int no_type_seen;
7170   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7171   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7172
7173   if (path == NULL) return NULL;
7174   rslt_len = VMS_MAXRSS-1;
7175   if (buf) rslt = buf;
7176   else if (ts) Newx(rslt, VMS_MAXRSS, char);
7177   else rslt = __tovmsspec_retbuf;
7178
7179   /* '.' and '..' are "[]" and "[-]" for a quick check */
7180   if (path[0] == '.') {
7181     if (path[1] == '\0') {
7182       strcpy(rslt,"[]");
7183       if (utf8_flag != NULL)
7184         *utf8_flag = 0;
7185       return rslt;
7186     }
7187     else {
7188       if (path[1] == '.' && path[2] == '\0') {
7189         strcpy(rslt,"[-]");
7190         if (utf8_flag != NULL)
7191            *utf8_flag = 0;
7192         return rslt;
7193       }
7194     }
7195   }
7196
7197    /* Posix specifications are now a native VMS format */
7198   /*--------------------------------------------------*/
7199 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7200   if (decc_posix_compliant_pathnames) {
7201     if (strncmp(path,"\"^UP^",5) == 0) {
7202       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7203       return rslt;
7204     }
7205   }
7206 #endif
7207
7208   /* This is really the only way to see if this is already in VMS format */
7209   sts = vms_split_path
7210        (path,
7211         &v_spec,
7212         &v_len,
7213         &r_spec,
7214         &r_len,
7215         &d_spec,
7216         &d_len,
7217         &n_spec,
7218         &n_len,
7219         &e_spec,
7220         &e_len,
7221         &vs_spec,
7222         &vs_len);
7223   if (sts == 0) {
7224     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7225        replacement, because the above parse just took care of most of
7226        what is needed to do vmspath when the specification is already
7227        in VMS format.
7228
7229        And if it is not already, it is easier to do the conversion as
7230        part of this routine than to call this routine and then work on
7231        the result.
7232      */
7233
7234     /* If VMS punctuation was found, it is already VMS format */
7235     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7236       if (utf8_flag != NULL)
7237         *utf8_flag = 0;
7238       strcpy(rslt, path);
7239       return rslt;
7240     }
7241     /* Now, what to do with trailing "." cases where there is no
7242        extension?  If this is a UNIX specification, and EFS characters
7243        are enabled, then the trailing "." should be converted to a "^.".
7244        But if this was already a VMS specification, then it should be
7245        left alone.
7246
7247        So in the case of ambiguity, leave the specification alone.
7248      */
7249
7250
7251     /* If there is a possibility of UTF8, then if any UTF8 characters
7252         are present, then they must be converted to VTF-7
7253      */
7254     if (utf8_flag != NULL)
7255       *utf8_flag = 0;
7256     strcpy(rslt, path);
7257     return rslt;
7258   }
7259
7260   dirend = strrchr(path,'/');
7261
7262   if (dirend == NULL) {
7263      /* If we get here with no UNIX directory delimiters, then this is
7264         not a complete file specification, either garbage a UNIX glob
7265         specification that can not be converted to a VMS wildcard, or
7266         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7267         so apparently other programs expect this also.
7268
7269         utf8 flag setting needs to be preserved.
7270       */
7271       strcpy(rslt, path);
7272       return rslt;
7273   }
7274
7275 /* If POSIX mode active, handle the conversion */
7276 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7277   if (decc_efs_charset) {
7278     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7279     return rslt;
7280   }
7281 #endif
7282
7283   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7284     if (!*(dirend+2)) dirend +=2;
7285     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7286     if (decc_efs_charset == 0) {
7287       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7288     }
7289   }
7290
7291   cp1 = rslt;
7292   cp2 = path;
7293   lastdot = strrchr(cp2,'.');
7294   if (*cp2 == '/') {
7295     char *trndev;
7296     int islnm, rooted;
7297     STRLEN trnend;
7298
7299     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7300     if (!*(cp2+1)) {
7301       if (decc_disable_posix_root) {
7302         strcpy(rslt,"sys$disk:[000000]");
7303       }
7304       else {
7305         strcpy(rslt,"sys$posix_root:[000000]");
7306       }
7307       if (utf8_flag != NULL)
7308         *utf8_flag = 0;
7309       return rslt;
7310     }
7311     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7312     *cp1 = '\0';
7313     trndev = PerlMem_malloc(VMS_MAXRSS);
7314     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7315     islnm =  my_trnlnm(rslt,trndev,0);
7316
7317      /* DECC special handling */
7318     if (!islnm) {
7319       if (strcmp(rslt,"bin") == 0) {
7320         strcpy(rslt,"sys$system");
7321         cp1 = rslt + 10;
7322         *cp1 = 0;
7323         islnm =  my_trnlnm(rslt,trndev,0);
7324       }
7325       else if (strcmp(rslt,"tmp") == 0) {
7326         strcpy(rslt,"sys$scratch");
7327         cp1 = rslt + 11;
7328         *cp1 = 0;
7329         islnm =  my_trnlnm(rslt,trndev,0);
7330       }
7331       else if (!decc_disable_posix_root) {
7332         strcpy(rslt, "sys$posix_root");
7333         cp1 = rslt + 13;
7334         *cp1 = 0;
7335         cp2 = path;
7336         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7337         islnm =  my_trnlnm(rslt,trndev,0);
7338       }
7339       else if (strcmp(rslt,"dev") == 0) {
7340         if (strncmp(cp2,"/null", 5) == 0) {
7341           if ((cp2[5] == 0) || (cp2[5] == '/')) {
7342             strcpy(rslt,"NLA0");
7343             cp1 = rslt + 4;
7344             *cp1 = 0;
7345             cp2 = cp2 + 5;
7346             islnm =  my_trnlnm(rslt,trndev,0);
7347           }
7348         }
7349       }
7350     }
7351
7352     trnend = islnm ? strlen(trndev) - 1 : 0;
7353     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7354     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7355     /* If the first element of the path is a logical name, determine
7356      * whether it has to be translated so we can add more directories. */
7357     if (!islnm || rooted) {
7358       *(cp1++) = ':';
7359       *(cp1++) = '[';
7360       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7361       else cp2++;
7362     }
7363     else {
7364       if (cp2 != dirend) {
7365         strcpy(rslt,trndev);
7366         cp1 = rslt + trnend;
7367         if (*cp2 != 0) {
7368           *(cp1++) = '.';
7369           cp2++;
7370         }
7371       }
7372       else {
7373         if (decc_disable_posix_root) {
7374           *(cp1++) = ':';
7375           hasdir = 0;
7376         }
7377       }
7378     }
7379     PerlMem_free(trndev);
7380   }
7381   else {
7382     *(cp1++) = '[';
7383     if (*cp2 == '.') {
7384       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7385         cp2 += 2;         /* skip over "./" - it's redundant */
7386         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
7387       }
7388       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7389         *(cp1++) = '-';                                 /* "../" --> "-" */
7390         cp2 += 3;
7391       }
7392       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7393                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7394         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7395         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7396         cp2 += 4;
7397       }
7398       else if ((cp2 != lastdot) || (lastdot < dirend)) {
7399         /* Escape the extra dots in EFS file specifications */
7400         *(cp1++) = '^';
7401       }
7402       if (cp2 > dirend) cp2 = dirend;
7403     }
7404     else *(cp1++) = '.';
7405   }
7406   for (; cp2 < dirend; cp2++) {
7407     if (*cp2 == '/') {
7408       if (*(cp2-1) == '/') continue;
7409       if (*(cp1-1) != '.') *(cp1++) = '.';
7410       infront = 0;
7411     }
7412     else if (!infront && *cp2 == '.') {
7413       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7414       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
7415       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7416         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7417         else if (*(cp1-2) == '[') *(cp1-1) = '-';
7418         else {  /* back up over previous directory name */
7419           cp1--;
7420           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7421           if (*(cp1-1) == '[') {
7422             memcpy(cp1,"000000.",7);
7423             cp1 += 7;
7424           }
7425         }
7426         cp2 += 2;
7427         if (cp2 == dirend) break;
7428       }
7429       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7430                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7431         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7432         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7433         if (!*(cp2+3)) {
7434           *(cp1++) = '.';  /* Simulate trailing '/' */
7435           cp2 += 2;  /* for loop will incr this to == dirend */
7436         }
7437         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
7438       }
7439       else {
7440         if (decc_efs_charset == 0)
7441           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
7442         else {
7443           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
7444           *(cp1++) = '.';
7445         }
7446       }
7447     }
7448     else {
7449       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
7450       if (*cp2 == '.') {
7451         if (decc_efs_charset == 0)
7452           *(cp1++) = '_';
7453         else {
7454           *(cp1++) = '^';
7455           *(cp1++) = '.';
7456         }
7457       }
7458       else                  *(cp1++) =  *cp2;
7459       infront = 1;
7460     }
7461   }
7462   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7463   if (hasdir) *(cp1++) = ']';
7464   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
7465   /* fixme for ODS5 */
7466   no_type_seen = 0;
7467   if (cp2 > lastdot)
7468     no_type_seen = 1;
7469   while (*cp2) {
7470     switch(*cp2) {
7471     case '?':
7472         if (decc_efs_charset == 0)
7473           *(cp1++) = '%';
7474         else
7475           *(cp1++) = '?';
7476         cp2++;
7477     case ' ':
7478         *(cp1)++ = '^';
7479         *(cp1)++ = '_';
7480         cp2++;
7481         break;
7482     case '.':
7483         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7484             decc_readdir_dropdotnotype) {
7485           *(cp1)++ = '^';
7486           *(cp1)++ = '.';
7487           cp2++;
7488
7489           /* trailing dot ==> '^..' on VMS */
7490           if (*cp2 == '\0') {
7491             *(cp1++) = '.';
7492             no_type_seen = 0;
7493           }
7494         }
7495         else {
7496           *(cp1++) = *(cp2++);
7497           no_type_seen = 0;
7498         }
7499         break;
7500     case '$':
7501          /* This could be a macro to be passed through */
7502         *(cp1++) = *(cp2++);
7503         if (*cp2 == '(') {
7504         const char * save_cp2;
7505         char * save_cp1;
7506         int is_macro;
7507
7508             /* paranoid check */
7509             save_cp2 = cp2;
7510             save_cp1 = cp1;
7511             is_macro = 0;
7512
7513             /* Test through */
7514             *(cp1++) = *(cp2++);
7515             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7516                 *(cp1++) = *(cp2++);
7517                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7518                     *(cp1++) = *(cp2++);
7519                 }
7520                 if (*cp2 == ')') {
7521                     *(cp1++) = *(cp2++);
7522                     is_macro = 1;
7523                 }
7524             }
7525             if (is_macro == 0) {
7526                 /* Not really a macro - never mind */
7527                 cp2 = save_cp2;
7528                 cp1 = save_cp1;
7529             }
7530         }
7531         break;
7532     case '\"':
7533     case '~':
7534     case '`':
7535     case '!':
7536     case '#':
7537     case '%':
7538     case '^':
7539     case '&':
7540     case '(':
7541     case ')':
7542     case '=':
7543     case '+':
7544     case '\'':
7545     case '@':
7546     case '[':
7547     case ']':
7548     case '{':
7549     case '}':
7550     case ':':
7551     case '\\':
7552     case '|':
7553     case '<':
7554     case '>':
7555         *(cp1++) = '^';
7556         *(cp1++) = *(cp2++);
7557         break;
7558     case ';':
7559         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7560          * which is wrong.  UNIX notation should be ".dir." unless
7561          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7562          * changing this behavior could break more things at this time.
7563          * efs character set effectively does not allow "." to be a version
7564          * delimiter as a further complication about changing this.
7565          */
7566         if (decc_filename_unix_report != 0) {
7567           *(cp1++) = '^';
7568         }
7569         *(cp1++) = *(cp2++);
7570         break;
7571     default:
7572         *(cp1++) = *(cp2++);
7573     }
7574   }
7575   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7576   char *lcp1;
7577     lcp1 = cp1;
7578     lcp1--;
7579      /* Fix me for "^]", but that requires making sure that you do
7580       * not back up past the start of the filename
7581       */
7582     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7583       *cp1++ = '.';
7584   }
7585   *cp1 = '\0';
7586
7587   if (utf8_flag != NULL)
7588     *utf8_flag = 0;
7589   return rslt;
7590
7591 }  /* end of do_tovmsspec() */
7592 /*}}}*/
7593 /* External entry points */
7594 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7595   { return do_tovmsspec(path,buf,0,NULL); }
7596 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7597   { return do_tovmsspec(path,buf,1,NULL); }
7598 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7599   { return do_tovmsspec(path,buf,0,utf8_fl); }
7600 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7601   { return do_tovmsspec(path,buf,1,utf8_fl); }
7602
7603 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7604 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7605   static char __tovmspath_retbuf[VMS_MAXRSS];
7606   int vmslen;
7607   char *pathified, *vmsified, *cp;
7608
7609   if (path == NULL) return NULL;
7610   pathified = PerlMem_malloc(VMS_MAXRSS);
7611   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7612   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7613     PerlMem_free(pathified);
7614     return NULL;
7615   }
7616
7617   vmsified = NULL;
7618   if (buf == NULL)
7619      Newx(vmsified, VMS_MAXRSS, char);
7620   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7621     PerlMem_free(pathified);
7622     if (vmsified) Safefree(vmsified);
7623     return NULL;
7624   }
7625   PerlMem_free(pathified);
7626   if (buf) {
7627     return buf;
7628   }
7629   else if (ts) {
7630     vmslen = strlen(vmsified);
7631     Newx(cp,vmslen+1,char);
7632     memcpy(cp,vmsified,vmslen);
7633     cp[vmslen] = '\0';
7634     Safefree(vmsified);
7635     return cp;
7636   }
7637   else {
7638     strcpy(__tovmspath_retbuf,vmsified);
7639     Safefree(vmsified);
7640     return __tovmspath_retbuf;
7641   }
7642
7643 }  /* end of do_tovmspath() */
7644 /*}}}*/
7645 /* External entry points */
7646 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7647   { return do_tovmspath(path,buf,0, NULL); }
7648 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7649   { return do_tovmspath(path,buf,1, NULL); }
7650 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7651   { return do_tovmspath(path,buf,0,utf8_fl); }
7652 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7653   { return do_tovmspath(path,buf,1,utf8_fl); }
7654
7655
7656 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7657 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7658   static char __tounixpath_retbuf[VMS_MAXRSS];
7659   int unixlen;
7660   char *pathified, *unixified, *cp;
7661
7662   if (path == NULL) return NULL;
7663   pathified = PerlMem_malloc(VMS_MAXRSS);
7664   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7665   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7666     PerlMem_free(pathified);
7667     return NULL;
7668   }
7669
7670   unixified = NULL;
7671   if (buf == NULL) {
7672       Newx(unixified, VMS_MAXRSS, char);
7673   }
7674   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7675     PerlMem_free(pathified);
7676     if (unixified) Safefree(unixified);
7677     return NULL;
7678   }
7679   PerlMem_free(pathified);
7680   if (buf) {
7681     return buf;
7682   }
7683   else if (ts) {
7684     unixlen = strlen(unixified);
7685     Newx(cp,unixlen+1,char);
7686     memcpy(cp,unixified,unixlen);
7687     cp[unixlen] = '\0';
7688     Safefree(unixified);
7689     return cp;
7690   }
7691   else {
7692     strcpy(__tounixpath_retbuf,unixified);
7693     Safefree(unixified);
7694     return __tounixpath_retbuf;
7695   }
7696
7697 }  /* end of do_tounixpath() */
7698 /*}}}*/
7699 /* External entry points */
7700 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7701   { return do_tounixpath(path,buf,0,NULL); }
7702 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7703   { return do_tounixpath(path,buf,1,NULL); }
7704 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7705   { return do_tounixpath(path,buf,0,utf8_fl); }
7706 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7707   { return do_tounixpath(path,buf,1,utf8_fl); }
7708
7709 /*
7710  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
7711  *
7712  *****************************************************************************
7713  *                                                                           *
7714  *  Copyright (C) 1989-1994 by                                               *
7715  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
7716  *                                                                           *
7717  *  Permission is hereby  granted for the reproduction of this software,     *
7718  *  on condition that this copyright notice is included in the reproduction, *
7719  *  and that such reproduction is not for purposes of profit or material     *
7720  *  gain.                                                                    *
7721  *                                                                           *
7722  *  27-Aug-1994 Modified for inclusion in perl5                              *
7723  *              by Charles Bailey  bailey@newman.upenn.edu                   *
7724  *****************************************************************************
7725  */
7726
7727 /*
7728  * getredirection() is intended to aid in porting C programs
7729  * to VMS (Vax-11 C).  The native VMS environment does not support
7730  * '>' and '<' I/O redirection, or command line wild card expansion,
7731  * or a command line pipe mechanism using the '|' AND background
7732  * command execution '&'.  All of these capabilities are provided to any
7733  * C program which calls this procedure as the first thing in the
7734  * main program.
7735  * The piping mechanism will probably work with almost any 'filter' type
7736  * of program.  With suitable modification, it may useful for other
7737  * portability problems as well.
7738  *
7739  * Author:  Mark Pizzolato      mark@infocomm.com
7740  */
7741 struct list_item
7742     {
7743     struct list_item *next;
7744     char *value;
7745     };
7746
7747 static void add_item(struct list_item **head,
7748                      struct list_item **tail,
7749                      char *value,
7750                      int *count);
7751
7752 static void mp_expand_wild_cards(pTHX_ char *item,
7753                                 struct list_item **head,
7754                                 struct list_item **tail,
7755                                 int *count);
7756
7757 static int background_process(pTHX_ int argc, char **argv);
7758
7759 static void pipe_and_fork(pTHX_ char **cmargv);
7760
7761 /*{{{ void getredirection(int *ac, char ***av)*/
7762 static void
7763 mp_getredirection(pTHX_ int *ac, char ***av)
7764 /*
7765  * Process vms redirection arg's.  Exit if any error is seen.
7766  * If getredirection() processes an argument, it is erased
7767  * from the vector.  getredirection() returns a new argc and argv value.
7768  * In the event that a background command is requested (by a trailing "&"),
7769  * this routine creates a background subprocess, and simply exits the program.
7770  *
7771  * Warning: do not try to simplify the code for vms.  The code
7772  * presupposes that getredirection() is called before any data is
7773  * read from stdin or written to stdout.
7774  *
7775  * Normal usage is as follows:
7776  *
7777  *      main(argc, argv)
7778  *      int             argc;
7779  *      char            *argv[];
7780  *      {
7781  *              getredirection(&argc, &argv);
7782  *      }
7783  */
7784 {
7785     int                 argc = *ac;     /* Argument Count         */
7786     char                **argv = *av;   /* Argument Vector        */
7787     char                *ap;            /* Argument pointer       */
7788     int                 j;              /* argv[] index           */
7789     int                 item_count = 0; /* Count of Items in List */
7790     struct list_item    *list_head = 0; /* First Item in List       */
7791     struct list_item    *list_tail;     /* Last Item in List        */
7792     char                *in = NULL;     /* Input File Name          */
7793     char                *out = NULL;    /* Output File Name         */
7794     char                *outmode = "w"; /* Mode to Open Output File */
7795     char                *err = NULL;    /* Error File Name          */
7796     char                *errmode = "w"; /* Mode to Open Error File  */
7797     int                 cmargc = 0;     /* Piped Command Arg Count  */
7798     char                **cmargv = NULL;/* Piped Command Arg Vector */
7799
7800     /*
7801      * First handle the case where the last thing on the line ends with
7802      * a '&'.  This indicates the desire for the command to be run in a
7803      * subprocess, so we satisfy that desire.
7804      */
7805     ap = argv[argc-1];
7806     if (0 == strcmp("&", ap))
7807        exit(background_process(aTHX_ --argc, argv));
7808     if (*ap && '&' == ap[strlen(ap)-1])
7809         {
7810         ap[strlen(ap)-1] = '\0';
7811        exit(background_process(aTHX_ argc, argv));
7812         }
7813     /*
7814      * Now we handle the general redirection cases that involve '>', '>>',
7815      * '<', and pipes '|'.
7816      */
7817     for (j = 0; j < argc; ++j)
7818         {
7819         if (0 == strcmp("<", argv[j]))
7820             {
7821             if (j+1 >= argc)
7822                 {
7823                 fprintf(stderr,"No input file after < on command line");
7824                 exit(LIB$_WRONUMARG);
7825                 }
7826             in = argv[++j];
7827             continue;
7828             }
7829         if ('<' == *(ap = argv[j]))
7830             {
7831             in = 1 + ap;
7832             continue;
7833             }
7834         if (0 == strcmp(">", ap))
7835             {
7836             if (j+1 >= argc)
7837                 {
7838                 fprintf(stderr,"No output file after > on command line");
7839                 exit(LIB$_WRONUMARG);
7840                 }
7841             out = argv[++j];
7842             continue;
7843             }
7844         if ('>' == *ap)
7845             {
7846             if ('>' == ap[1])
7847                 {
7848                 outmode = "a";
7849                 if ('\0' == ap[2])
7850                     out = argv[++j];
7851                 else
7852                     out = 2 + ap;
7853                 }
7854             else
7855                 out = 1 + ap;
7856             if (j >= argc)
7857                 {
7858                 fprintf(stderr,"No output file after > or >> on command line");
7859                 exit(LIB$_WRONUMARG);
7860                 }
7861             continue;
7862             }
7863         if (('2' == *ap) && ('>' == ap[1]))
7864             {
7865             if ('>' == ap[2])
7866                 {
7867                 errmode = "a";
7868                 if ('\0' == ap[3])
7869                     err = argv[++j];
7870                 else
7871                     err = 3 + ap;
7872                 }
7873             else
7874                 if ('\0' == ap[2])
7875                     err = argv[++j];
7876                 else
7877                     err = 2 + ap;
7878             if (j >= argc)
7879                 {
7880                 fprintf(stderr,"No output file after 2> or 2>> on command line");
7881                 exit(LIB$_WRONUMARG);
7882                 }
7883             continue;
7884             }
7885         if (0 == strcmp("|", argv[j]))
7886             {
7887             if (j+1 >= argc)
7888                 {
7889                 fprintf(stderr,"No command into which to pipe on command line");
7890                 exit(LIB$_WRONUMARG);
7891                 }
7892             cmargc = argc-(j+1);
7893             cmargv = &argv[j+1];
7894             argc = j;
7895             continue;
7896             }
7897         if ('|' == *(ap = argv[j]))
7898             {
7899             ++argv[j];
7900             cmargc = argc-j;
7901             cmargv = &argv[j];
7902             argc = j;
7903             continue;
7904             }
7905         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7906         }
7907     /*
7908      * Allocate and fill in the new argument vector, Some Unix's terminate
7909      * the list with an extra null pointer.
7910      */
7911     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7912     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7913     *av = argv;
7914     for (j = 0; j < item_count; ++j, list_head = list_head->next)
7915         argv[j] = list_head->value;
7916     *ac = item_count;
7917     if (cmargv != NULL)
7918         {
7919         if (out != NULL)
7920             {
7921             fprintf(stderr,"'|' and '>' may not both be specified on command line");
7922             exit(LIB$_INVARGORD);
7923             }
7924         pipe_and_fork(aTHX_ cmargv);
7925         }
7926
7927     /* Check for input from a pipe (mailbox) */
7928
7929     if (in == NULL && 1 == isapipe(0))
7930         {
7931         char mbxname[L_tmpnam];
7932         long int bufsize;
7933         long int dvi_item = DVI$_DEVBUFSIZ;
7934         $DESCRIPTOR(mbxnam, "");
7935         $DESCRIPTOR(mbxdevnam, "");
7936
7937         /* Input from a pipe, reopen it in binary mode to disable       */
7938         /* carriage control processing.                                 */
7939
7940         fgetname(stdin, mbxname);
7941         mbxnam.dsc$a_pointer = mbxname;
7942         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7943         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7944         mbxdevnam.dsc$a_pointer = mbxname;
7945         mbxdevnam.dsc$w_length = sizeof(mbxname);
7946         dvi_item = DVI$_DEVNAM;
7947         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7948         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7949         set_errno(0);
7950         set_vaxc_errno(1);
7951         freopen(mbxname, "rb", stdin);
7952         if (errno != 0)
7953             {
7954             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7955             exit(vaxc$errno);
7956             }
7957         }
7958     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7959         {
7960         fprintf(stderr,"Can't open input file %s as stdin",in);
7961         exit(vaxc$errno);
7962         }
7963     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7964         {
7965         fprintf(stderr,"Can't open output file %s as stdout",out);
7966         exit(vaxc$errno);
7967         }
7968         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7969
7970     if (err != NULL) {
7971         if (strcmp(err,"&1") == 0) {
7972             dup2(fileno(stdout), fileno(stderr));
7973             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7974         } else {
7975         FILE *tmperr;
7976         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7977             {
7978             fprintf(stderr,"Can't open error file %s as stderr",err);
7979             exit(vaxc$errno);
7980             }
7981             fclose(tmperr);
7982            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7983                 {
7984                 exit(vaxc$errno);
7985                 }
7986             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7987         }
7988         }
7989 #ifdef ARGPROC_DEBUG
7990     PerlIO_printf(Perl_debug_log, "Arglist:\n");
7991     for (j = 0; j < *ac;  ++j)
7992         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7993 #endif
7994    /* Clear errors we may have hit expanding wildcards, so they don't
7995       show up in Perl's $! later */
7996    set_errno(0); set_vaxc_errno(1);
7997 }  /* end of getredirection() */
7998 /*}}}*/
7999
8000 static void add_item(struct list_item **head,
8001                      struct list_item **tail,
8002                      char *value,
8003                      int *count)
8004 {
8005     if (*head == 0)
8006         {
8007         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8008         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8009         *tail = *head;
8010         }
8011     else {
8012         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8013         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8014         *tail = (*tail)->next;
8015         }
8016     (*tail)->value = value;
8017     ++(*count);
8018 }
8019
8020 static void mp_expand_wild_cards(pTHX_ char *item,
8021                               struct list_item **head,
8022                               struct list_item **tail,
8023                               int *count)
8024 {
8025 int expcount = 0;
8026 unsigned long int context = 0;
8027 int isunix = 0;
8028 int item_len = 0;
8029 char *had_version;
8030 char *had_device;
8031 int had_directory;
8032 char *devdir,*cp;
8033 char *vmsspec;
8034 $DESCRIPTOR(filespec, "");
8035 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8036 $DESCRIPTOR(resultspec, "");
8037 unsigned long int lff_flags = 0;
8038 int sts;
8039 int rms_sts;
8040
8041 #ifdef VMS_LONGNAME_SUPPORT
8042     lff_flags = LIB$M_FIL_LONG_NAMES;
8043 #endif
8044
8045     for (cp = item; *cp; cp++) {
8046         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8047         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8048     }
8049     if (!*cp || isspace(*cp))
8050         {
8051         add_item(head, tail, item, count);
8052         return;
8053         }
8054     else
8055         {
8056      /* "double quoted" wild card expressions pass as is */
8057      /* From DCL that means using e.g.:                  */
8058      /* perl program """perl.*"""                        */
8059      item_len = strlen(item);
8060      if ( '"' == *item && '"' == item[item_len-1] )
8061        {
8062        item++;
8063        item[item_len-2] = '\0';
8064        add_item(head, tail, item, count);
8065        return;
8066        }
8067      }
8068     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8069     resultspec.dsc$b_class = DSC$K_CLASS_D;
8070     resultspec.dsc$a_pointer = NULL;
8071     vmsspec = PerlMem_malloc(VMS_MAXRSS);
8072     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8073     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8074       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8075     if (!isunix || !filespec.dsc$a_pointer)
8076       filespec.dsc$a_pointer = item;
8077     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8078     /*
8079      * Only return version specs, if the caller specified a version
8080      */
8081     had_version = strchr(item, ';');
8082     /*
8083      * Only return device and directory specs, if the caller specifed either.
8084      */
8085     had_device = strchr(item, ':');
8086     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8087
8088     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8089                                  (&filespec, &resultspec, &context,
8090                                   &defaultspec, 0, &rms_sts, &lff_flags)))
8091         {
8092         char *string;
8093         char *c;
8094
8095         string = PerlMem_malloc(resultspec.dsc$w_length+1);
8096         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8097         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8098         string[resultspec.dsc$w_length] = '\0';
8099         if (NULL == had_version)
8100             *(strrchr(string, ';')) = '\0';
8101         if ((!had_directory) && (had_device == NULL))
8102             {
8103             if (NULL == (devdir = strrchr(string, ']')))
8104                 devdir = strrchr(string, '>');
8105             strcpy(string, devdir + 1);
8106             }
8107         /*
8108          * Be consistent with what the C RTL has already done to the rest of
8109          * the argv items and lowercase all of these names.
8110          */
8111         if (!decc_efs_case_preserve) {
8112             for (c = string; *c; ++c)
8113             if (isupper(*c))
8114                 *c = tolower(*c);
8115         }
8116         if (isunix) trim_unixpath(string,item,1);
8117         add_item(head, tail, string, count);
8118         ++expcount;
8119     }
8120     PerlMem_free(vmsspec);
8121     if (sts != RMS$_NMF)
8122         {
8123         set_vaxc_errno(sts);
8124         switch (sts)
8125             {
8126             case RMS$_FNF: case RMS$_DNF:
8127                 set_errno(ENOENT); break;
8128             case RMS$_DIR:
8129                 set_errno(ENOTDIR); break;
8130             case RMS$_DEV:
8131                 set_errno(ENODEV); break;
8132             case RMS$_FNM: case RMS$_SYN:
8133                 set_errno(EINVAL); break;
8134             case RMS$_PRV:
8135                 set_errno(EACCES); break;
8136             default:
8137                 _ckvmssts_noperl(sts);
8138             }
8139         }
8140     if (expcount == 0)
8141         add_item(head, tail, item, count);
8142     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8143     _ckvmssts_noperl(lib$find_file_end(&context));
8144 }
8145
8146 static int child_st[2];/* Event Flag set when child process completes   */
8147
8148 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
8149
8150 static unsigned long int exit_handler(int *status)
8151 {
8152 short iosb[4];
8153
8154     if (0 == child_st[0])
8155         {
8156 #ifdef ARGPROC_DEBUG
8157         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8158 #endif
8159         fflush(stdout);     /* Have to flush pipe for binary data to    */
8160                             /* terminate properly -- <tp@mccall.com>    */
8161         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8162         sys$dassgn(child_chan);
8163         fclose(stdout);
8164         sys$synch(0, child_st);
8165         }
8166     return(1);
8167 }
8168
8169 static void sig_child(int chan)
8170 {
8171 #ifdef ARGPROC_DEBUG
8172     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8173 #endif
8174     if (child_st[0] == 0)
8175         child_st[0] = 1;
8176 }
8177
8178 static struct exit_control_block exit_block =
8179     {
8180     0,
8181     exit_handler,
8182     1,
8183     &exit_block.exit_status,
8184     0
8185     };
8186
8187 static void
8188 pipe_and_fork(pTHX_ char **cmargv)
8189 {
8190     PerlIO *fp;
8191     struct dsc$descriptor_s *vmscmd;
8192     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8193     int sts, j, l, ismcr, quote, tquote = 0;
8194
8195     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8196     vms_execfree(vmscmd);
8197
8198     j = l = 0;
8199     p = subcmd;
8200     q = cmargv[0];
8201     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
8202               && toupper(*(q+2)) == 'R' && !*(q+3);
8203
8204     while (q && l < MAX_DCL_LINE_LENGTH) {
8205         if (!*q) {
8206             if (j > 0 && quote) {
8207                 *p++ = '"';
8208                 l++;
8209             }
8210             q = cmargv[++j];
8211             if (q) {
8212                 if (ismcr && j > 1) quote = 1;
8213                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
8214                 *p++ = ' ';
8215                 l++;
8216                 if (quote || tquote) {
8217                     *p++ = '"';
8218                     l++;
8219                 }
8220             }
8221         } else {
8222             if ((quote||tquote) && *q == '"') {
8223                 *p++ = '"';
8224                 l++;
8225             }
8226             *p++ = *q++;
8227             l++;
8228         }
8229     }
8230     *p = '\0';
8231
8232     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8233     if (fp == Nullfp) {
8234         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8235     }
8236 }
8237
8238 static int background_process(pTHX_ int argc, char **argv)
8239 {
8240 char command[MAX_DCL_SYMBOL + 1] = "$";
8241 $DESCRIPTOR(value, "");
8242 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8243 static $DESCRIPTOR(null, "NLA0:");
8244 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8245 char pidstring[80];
8246 $DESCRIPTOR(pidstr, "");
8247 int pid;
8248 unsigned long int flags = 17, one = 1, retsts;
8249 int len;
8250
8251     strcat(command, argv[0]);
8252     len = strlen(command);
8253     while (--argc && (len < MAX_DCL_SYMBOL))
8254         {
8255         strcat(command, " \"");
8256         strcat(command, *(++argv));
8257         strcat(command, "\"");
8258         len = strlen(command);
8259         }
8260     value.dsc$a_pointer = command;
8261     value.dsc$w_length = strlen(value.dsc$a_pointer);
8262     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8263     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8264     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8265         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8266     }
8267     else {
8268         _ckvmssts_noperl(retsts);
8269     }
8270 #ifdef ARGPROC_DEBUG
8271     PerlIO_printf(Perl_debug_log, "%s\n", command);
8272 #endif
8273     sprintf(pidstring, "%08X", pid);
8274     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8275     pidstr.dsc$a_pointer = pidstring;
8276     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8277     lib$set_symbol(&pidsymbol, &pidstr);
8278     return(SS$_NORMAL);
8279 }
8280 /*}}}*/
8281 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8282
8283
8284 /* OS-specific initialization at image activation (not thread startup) */
8285 /* Older VAXC header files lack these constants */
8286 #ifndef JPI$_RIGHTS_SIZE
8287 #  define JPI$_RIGHTS_SIZE 817
8288 #endif
8289 #ifndef KGB$M_SUBSYSTEM
8290 #  define KGB$M_SUBSYSTEM 0x8
8291 #endif
8292
8293 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8294
8295 /*{{{void vms_image_init(int *, char ***)*/
8296 void
8297 vms_image_init(int *argcp, char ***argvp)
8298 {
8299   char eqv[LNM$C_NAMLENGTH+1] = "";
8300   unsigned int len, tabct = 8, tabidx = 0;
8301   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8302   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8303   unsigned short int dummy, rlen;
8304   struct dsc$descriptor_s **tabvec;
8305 #if defined(PERL_IMPLICIT_CONTEXT)
8306   pTHX = NULL;
8307 #endif
8308   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8309                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8310                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8311                                  {          0,                0,    0,      0} };
8312
8313 #ifdef KILL_BY_SIGPRC
8314     Perl_csighandler_init();
8315 #endif
8316
8317   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8318   _ckvmssts_noperl(iosb[0]);
8319   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8320     if (iprv[i]) {           /* Running image installed with privs? */
8321       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8322       will_taint = TRUE;
8323       break;
8324     }
8325   }
8326   /* Rights identifiers might trigger tainting as well. */
8327   if (!will_taint && (rlen || rsz)) {
8328     while (rlen < rsz) {
8329       /* We didn't get all the identifiers on the first pass.  Allocate a
8330        * buffer much larger than $GETJPI wants (rsz is size in bytes that
8331        * were needed to hold all identifiers at time of last call; we'll
8332        * allocate that many unsigned long ints), and go back and get 'em.
8333        * If it gave us less than it wanted to despite ample buffer space,
8334        * something's broken.  Is your system missing a system identifier?
8335        */
8336       if (rsz <= jpilist[1].buflen) {
8337          /* Perl_croak accvios when used this early in startup. */
8338          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8339                          rsz, (unsigned long) jpilist[1].buflen,
8340                          "Check your rights database for corruption.\n");
8341          exit(SS$_ABORT);
8342       }
8343       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8344       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8345       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8346       jpilist[1].buflen = rsz * sizeof(unsigned long int);
8347       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8348       _ckvmssts_noperl(iosb[0]);
8349     }
8350     mask = jpilist[1].bufadr;
8351     /* Check attribute flags for each identifier (2nd longword); protected
8352      * subsystem identifiers trigger tainting.
8353      */
8354     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8355       if (mask[i] & KGB$M_SUBSYSTEM) {
8356         will_taint = TRUE;
8357         break;
8358       }
8359     }
8360     if (mask != rlst) PerlMem_free(mask);
8361   }
8362
8363   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8364    * logical, some versions of the CRTL will add a phanthom /000000/
8365    * directory.  This needs to be removed.
8366    */
8367   if (decc_filename_unix_report) {
8368   char * zeros;
8369   int ulen;
8370     ulen = strlen(argvp[0][0]);
8371     if (ulen > 7) {
8372       zeros = strstr(argvp[0][0], "/000000/");
8373       if (zeros != NULL) {
8374         int mlen;
8375         mlen = ulen - (zeros - argvp[0][0]) - 7;
8376         memmove(zeros, &zeros[7], mlen);
8377         ulen = ulen - 7;
8378         argvp[0][0][ulen] = '\0';
8379       }
8380     }
8381     /* It also may have a trailing dot that needs to be removed otherwise
8382      * it will be converted to VMS mode incorrectly.
8383      */
8384     ulen--;
8385     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8386       argvp[0][0][ulen] = '\0';
8387   }
8388
8389   /* We need to use this hack to tell Perl it should run with tainting,
8390    * since its tainting flag may be part of the PL_curinterp struct, which
8391    * hasn't been allocated when vms_image_init() is called.
8392    */
8393   if (will_taint) {
8394     char **newargv, **oldargv;
8395     oldargv = *argvp;
8396     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8397     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8398     newargv[0] = oldargv[0];
8399     newargv[1] = PerlMem_malloc(3 * sizeof(char));
8400     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8401     strcpy(newargv[1], "-T");
8402     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8403     (*argcp)++;
8404     newargv[*argcp] = NULL;
8405     /* We orphan the old argv, since we don't know where it's come from,
8406      * so we don't know how to free it.
8407      */
8408     *argvp = newargv;
8409   }
8410   else {  /* Did user explicitly request tainting? */
8411     int i;
8412     char *cp, **av = *argvp;
8413     for (i = 1; i < *argcp; i++) {
8414       if (*av[i] != '-') break;
8415       for (cp = av[i]+1; *cp; cp++) {
8416         if (*cp == 'T') { will_taint = 1; break; }
8417         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8418                   strchr("DFIiMmx",*cp)) break;
8419       }
8420       if (will_taint) break;
8421     }
8422   }
8423
8424   for (tabidx = 0;
8425        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8426        tabidx++) {
8427     if (!tabidx) {
8428       tabvec = (struct dsc$descriptor_s **)
8429             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8430       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8431     }
8432     else if (tabidx >= tabct) {
8433       tabct += 8;
8434       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8435       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8436     }
8437     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8438     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8439     tabvec[tabidx]->dsc$w_length  = 0;
8440     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
8441     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
8442     tabvec[tabidx]->dsc$a_pointer = NULL;
8443     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8444   }
8445   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8446
8447   getredirection(argcp,argvp);
8448 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8449   {
8450 # include <reentrancy.h>
8451   decc$set_reentrancy(C$C_MULTITHREAD);
8452   }
8453 #endif
8454   return;
8455 }
8456 /*}}}*/
8457
8458
8459 /* trim_unixpath()
8460  * Trim Unix-style prefix off filespec, so it looks like what a shell
8461  * glob expansion would return (i.e. from specified prefix on, not
8462  * full path).  Note that returned filespec is Unix-style, regardless
8463  * of whether input filespec was VMS-style or Unix-style.
8464  *
8465  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8466  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
8467  * vector of options; at present, only bit 0 is used, and if set tells
8468  * trim unixpath to try the current default directory as a prefix when
8469  * presented with a possibly ambiguous ... wildcard.
8470  *
8471  * Returns !=0 on success, with trimmed filespec replacing contents of
8472  * fspec, and 0 on failure, with contents of fpsec unchanged.
8473  */
8474 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8475 int
8476 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8477 {
8478   char *unixified, *unixwild,
8479        *template, *base, *end, *cp1, *cp2;
8480   register int tmplen, reslen = 0, dirs = 0;
8481
8482   unixwild = PerlMem_malloc(VMS_MAXRSS);
8483   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8484   if (!wildspec || !fspec) return 0;
8485   template = unixwild;
8486   if (strpbrk(wildspec,"]>:") != NULL) {
8487     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8488         PerlMem_free(unixwild);
8489         return 0;
8490     }
8491   }
8492   else {
8493     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8494     unixwild[VMS_MAXRSS-1] = 0;
8495   }
8496   unixified = PerlMem_malloc(VMS_MAXRSS);
8497   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8498   if (strpbrk(fspec,"]>:") != NULL) {
8499     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8500         PerlMem_free(unixwild);
8501         PerlMem_free(unixified);
8502         return 0;
8503     }
8504     else base = unixified;
8505     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8506      * check to see that final result fits into (isn't longer than) fspec */
8507     reslen = strlen(fspec);
8508   }
8509   else base = fspec;
8510
8511   /* No prefix or absolute path on wildcard, so nothing to remove */
8512   if (!*template || *template == '/') {
8513     PerlMem_free(unixwild);
8514     if (base == fspec) {
8515         PerlMem_free(unixified);
8516         return 1;
8517     }
8518     tmplen = strlen(unixified);
8519     if (tmplen > reslen) {
8520         PerlMem_free(unixified);
8521         return 0;  /* not enough space */
8522     }
8523     /* Copy unixified resultant, including trailing NUL */
8524     memmove(fspec,unixified,tmplen+1);
8525     PerlMem_free(unixified);
8526     return 1;
8527   }
8528
8529   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
8530   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8531     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8532     for (cp1 = end ;cp1 >= base; cp1--)
8533       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8534         { cp1++; break; }
8535     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8536     PerlMem_free(unixified);
8537     PerlMem_free(unixwild);
8538     return 1;
8539   }
8540   else {
8541     char *tpl, *lcres;
8542     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8543     int ells = 1, totells, segdirs, match;
8544     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8545                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8546
8547     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8548     totells = ells;
8549     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8550     tpl = PerlMem_malloc(VMS_MAXRSS);
8551     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8552     if (ellipsis == template && opts & 1) {
8553       /* Template begins with an ellipsis.  Since we can't tell how many
8554        * directory names at the front of the resultant to keep for an
8555        * arbitrary starting point, we arbitrarily choose the current
8556        * default directory as a starting point.  If it's there as a prefix,
8557        * clip it off.  If not, fall through and act as if the leading
8558        * ellipsis weren't there (i.e. return shortest possible path that
8559        * could match template).
8560        */
8561       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8562           PerlMem_free(tpl);
8563           PerlMem_free(unixified);
8564           PerlMem_free(unixwild);
8565           return 0;
8566       }
8567       if (!decc_efs_case_preserve) {
8568         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8569           if (_tolower(*cp1) != _tolower(*cp2)) break;
8570       }
8571       segdirs = dirs - totells;  /* Min # of dirs we must have left */
8572       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8573       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8574         memmove(fspec,cp2+1,end - cp2);
8575         PerlMem_free(tpl);
8576         PerlMem_free(unixified);
8577         PerlMem_free(unixwild);
8578         return 1;
8579       }
8580     }
8581     /* First off, back up over constant elements at end of path */
8582     if (dirs) {
8583       for (front = end ; front >= base; front--)
8584          if (*front == '/' && !dirs--) { front++; break; }
8585     }
8586     lcres = PerlMem_malloc(VMS_MAXRSS);
8587     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8588     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8589          cp1++,cp2++) {
8590             if (!decc_efs_case_preserve) {
8591                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
8592             }
8593             else {
8594                 *cp2 = *cp1;
8595             }
8596     }
8597     if (cp1 != '\0') {
8598         PerlMem_free(tpl);
8599         PerlMem_free(unixified);
8600         PerlMem_free(unixwild);
8601         PerlMem_free(lcres);
8602         return 0;  /* Path too long. */
8603     }
8604     lcend = cp2;
8605     *cp2 = '\0';  /* Pick up with memcpy later */
8606     lcfront = lcres + (front - base);
8607     /* Now skip over each ellipsis and try to match the path in front of it. */
8608     while (ells--) {
8609       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8610         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
8611             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
8612       if (cp1 < template) break; /* template started with an ellipsis */
8613       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8614         ellipsis = cp1; continue;
8615       }
8616       wilddsc.dsc$a_pointer = tpl;
8617       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8618       nextell = cp1;
8619       for (segdirs = 0, cp2 = tpl;
8620            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8621            cp1++, cp2++) {
8622          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8623          else {
8624             if (!decc_efs_case_preserve) {
8625               *cp2 = _tolower(*cp1);  /* else lowercase for match */
8626             }
8627             else {
8628               *cp2 = *cp1;  /* else preserve case for match */
8629             }
8630          }
8631          if (*cp2 == '/') segdirs++;
8632       }
8633       if (cp1 != ellipsis - 1) {
8634           PerlMem_free(tpl);
8635           PerlMem_free(unixified);
8636           PerlMem_free(unixwild);
8637           PerlMem_free(lcres);
8638           return 0; /* Path too long */
8639       }
8640       /* Back up at least as many dirs as in template before matching */
8641       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8642         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8643       for (match = 0; cp1 > lcres;) {
8644         resdsc.dsc$a_pointer = cp1;
8645         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8646           match++;
8647           if (match == 1) lcfront = cp1;
8648         }
8649         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8650       }
8651       if (!match) {
8652         PerlMem_free(tpl);
8653         PerlMem_free(unixified);
8654         PerlMem_free(unixwild);
8655         PerlMem_free(lcres);
8656         return 0;  /* Can't find prefix ??? */
8657       }
8658       if (match > 1 && opts & 1) {
8659         /* This ... wildcard could cover more than one set of dirs (i.e.
8660          * a set of similar dir names is repeated).  If the template
8661          * contains more than 1 ..., upstream elements could resolve the
8662          * ambiguity, but it's not worth a full backtracking setup here.
8663          * As a quick heuristic, clip off the current default directory
8664          * if it's present to find the trimmed spec, else use the
8665          * shortest string that this ... could cover.
8666          */
8667         char def[NAM$C_MAXRSS+1], *st;
8668
8669         if (getcwd(def, sizeof def,0) == NULL) {
8670             Safefree(unixified);
8671             Safefree(unixwild);
8672             Safefree(lcres);
8673             Safefree(tpl);
8674             return 0;
8675         }
8676         if (!decc_efs_case_preserve) {
8677           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8678             if (_tolower(*cp1) != _tolower(*cp2)) break;
8679         }
8680         segdirs = dirs - totells;  /* Min # of dirs we must have left */
8681         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8682         if (*cp1 == '\0' && *cp2 == '/') {
8683           memmove(fspec,cp2+1,end - cp2);
8684           PerlMem_free(tpl);
8685           PerlMem_free(unixified);
8686           PerlMem_free(unixwild);
8687           PerlMem_free(lcres);
8688           return 1;
8689         }
8690         /* Nope -- stick with lcfront from above and keep going. */
8691       }
8692     }
8693     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8694     PerlMem_free(tpl);
8695     PerlMem_free(unixified);
8696     PerlMem_free(unixwild);
8697     PerlMem_free(lcres);
8698     return 1;
8699     ellipsis = nextell;
8700   }
8701
8702 }  /* end of trim_unixpath() */
8703 /*}}}*/
8704
8705
8706 /*
8707  *  VMS readdir() routines.
8708  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8709  *
8710  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
8711  *  Minor modifications to original routines.
8712  */
8713
8714 /* readdir may have been redefined by reentr.h, so make sure we get
8715  * the local version for what we do here.
8716  */
8717 #ifdef readdir
8718 # undef readdir
8719 #endif
8720 #if !defined(PERL_IMPLICIT_CONTEXT)
8721 # define readdir Perl_readdir
8722 #else
8723 # define readdir(a) Perl_readdir(aTHX_ a)
8724 #endif
8725
8726     /* Number of elements in vms_versions array */
8727 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
8728
8729 /*
8730  *  Open a directory, return a handle for later use.
8731  */
8732 /*{{{ DIR *opendir(char*name) */
8733 DIR *
8734 Perl_opendir(pTHX_ const char *name)
8735 {
8736     DIR *dd;
8737     char *dir;
8738     Stat_t sb;
8739     int unix_flag;
8740
8741     unix_flag = 0;
8742     if (decc_efs_charset) {
8743         unix_flag = is_unix_filespec(name);
8744     }
8745
8746     Newx(dir, VMS_MAXRSS, char);
8747     if (do_tovmspath(name,dir,0,NULL) == NULL) {
8748       Safefree(dir);
8749       return NULL;
8750     }
8751     /* Check access before stat; otherwise stat does not
8752      * accurately report whether it's a directory.
8753      */
8754     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8755       /* cando_by_name has already set errno */
8756       Safefree(dir);
8757       return NULL;
8758     }
8759     if (flex_stat(dir,&sb) == -1) return NULL;
8760     if (!S_ISDIR(sb.st_mode)) {
8761       Safefree(dir);
8762       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
8763       return NULL;
8764     }
8765     /* Get memory for the handle, and the pattern. */
8766     Newx(dd,1,DIR);
8767     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8768
8769     /* Fill in the fields; mainly playing with the descriptor. */
8770     sprintf(dd->pattern, "%s*.*",dir);
8771     Safefree(dir);
8772     dd->context = 0;
8773     dd->count = 0;
8774     dd->flags = 0;
8775     if (unix_flag)
8776         dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8777     dd->pat.dsc$a_pointer = dd->pattern;
8778     dd->pat.dsc$w_length = strlen(dd->pattern);
8779     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8780     dd->pat.dsc$b_class = DSC$K_CLASS_S;
8781 #if defined(USE_ITHREADS)
8782     Newx(dd->mutex,1,perl_mutex);
8783     MUTEX_INIT( (perl_mutex *) dd->mutex );
8784 #else
8785     dd->mutex = NULL;
8786 #endif
8787
8788     return dd;
8789 }  /* end of opendir() */
8790 /*}}}*/
8791
8792 /*
8793  *  Set the flag to indicate we want versions or not.
8794  */
8795 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8796 void
8797 vmsreaddirversions(DIR *dd, int flag)
8798 {
8799     if (flag)
8800         dd->flags |= PERL_VMSDIR_M_VERSIONS;
8801     else
8802         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8803 }
8804 /*}}}*/
8805
8806 /*
8807  *  Free up an opened directory.
8808  */
8809 /*{{{ void closedir(DIR *dd)*/
8810 void
8811 Perl_closedir(DIR *dd)
8812 {
8813     int sts;
8814
8815     sts = lib$find_file_end(&dd->context);
8816     Safefree(dd->pattern);
8817 #if defined(USE_ITHREADS)
8818     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8819     Safefree(dd->mutex);
8820 #endif
8821     Safefree(dd);
8822 }
8823 /*}}}*/
8824
8825 /*
8826  *  Collect all the version numbers for the current file.
8827  */
8828 static void
8829 collectversions(pTHX_ DIR *dd)
8830 {
8831     struct dsc$descriptor_s     pat;
8832     struct dsc$descriptor_s     res;
8833     struct dirent *e;
8834     char *p, *text, *buff;
8835     int i;
8836     unsigned long context, tmpsts;
8837
8838     /* Convenient shorthand. */
8839     e = &dd->entry;
8840
8841     /* Add the version wildcard, ignoring the "*.*" put on before */
8842     i = strlen(dd->pattern);
8843     Newx(text,i + e->d_namlen + 3,char);
8844     strcpy(text, dd->pattern);
8845     sprintf(&text[i - 3], "%s;*", e->d_name);
8846
8847     /* Set up the pattern descriptor. */
8848     pat.dsc$a_pointer = text;
8849     pat.dsc$w_length = i + e->d_namlen - 1;
8850     pat.dsc$b_dtype = DSC$K_DTYPE_T;
8851     pat.dsc$b_class = DSC$K_CLASS_S;
8852
8853     /* Set up result descriptor. */
8854     Newx(buff, VMS_MAXRSS, char);
8855     res.dsc$a_pointer = buff;
8856     res.dsc$w_length = VMS_MAXRSS - 1;
8857     res.dsc$b_dtype = DSC$K_DTYPE_T;
8858     res.dsc$b_class = DSC$K_CLASS_S;
8859
8860     /* Read files, collecting versions. */
8861     for (context = 0, e->vms_verscount = 0;
8862          e->vms_verscount < VERSIZE(e);
8863          e->vms_verscount++) {
8864         unsigned long rsts;
8865         unsigned long flags = 0;
8866
8867 #ifdef VMS_LONGNAME_SUPPORT
8868         flags = LIB$M_FIL_LONG_NAMES;
8869 #endif
8870         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8871         if (tmpsts == RMS$_NMF || context == 0) break;
8872         _ckvmssts(tmpsts);
8873         buff[VMS_MAXRSS - 1] = '\0';
8874         if ((p = strchr(buff, ';')))
8875             e->vms_versions[e->vms_verscount] = atoi(p + 1);
8876         else
8877             e->vms_versions[e->vms_verscount] = -1;
8878     }
8879
8880     _ckvmssts(lib$find_file_end(&context));
8881     Safefree(text);
8882     Safefree(buff);
8883
8884 }  /* end of collectversions() */
8885
8886 /*
8887  *  Read the next entry from the directory.
8888  */
8889 /*{{{ struct dirent *readdir(DIR *dd)*/
8890 struct dirent *
8891 Perl_readdir(pTHX_ DIR *dd)
8892 {
8893     struct dsc$descriptor_s     res;
8894     char *p, *buff;
8895     unsigned long int tmpsts;
8896     unsigned long rsts;
8897     unsigned long flags = 0;
8898     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8899     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8900
8901     /* Set up result descriptor, and get next file. */
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 #ifdef VMS_LONGNAME_SUPPORT
8909     flags = LIB$M_FIL_LONG_NAMES;
8910 #endif
8911
8912     tmpsts = lib$find_file
8913         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8914     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
8915     if (!(tmpsts & 1)) {
8916       set_vaxc_errno(tmpsts);
8917       switch (tmpsts) {
8918         case RMS$_PRV:
8919           set_errno(EACCES); break;
8920         case RMS$_DEV:
8921           set_errno(ENODEV); break;
8922         case RMS$_DIR:
8923           set_errno(ENOTDIR); break;
8924         case RMS$_FNF: case RMS$_DNF:
8925           set_errno(ENOENT); break;
8926         default:
8927           set_errno(EVMSERR);
8928       }
8929       Safefree(buff);
8930       return NULL;
8931     }
8932     dd->count++;
8933     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8934     if (!decc_efs_case_preserve) {
8935       buff[VMS_MAXRSS - 1] = '\0';
8936       for (p = buff; *p; p++) *p = _tolower(*p);
8937     }
8938     else {
8939       /* we don't want to force to lowercase, just null terminate */
8940       buff[res.dsc$w_length] = '\0';
8941     }
8942     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
8943     *p = '\0';
8944
8945     /* Skip any directory component and just copy the name. */
8946     sts = vms_split_path
8947        (buff,
8948         &v_spec,
8949         &v_len,
8950         &r_spec,
8951         &r_len,
8952         &d_spec,
8953         &d_len,
8954         &n_spec,
8955         &n_len,
8956         &e_spec,
8957         &e_len,
8958         &vs_spec,
8959         &vs_len);
8960
8961     /* Drop NULL extensions on UNIX file specification */
8962     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8963         (e_len == 1) && decc_readdir_dropdotnotype)) {
8964         e_len = 0;
8965         e_spec[0] = '\0';
8966     }
8967
8968     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8969     dd->entry.d_name[n_len + e_len] = '\0';
8970     dd->entry.d_namlen = strlen(dd->entry.d_name);
8971
8972     /* Convert the filename to UNIX format if needed */
8973     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8974
8975         /* Translate the encoded characters. */
8976         /* Fixme: unicode handling could result in embedded 0 characters */
8977         if (strchr(dd->entry.d_name, '^') != NULL) {
8978             char new_name[256];
8979             char * q;
8980             int cnt;
8981             p = dd->entry.d_name;
8982             q = new_name;
8983             while (*p != 0) {
8984                 int x, y;
8985                 x = copy_expand_vms_filename_escape(q, p, &y);
8986                 p += x;
8987                 q += y;
8988                 /* fix-me */
8989                 /* if y > 1, then this is a wide file specification */
8990                 /* Wide file specifications need to be passed in Perl */
8991                 /* counted strings apparently with a unicode flag */
8992             }
8993             *q = 0;
8994             strcpy(dd->entry.d_name, new_name);
8995         }
8996     }
8997
8998     dd->entry.vms_verscount = 0;
8999     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9000     Safefree(buff);
9001     return &dd->entry;
9002
9003 }  /* end of readdir() */
9004 /*}}}*/
9005
9006 /*
9007  *  Read the next entry from the directory -- thread-safe version.
9008  */
9009 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9010 int
9011 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9012 {
9013     int retval;
9014
9015     MUTEX_LOCK( (perl_mutex *) dd->mutex );
9016
9017     entry = readdir(dd);
9018     *result = entry;
9019     retval = ( *result == NULL ? errno : 0 );
9020
9021     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9022
9023     return retval;
9024
9025 }  /* end of readdir_r() */
9026 /*}}}*/
9027
9028 /*
9029  *  Return something that can be used in a seekdir later.
9030  */
9031 /*{{{ long telldir(DIR *dd)*/
9032 long
9033 Perl_telldir(DIR *dd)
9034 {
9035     return dd->count;
9036 }
9037 /*}}}*/
9038
9039 /*
9040  *  Return to a spot where we used to be.  Brute force.
9041  */
9042 /*{{{ void seekdir(DIR *dd,long count)*/
9043 void
9044 Perl_seekdir(pTHX_ DIR *dd, long count)
9045 {
9046     int old_flags;
9047
9048     /* If we haven't done anything yet... */
9049     if (dd->count == 0)
9050         return;
9051
9052     /* Remember some state, and clear it. */
9053     old_flags = dd->flags;
9054     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9055     _ckvmssts(lib$find_file_end(&dd->context));
9056     dd->context = 0;
9057
9058     /* The increment is in readdir(). */
9059     for (dd->count = 0; dd->count < count; )
9060         readdir(dd);
9061
9062     dd->flags = old_flags;
9063
9064 }  /* end of seekdir() */
9065 /*}}}*/
9066
9067 /* VMS subprocess management
9068  *
9069  * my_vfork() - just a vfork(), after setting a flag to record that
9070  * the current script is trying a Unix-style fork/exec.
9071  *
9072  * vms_do_aexec() and vms_do_exec() are called in response to the
9073  * perl 'exec' function.  If this follows a vfork call, then they
9074  * call out the regular perl routines in doio.c which do an
9075  * execvp (for those who really want to try this under VMS).
9076  * Otherwise, they do exactly what the perl docs say exec should
9077  * do - terminate the current script and invoke a new command
9078  * (See below for notes on command syntax.)
9079  *
9080  * do_aspawn() and do_spawn() implement the VMS side of the perl
9081  * 'system' function.
9082  *
9083  * Note on command arguments to perl 'exec' and 'system': When handled
9084  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9085  * are concatenated to form a DCL command string.  If the first arg
9086  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
9087  * the command string is handed off to DCL directly.  Otherwise,
9088  * the first token of the command is taken as the filespec of an image
9089  * to run.  The filespec is expanded using a default type of '.EXE' and
9090  * the process defaults for device, directory, etc., and if found, the resultant
9091  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9092  * the command string as parameters.  This is perhaps a bit complicated,
9093  * but I hope it will form a happy medium between what VMS folks expect
9094  * from lib$spawn and what Unix folks expect from exec.
9095  */
9096
9097 static int vfork_called;
9098
9099 /*{{{int my_vfork()*/
9100 int
9101 my_vfork()
9102 {
9103   vfork_called++;
9104   return vfork();
9105 }
9106 /*}}}*/
9107
9108
9109 static void
9110 vms_execfree(struct dsc$descriptor_s *vmscmd)
9111 {
9112   if (vmscmd) {
9113       if (vmscmd->dsc$a_pointer) {
9114           PerlMem_free(vmscmd->dsc$a_pointer);
9115       }
9116       PerlMem_free(vmscmd);
9117   }
9118 }
9119
9120 static char *
9121 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9122 {
9123   char *junk, *tmps = Nullch;
9124   register size_t cmdlen = 0;
9125   size_t rlen;
9126   register SV **idx;
9127   STRLEN n_a;
9128
9129   idx = mark;
9130   if (really) {
9131     tmps = SvPV(really,rlen);
9132     if (*tmps) {
9133       cmdlen += rlen + 1;
9134       idx++;
9135     }
9136   }
9137
9138   for (idx++; idx <= sp; idx++) {
9139     if (*idx) {
9140       junk = SvPVx(*idx,rlen);
9141       cmdlen += rlen ? rlen + 1 : 0;
9142     }
9143   }
9144   Newx(PL_Cmd, cmdlen+1, char);
9145
9146   if (tmps && *tmps) {
9147     strcpy(PL_Cmd,tmps);
9148     mark++;
9149   }
9150   else *PL_Cmd = '\0';
9151   while (++mark <= sp) {
9152     if (*mark) {
9153       char *s = SvPVx(*mark,n_a);
9154       if (!*s) continue;
9155       if (*PL_Cmd) strcat(PL_Cmd," ");
9156       strcat(PL_Cmd,s);
9157     }
9158   }
9159   return PL_Cmd;
9160
9161 }  /* end of setup_argstr() */
9162
9163
9164 static unsigned long int
9165 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9166                    struct dsc$descriptor_s **pvmscmd)
9167 {
9168   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9169   char image_name[NAM$C_MAXRSS+1];
9170   char image_argv[NAM$C_MAXRSS+1];
9171   $DESCRIPTOR(defdsc,".EXE");
9172   $DESCRIPTOR(defdsc2,".");
9173   $DESCRIPTOR(resdsc,resspec);
9174   struct dsc$descriptor_s *vmscmd;
9175   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9176   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9177   register char *s, *rest, *cp, *wordbreak;
9178   char * cmd;
9179   int cmdlen;
9180   register int isdcl;
9181
9182   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9183   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9184
9185   /* Make a copy for modification */
9186   cmdlen = strlen(incmd);
9187   cmd = PerlMem_malloc(cmdlen+1);
9188   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9189   strncpy(cmd, incmd, cmdlen);
9190   cmd[cmdlen] = 0;
9191   image_name[0] = 0;
9192   image_argv[0] = 0;
9193
9194   vmscmd->dsc$a_pointer = NULL;
9195   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
9196   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
9197   vmscmd->dsc$w_length = 0;
9198   if (pvmscmd) *pvmscmd = vmscmd;
9199
9200   if (suggest_quote) *suggest_quote = 0;
9201
9202   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9203     PerlMem_free(cmd);
9204     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
9205   }
9206
9207   s = cmd;
9208
9209   while (*s && isspace(*s)) s++;
9210
9211   if (*s == '@' || *s == '$') {
9212     vmsspec[0] = *s;  rest = s + 1;
9213     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9214   }
9215   else { cp = vmsspec; rest = s; }
9216   if (*rest == '.' || *rest == '/') {
9217     char *cp2;
9218     for (cp2 = resspec;
9219          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9220          rest++, cp2++) *cp2 = *rest;
9221     *cp2 = '\0';
9222     if (do_tovmsspec(resspec,cp,0,NULL)) {
9223       s = vmsspec;
9224       if (*rest) {
9225         for (cp2 = vmsspec + strlen(vmsspec);
9226              *rest && cp2 - vmsspec < sizeof vmsspec;
9227              rest++, cp2++) *cp2 = *rest;
9228         *cp2 = '\0';
9229       }
9230     }
9231   }
9232   /* Intuit whether verb (first word of cmd) is a DCL command:
9233    *   - if first nonspace char is '@', it's a DCL indirection
9234    * otherwise
9235    *   - if verb contains a filespec separator, it's not a DCL command
9236    *   - if it doesn't, caller tells us whether to default to a DCL
9237    *     command, or to a local image unless told it's DCL (by leading '$')
9238    */
9239   if (*s == '@') {
9240       isdcl = 1;
9241       if (suggest_quote) *suggest_quote = 1;
9242   } else {
9243     register char *filespec = strpbrk(s,":<[.;");
9244     rest = wordbreak = strpbrk(s," \"\t/");
9245     if (!wordbreak) wordbreak = s + strlen(s);
9246     if (*s == '$') check_img = 0;
9247     if (filespec && (filespec < wordbreak)) isdcl = 0;
9248     else isdcl = !check_img;
9249   }
9250
9251   if (!isdcl) {
9252     int rsts;
9253     imgdsc.dsc$a_pointer = s;
9254     imgdsc.dsc$w_length = wordbreak - s;
9255     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9256     if (!(retsts&1)) {
9257         _ckvmssts(lib$find_file_end(&cxt));
9258         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9259       if (!(retsts & 1) && *s == '$') {
9260         _ckvmssts(lib$find_file_end(&cxt));
9261         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9262         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9263         if (!(retsts&1)) {
9264           _ckvmssts(lib$find_file_end(&cxt));
9265           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9266         }
9267       }
9268     }
9269     _ckvmssts(lib$find_file_end(&cxt));
9270
9271     if (retsts & 1) {
9272       FILE *fp;
9273       s = resspec;
9274       while (*s && !isspace(*s)) s++;
9275       *s = '\0';
9276
9277       /* check that it's really not DCL with no file extension */
9278       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9279       if (fp) {
9280         char b[256] = {0,0,0,0};
9281         read(fileno(fp), b, 256);
9282         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9283         if (isdcl) {
9284           int shebang_len;
9285
9286           /* Check for script */
9287           shebang_len = 0;
9288           if ((b[0] == '#') && (b[1] == '!'))
9289              shebang_len = 2;
9290 #ifdef ALTERNATE_SHEBANG
9291           else {
9292             shebang_len = strlen(ALTERNATE_SHEBANG);
9293             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9294               char * perlstr;
9295                 perlstr = strstr("perl",b);
9296                 if (perlstr == NULL)
9297                   shebang_len = 0;
9298             }
9299             else
9300               shebang_len = 0;
9301           }
9302 #endif
9303
9304           if (shebang_len > 0) {
9305           int i;
9306           int j;
9307           char tmpspec[NAM$C_MAXRSS + 1];
9308
9309             i = shebang_len;
9310              /* Image is following after white space */
9311             /*--------------------------------------*/
9312             while (isprint(b[i]) && isspace(b[i]))
9313                 i++;
9314
9315             j = 0;
9316             while (isprint(b[i]) && !isspace(b[i])) {
9317                 tmpspec[j++] = b[i++];
9318                 if (j >= NAM$C_MAXRSS)
9319                    break;
9320             }
9321             tmpspec[j] = '\0';
9322
9323              /* There may be some default parameters to the image */
9324             /*---------------------------------------------------*/
9325             j = 0;
9326             while (isprint(b[i])) {
9327                 image_argv[j++] = b[i++];
9328                 if (j >= NAM$C_MAXRSS)
9329                    break;
9330             }
9331             while ((j > 0) && !isprint(image_argv[j-1]))
9332                 j--;
9333             image_argv[j] = 0;
9334
9335             /* It will need to be converted to VMS format and validated */
9336             if (tmpspec[0] != '\0') {
9337               char * iname;
9338
9339                /* Try to find the exact program requested to be run */
9340               /*---------------------------------------------------*/
9341               iname = do_rmsexpand
9342                  (tmpspec, image_name, 0, ".exe",
9343                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
9344               if (iname != NULL) {
9345                 if (cando_by_name_int
9346                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9347                   /* MCR prefix needed */
9348                   isdcl = 0;
9349                 }
9350                 else {
9351                    /* Try again with a null type */
9352                   /*----------------------------*/
9353                   iname = do_rmsexpand
9354                     (tmpspec, image_name, 0, ".",
9355                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
9356                   if (iname != NULL) {
9357                     if (cando_by_name_int
9358                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9359                       /* MCR prefix needed */
9360                       isdcl = 0;
9361                     }
9362                   }
9363                 }
9364
9365                  /* Did we find the image to run the script? */
9366                 /*------------------------------------------*/
9367                 if (isdcl) {
9368                   char *tchr;
9369
9370                    /* Assume DCL or foreign command exists */
9371                   /*--------------------------------------*/
9372                   tchr = strrchr(tmpspec, '/');
9373                   if (tchr != NULL) {
9374                     tchr++;
9375                   }
9376                   else {
9377                     tchr = tmpspec;
9378                   }
9379                   strcpy(image_name, tchr);
9380                 }
9381               }
9382             }
9383           }
9384         }
9385         fclose(fp);
9386       }
9387       if (check_img && isdcl) return RMS$_FNF;
9388
9389       if (cando_by_name(S_IXUSR,0,resspec)) {
9390         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9391         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9392         if (!isdcl) {
9393             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9394             if (image_name[0] != 0) {
9395                 strcat(vmscmd->dsc$a_pointer, image_name);
9396                 strcat(vmscmd->dsc$a_pointer, " ");
9397             }
9398         } else if (image_name[0] != 0) {
9399             strcpy(vmscmd->dsc$a_pointer, image_name);
9400             strcat(vmscmd->dsc$a_pointer, " ");
9401         } else {
9402             strcpy(vmscmd->dsc$a_pointer,"@");
9403         }
9404         if (suggest_quote) *suggest_quote = 1;
9405
9406         /* If there is an image name, use original command */
9407         if (image_name[0] == 0)
9408             strcat(vmscmd->dsc$a_pointer,resspec);
9409         else {
9410             rest = cmd;
9411             while (*rest && isspace(*rest)) rest++;
9412         }
9413
9414         if (image_argv[0] != 0) {
9415           strcat(vmscmd->dsc$a_pointer,image_argv);
9416           strcat(vmscmd->dsc$a_pointer, " ");
9417         }
9418         if (rest) {
9419            int rest_len;
9420            int vmscmd_len;
9421
9422            rest_len = strlen(rest);
9423            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9424            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9425               strcat(vmscmd->dsc$a_pointer,rest);
9426            else
9427              retsts = CLI$_BUFOVF;
9428         }
9429         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9430         PerlMem_free(cmd);
9431         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9432       }
9433       else
9434         retsts = RMS$_PRV;
9435     }
9436   }
9437   /* It's either a DCL command or we couldn't find a suitable image */
9438   vmscmd->dsc$w_length = strlen(cmd);
9439
9440   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9441   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9442   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9443
9444   PerlMem_free(cmd);
9445
9446   /* check if it's a symbol (for quoting purposes) */
9447   if (suggest_quote && !*suggest_quote) {
9448     int iss;
9449     char equiv[LNM$C_NAMLENGTH];
9450     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9451     eqvdsc.dsc$a_pointer = equiv;
9452
9453     iss = lib$get_symbol(vmscmd,&eqvdsc);
9454     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9455   }
9456   if (!(retsts & 1)) {
9457     /* just hand off status values likely to be due to user error */
9458     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9459         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9460        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9461     else { _ckvmssts(retsts); }
9462   }
9463
9464   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9465
9466 }  /* end of setup_cmddsc() */
9467
9468
9469 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9470 bool
9471 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9472 {
9473 bool exec_sts;
9474 char * cmd;
9475
9476   if (sp > mark) {
9477     if (vfork_called) {           /* this follows a vfork - act Unixish */
9478       vfork_called--;
9479       if (vfork_called < 0) {
9480         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9481         vfork_called = 0;
9482       }
9483       else return do_aexec(really,mark,sp);
9484     }
9485                                            /* no vfork - act VMSish */
9486     cmd = setup_argstr(aTHX_ really,mark,sp);
9487     exec_sts = vms_do_exec(cmd);
9488     Safefree(cmd);  /* Clean up from setup_argstr() */
9489     return exec_sts;
9490   }
9491
9492   return FALSE;
9493 }  /* end of vms_do_aexec() */
9494 /*}}}*/
9495
9496 /* {{{bool vms_do_exec(char *cmd) */
9497 bool
9498 Perl_vms_do_exec(pTHX_ const char *cmd)
9499 {
9500   struct dsc$descriptor_s *vmscmd;
9501
9502   if (vfork_called) {             /* this follows a vfork - act Unixish */
9503     vfork_called--;
9504     if (vfork_called < 0) {
9505       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9506       vfork_called = 0;
9507     }
9508     else return do_exec(cmd);
9509   }
9510
9511   {                               /* no vfork - act VMSish */
9512     unsigned long int retsts;
9513
9514     TAINT_ENV();
9515     TAINT_PROPER("exec");
9516     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9517       retsts = lib$do_command(vmscmd);
9518
9519     switch (retsts) {
9520       case RMS$_FNF: case RMS$_DNF:
9521         set_errno(ENOENT); break;
9522       case RMS$_DIR:
9523         set_errno(ENOTDIR); break;
9524       case RMS$_DEV:
9525         set_errno(ENODEV); break;
9526       case RMS$_PRV:
9527         set_errno(EACCES); break;
9528       case RMS$_SYN:
9529         set_errno(EINVAL); break;
9530       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9531         set_errno(E2BIG); break;
9532       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9533         _ckvmssts(retsts); /* fall through */
9534       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9535         set_errno(EVMSERR);
9536     }
9537     set_vaxc_errno(retsts);
9538     if (ckWARN(WARN_EXEC)) {
9539       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9540              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9541     }
9542     vms_execfree(vmscmd);
9543   }
9544
9545   return FALSE;
9546
9547 }  /* end of vms_do_exec() */
9548 /*}}}*/
9549
9550 unsigned long int Perl_do_spawn(pTHX_ const char *);
9551
9552 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9553 unsigned long int
9554 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9555 {
9556 unsigned long int sts;
9557 char * cmd;
9558
9559   if (sp > mark) {
9560     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9561     sts = do_spawn(cmd);
9562     /* pp_sys will clean up cmd */
9563     return sts;
9564   }
9565   return SS$_ABORT;
9566 }  /* end of do_aspawn() */
9567 /*}}}*/
9568
9569 /* {{{unsigned long int do_spawn(char *cmd) */
9570 unsigned long int
9571 Perl_do_spawn(pTHX_ const char *cmd)
9572 {
9573   unsigned long int sts, substs;
9574
9575   /* The caller of this routine expects to Safefree(PL_Cmd) */
9576   Newx(PL_Cmd,10,char);
9577
9578   TAINT_ENV();
9579   TAINT_PROPER("spawn");
9580   if (!cmd || !*cmd) {
9581     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9582     if (!(sts & 1)) {
9583       switch (sts) {
9584         case RMS$_FNF:  case RMS$_DNF:
9585           set_errno(ENOENT); break;
9586         case RMS$_DIR:
9587           set_errno(ENOTDIR); break;
9588         case RMS$_DEV:
9589           set_errno(ENODEV); break;
9590         case RMS$_PRV:
9591           set_errno(EACCES); break;
9592         case RMS$_SYN:
9593           set_errno(EINVAL); break;
9594         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9595           set_errno(E2BIG); break;
9596         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9597           _ckvmssts(sts); /* fall through */
9598         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9599           set_errno(EVMSERR);
9600       }
9601       set_vaxc_errno(sts);
9602       if (ckWARN(WARN_EXEC)) {
9603         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9604                     Strerror(errno));
9605       }
9606     }
9607     sts = substs;
9608   }
9609   else {
9610     PerlIO * fp;
9611     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9612     if (fp != NULL)
9613       my_pclose(fp);
9614   }
9615   return sts;
9616 }  /* end of do_spawn() */
9617 /*}}}*/
9618
9619
9620 static unsigned int *sockflags, sockflagsize;
9621
9622 /*
9623  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9624  * routines found in some versions of the CRTL can't deal with sockets.
9625  * We don't shim the other file open routines since a socket isn't
9626  * likely to be opened by a name.
9627  */
9628 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9629 FILE *my_fdopen(int fd, const char *mode)
9630 {
9631   FILE *fp = fdopen(fd, mode);
9632
9633   if (fp) {
9634     unsigned int fdoff = fd / sizeof(unsigned int);
9635     Stat_t sbuf; /* native stat; we don't need flex_stat */
9636     if (!sockflagsize || fdoff > sockflagsize) {
9637       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
9638       else           Newx  (sockflags,fdoff+2,unsigned int);
9639       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9640       sockflagsize = fdoff + 2;
9641     }
9642     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9643       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9644   }
9645   return fp;
9646
9647 }
9648 /*}}}*/
9649
9650
9651 /*
9652  * Clear the corresponding bit when the (possibly) socket stream is closed.
9653  * There still a small hole: we miss an implicit close which might occur
9654  * via freopen().  >> Todo
9655  */
9656 /*{{{ int my_fclose(FILE *fp)*/
9657 int my_fclose(FILE *fp) {
9658   if (fp) {
9659     unsigned int fd = fileno(fp);
9660     unsigned int fdoff = fd / sizeof(unsigned int);
9661
9662     if (sockflagsize && fdoff <= sockflagsize)
9663       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9664   }
9665   return fclose(fp);
9666 }
9667 /*}}}*/
9668
9669
9670 /*
9671  * A simple fwrite replacement which outputs itmsz*nitm chars without
9672  * introducing record boundaries every itmsz chars.
9673  * We are using fputs, which depends on a terminating null.  We may
9674  * well be writing binary data, so we need to accommodate not only
9675  * data with nulls sprinkled in the middle but also data with no null
9676  * byte at the end.
9677  */
9678 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9679 int
9680 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9681 {
9682   register char *cp, *end, *cpd, *data;
9683   register unsigned int fd = fileno(dest);
9684   register unsigned int fdoff = fd / sizeof(unsigned int);
9685   int retval;
9686   int bufsize = itmsz * nitm + 1;
9687
9688   if (fdoff < sockflagsize &&
9689       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9690     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9691     return nitm;
9692   }
9693
9694   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9695   memcpy( data, src, itmsz*nitm );
9696   data[itmsz*nitm] = '\0';
9697
9698   end = data + itmsz * nitm;
9699   retval = (int) nitm; /* on success return # items written */
9700
9701   cpd = data;
9702   while (cpd <= end) {
9703     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9704     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9705     if (cp < end)
9706       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9707     cpd = cp + 1;
9708   }
9709
9710   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9711   return retval;
9712
9713 }  /* end of my_fwrite() */
9714 /*}}}*/
9715
9716 /*{{{ int my_flush(FILE *fp)*/
9717 int
9718 Perl_my_flush(pTHX_ FILE *fp)
9719 {
9720     int res;
9721     if ((res = fflush(fp)) == 0 && fp) {
9722 #ifdef VMS_DO_SOCKETS
9723         Stat_t s;
9724         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9725 #endif
9726             res = fsync(fileno(fp));
9727     }
9728 /*
9729  * If the flush succeeded but set end-of-file, we need to clear
9730  * the error because our caller may check ferror().  BTW, this
9731  * probably means we just flushed an empty file.
9732  */
9733     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9734
9735     return res;
9736 }
9737 /*}}}*/
9738
9739 /*
9740  * Here are replacements for the following Unix routines in the VMS environment:
9741  *      getpwuid    Get information for a particular UIC or UID
9742  *      getpwnam    Get information for a named user
9743  *      getpwent    Get information for each user in the rights database
9744  *      setpwent    Reset search to the start of the rights database
9745  *      endpwent    Finish searching for users in the rights database
9746  *
9747  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9748  * (defined in pwd.h), which contains the following fields:-
9749  *      struct passwd {
9750  *              char        *pw_name;    Username (in lower case)
9751  *              char        *pw_passwd;  Hashed password
9752  *              unsigned int pw_uid;     UIC
9753  *              unsigned int pw_gid;     UIC group  number
9754  *              char        *pw_unixdir; Default device/directory (VMS-style)
9755  *              char        *pw_gecos;   Owner name
9756  *              char        *pw_dir;     Default device/directory (Unix-style)
9757  *              char        *pw_shell;   Default CLI name (eg. DCL)
9758  *      };
9759  * If the specified user does not exist, getpwuid and getpwnam return NULL.
9760  *
9761  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9762  * not the UIC member number (eg. what's returned by getuid()),
9763  * getpwuid() can accept either as input (if uid is specified, the caller's
9764  * UIC group is used), though it won't recognise gid=0.
9765  *
9766  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9767  * information about other users in your group or in other groups, respectively.
9768  * If the required privilege is not available, then these routines fill only
9769  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9770  * string).
9771  *
9772  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9773  */
9774
9775 /* sizes of various UAF record fields */
9776 #define UAI$S_USERNAME 12
9777 #define UAI$S_IDENT    31
9778 #define UAI$S_OWNER    31
9779 #define UAI$S_DEFDEV   31
9780 #define UAI$S_DEFDIR   63
9781 #define UAI$S_DEFCLI   31
9782 #define UAI$S_PWD       8
9783
9784 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
9785                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9786                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
9787
9788 static char __empty[]= "";
9789 static struct passwd __passwd_empty=
9790     {(char *) __empty, (char *) __empty, 0, 0,
9791      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9792 static int contxt= 0;
9793 static struct passwd __pwdcache;
9794 static char __pw_namecache[UAI$S_IDENT+1];
9795
9796 /*
9797  * This routine does most of the work extracting the user information.
9798  */
9799 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9800 {
9801     static struct {
9802         unsigned char length;
9803         char pw_gecos[UAI$S_OWNER+1];
9804     } owner;
9805     static union uicdef uic;
9806     static struct {
9807         unsigned char length;
9808         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9809     } defdev;
9810     static struct {
9811         unsigned char length;
9812         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9813     } defdir;
9814     static struct {
9815         unsigned char length;
9816         char pw_shell[UAI$S_DEFCLI+1];
9817     } defcli;
9818     static char pw_passwd[UAI$S_PWD+1];
9819
9820     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9821     struct dsc$descriptor_s name_desc;
9822     unsigned long int sts;
9823
9824     static struct itmlst_3 itmlst[]= {
9825         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
9826         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
9827         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
9828         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
9829         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
9830         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
9831         {0,                0,           NULL,    NULL}};
9832
9833     name_desc.dsc$w_length=  strlen(name);
9834     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9835     name_desc.dsc$b_class=   DSC$K_CLASS_S;
9836     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9837
9838 /*  Note that sys$getuai returns many fields as counted strings. */
9839     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9840     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9841       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9842     }
9843     else { _ckvmssts(sts); }
9844     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
9845
9846     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
9847     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9848     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9849     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9850     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9851     owner.pw_gecos[lowner]=            '\0';
9852     defdev.pw_dir[ldefdev+ldefdir]= '\0';
9853     defcli.pw_shell[ldefcli]=          '\0';
9854     if (valid_uic(uic)) {
9855         pwd->pw_uid= uic.uic$l_uic;
9856         pwd->pw_gid= uic.uic$v_group;
9857     }
9858     else
9859       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9860     pwd->pw_passwd=  pw_passwd;
9861     pwd->pw_gecos=   owner.pw_gecos;
9862     pwd->pw_dir=     defdev.pw_dir;
9863     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9864     pwd->pw_shell=   defcli.pw_shell;
9865     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9866         int ldir;
9867         ldir= strlen(pwd->pw_unixdir) - 1;
9868         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9869     }
9870     else
9871         strcpy(pwd->pw_unixdir, pwd->pw_dir);
9872     if (!decc_efs_case_preserve)
9873         __mystrtolower(pwd->pw_unixdir);
9874     return 1;
9875 }
9876
9877 /*
9878  * Get information for a named user.
9879 */
9880 /*{{{struct passwd *getpwnam(char *name)*/
9881 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9882 {
9883     struct dsc$descriptor_s name_desc;
9884     union uicdef uic;
9885     unsigned long int status, sts;
9886
9887     __pwdcache = __passwd_empty;
9888     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9889       /* We still may be able to determine pw_uid and pw_gid */
9890       name_desc.dsc$w_length=  strlen(name);
9891       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9892       name_desc.dsc$b_class=   DSC$K_CLASS_S;
9893       name_desc.dsc$a_pointer= (char *) name;
9894       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9895         __pwdcache.pw_uid= uic.uic$l_uic;
9896         __pwdcache.pw_gid= uic.uic$v_group;
9897       }
9898       else {
9899         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9900           set_vaxc_errno(sts);
9901           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9902           return NULL;
9903         }
9904         else { _ckvmssts(sts); }
9905       }
9906     }
9907     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9908     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9909     __pwdcache.pw_name= __pw_namecache;
9910     return &__pwdcache;
9911 }  /* end of my_getpwnam() */
9912 /*}}}*/
9913
9914 /*
9915  * Get information for a particular UIC or UID.
9916  * Called by my_getpwent with uid=-1 to list all users.
9917 */
9918 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9919 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9920 {
9921     const $DESCRIPTOR(name_desc,__pw_namecache);
9922     unsigned short lname;
9923     union uicdef uic;
9924     unsigned long int status;
9925
9926     if (uid == (unsigned int) -1) {
9927       do {
9928         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9929         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9930           set_vaxc_errno(status);
9931           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9932           my_endpwent();
9933           return NULL;
9934         }
9935         else { _ckvmssts(status); }
9936       } while (!valid_uic (uic));
9937     }
9938     else {
9939       uic.uic$l_uic= uid;
9940       if (!uic.uic$v_group)
9941         uic.uic$v_group= PerlProc_getgid();
9942       if (valid_uic(uic))
9943         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9944       else status = SS$_IVIDENT;
9945       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9946           status == RMS$_PRV) {
9947         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9948         return NULL;
9949       }
9950       else { _ckvmssts(status); }
9951     }
9952     __pw_namecache[lname]= '\0';
9953     __mystrtolower(__pw_namecache);
9954
9955     __pwdcache = __passwd_empty;
9956     __pwdcache.pw_name = __pw_namecache;
9957
9958 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9959     The identifier's value is usually the UIC, but it doesn't have to be,
9960     so if we can, we let fillpasswd update this. */
9961     __pwdcache.pw_uid =  uic.uic$l_uic;
9962     __pwdcache.pw_gid =  uic.uic$v_group;
9963
9964     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9965     return &__pwdcache;
9966
9967 }  /* end of my_getpwuid() */
9968 /*}}}*/
9969
9970 /*
9971  * Get information for next user.
9972 */
9973 /*{{{struct passwd *my_getpwent()*/
9974 struct passwd *Perl_my_getpwent(pTHX)
9975 {
9976     return (my_getpwuid((unsigned int) -1));
9977 }
9978 /*}}}*/
9979
9980 /*
9981  * Finish searching rights database for users.
9982 */
9983 /*{{{void my_endpwent()*/
9984 void Perl_my_endpwent(pTHX)
9985 {
9986     if (contxt) {
9987       _ckvmssts(sys$finish_rdb(&contxt));
9988       contxt= 0;
9989     }
9990 }
9991 /*}}}*/
9992
9993 #ifdef HOMEGROWN_POSIX_SIGNALS
9994   /* Signal handling routines, pulled into the core from POSIX.xs.
9995    *
9996    * We need these for threads, so they've been rolled into the core,
9997    * rather than left in POSIX.xs.
9998    *
9999    * (DRS, Oct 23, 1997)
10000    */
10001
10002   /* sigset_t is atomic under VMS, so these routines are easy */
10003 /*{{{int my_sigemptyset(sigset_t *) */
10004 int my_sigemptyset(sigset_t *set) {
10005     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10006     *set = 0; return 0;
10007 }
10008 /*}}}*/
10009
10010
10011 /*{{{int my_sigfillset(sigset_t *)*/
10012 int my_sigfillset(sigset_t *set) {
10013     int i;
10014     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10015     for (i = 0; i < NSIG; i++) *set |= (1 << i);
10016     return 0;
10017 }
10018 /*}}}*/
10019
10020
10021 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10022 int my_sigaddset(sigset_t *set, int sig) {
10023     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10024     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10025     *set |= (1 << (sig - 1));
10026     return 0;
10027 }
10028 /*}}}*/
10029
10030
10031 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10032 int my_sigdelset(sigset_t *set, int sig) {
10033     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10034     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10035     *set &= ~(1 << (sig - 1));
10036     return 0;
10037 }
10038 /*}}}*/
10039
10040
10041 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10042 int my_sigismember(sigset_t *set, int sig) {
10043     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10044     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10045     return *set & (1 << (sig - 1));
10046 }
10047 /*}}}*/
10048
10049
10050 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10051 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10052     sigset_t tempmask;
10053
10054     /* If set and oset are both null, then things are badly wrong. Bail out. */
10055     if ((oset == NULL) && (set == NULL)) {
10056       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10057       return -1;
10058     }
10059
10060     /* If set's null, then we're just handling a fetch. */
10061     if (set == NULL) {
10062         tempmask = sigblock(0);
10063     }
10064     else {
10065       switch (how) {
10066       case SIG_SETMASK:
10067         tempmask = sigsetmask(*set);
10068         break;
10069       case SIG_BLOCK:
10070         tempmask = sigblock(*set);
10071         break;
10072       case SIG_UNBLOCK:
10073         tempmask = sigblock(0);
10074         sigsetmask(*oset & ~tempmask);
10075         break;
10076       default:
10077         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10078         return -1;
10079       }
10080     }
10081
10082     /* Did they pass us an oset? If so, stick our holding mask into it */
10083     if (oset)
10084       *oset = tempmask;
10085
10086     return 0;
10087 }
10088 /*}}}*/
10089 #endif  /* HOMEGROWN_POSIX_SIGNALS */
10090
10091
10092 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10093  * my_utime(), and flex_stat(), all of which operate on UTC unless
10094  * VMSISH_TIMES is true.
10095  */
10096 /* method used to handle UTC conversions:
10097  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
10098  */
10099 static int gmtime_emulation_type;
10100 /* number of secs to add to UTC POSIX-style time to get local time */
10101 static long int utc_offset_secs;
10102
10103 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10104  * in vmsish.h.  #undef them here so we can call the CRTL routines
10105  * directly.
10106  */
10107 #undef gmtime
10108 #undef localtime
10109 #undef time
10110
10111
10112 /*
10113  * DEC C previous to 6.0 corrupts the behavior of the /prefix
10114  * qualifier with the extern prefix pragma.  This provisional
10115  * hack circumvents this prefix pragma problem in previous
10116  * precompilers.
10117  */
10118 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10119 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10120 #    pragma __extern_prefix save
10121 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
10122 #    define gmtime decc$__utctz_gmtime
10123 #    define localtime decc$__utctz_localtime
10124 #    define time decc$__utc_time
10125 #    pragma __extern_prefix restore
10126
10127      struct tm *gmtime(), *localtime();
10128
10129 #  endif
10130 #endif
10131
10132
10133 static time_t toutc_dst(time_t loc) {
10134   struct tm *rsltmp;
10135
10136   if ((rsltmp = localtime(&loc)) == NULL) return -1;
10137   loc -= utc_offset_secs;
10138   if (rsltmp->tm_isdst) loc -= 3600;
10139   return loc;
10140 }
10141 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10142        ((gmtime_emulation_type || my_time(NULL)), \
10143        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10144        ((secs) - utc_offset_secs))))
10145
10146 static time_t toloc_dst(time_t utc) {
10147   struct tm *rsltmp;
10148
10149   utc += utc_offset_secs;
10150   if ((rsltmp = localtime(&utc)) == NULL) return -1;
10151   if (rsltmp->tm_isdst) utc += 3600;
10152   return utc;
10153 }
10154 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10155        ((gmtime_emulation_type || my_time(NULL)), \
10156        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10157        ((secs) + utc_offset_secs))))
10158
10159 #ifndef RTL_USES_UTC
10160 /*
10161
10162     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
10163         DST starts on 1st sun of april      at 02:00  std time
10164             ends on last sun of october     at 02:00  dst time
10165     see the UCX management command reference, SET CONFIG TIMEZONE
10166     for formatting info.
10167
10168     No, it's not as general as it should be, but then again, NOTHING
10169     will handle UK times in a sensible way.
10170 */
10171
10172
10173 /*
10174     parse the DST start/end info:
10175     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10176 */
10177
10178 static char *
10179 tz_parse_startend(char *s, struct tm *w, int *past)
10180 {
10181     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10182     int ly, dozjd, d, m, n, hour, min, sec, j, k;
10183     time_t g;
10184
10185     if (!s)    return 0;
10186     if (!w) return 0;
10187     if (!past) return 0;
10188
10189     ly = 0;
10190     if (w->tm_year % 4        == 0) ly = 1;
10191     if (w->tm_year % 100      == 0) ly = 0;
10192     if (w->tm_year+1900 % 400 == 0) ly = 1;
10193     if (ly) dinm[1]++;
10194
10195     dozjd = isdigit(*s);
10196     if (*s == 'J' || *s == 'j' || dozjd) {
10197         if (!dozjd && !isdigit(*++s)) return 0;
10198         d = *s++ - '0';
10199         if (isdigit(*s)) {
10200             d = d*10 + *s++ - '0';
10201             if (isdigit(*s)) {
10202                 d = d*10 + *s++ - '0';
10203             }
10204         }
10205         if (d == 0) return 0;
10206         if (d > 366) return 0;
10207         d--;
10208         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
10209         g = d * 86400;
10210         dozjd = 1;
10211     } else if (*s == 'M' || *s == 'm') {
10212         if (!isdigit(*++s)) return 0;
10213         m = *s++ - '0';
10214         if (isdigit(*s)) m = 10*m + *s++ - '0';
10215         if (*s != '.') return 0;
10216         if (!isdigit(*++s)) return 0;
10217         n = *s++ - '0';
10218         if (n < 1 || n > 5) return 0;
10219         if (*s != '.') return 0;
10220         if (!isdigit(*++s)) return 0;
10221         d = *s++ - '0';
10222         if (d > 6) return 0;
10223     }
10224
10225     if (*s == '/') {
10226         if (!isdigit(*++s)) return 0;
10227         hour = *s++ - '0';
10228         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10229         if (*s == ':') {
10230             if (!isdigit(*++s)) return 0;
10231             min = *s++ - '0';
10232             if (isdigit(*s)) min = 10*min + *s++ - '0';
10233             if (*s == ':') {
10234                 if (!isdigit(*++s)) return 0;
10235                 sec = *s++ - '0';
10236                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10237             }
10238         }
10239     } else {
10240         hour = 2;
10241         min = 0;
10242         sec = 0;
10243     }
10244
10245     if (dozjd) {
10246         if (w->tm_yday < d) goto before;
10247         if (w->tm_yday > d) goto after;
10248     } else {
10249         if (w->tm_mon+1 < m) goto before;
10250         if (w->tm_mon+1 > m) goto after;
10251
10252         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
10253         k = d - j; /* mday of first d */
10254         if (k <= 0) k += 7;
10255         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
10256         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10257         if (w->tm_mday < k) goto before;
10258         if (w->tm_mday > k) goto after;
10259     }
10260
10261     if (w->tm_hour < hour) goto before;
10262     if (w->tm_hour > hour) goto after;
10263     if (w->tm_min  < min)  goto before;
10264     if (w->tm_min  > min)  goto after;
10265     if (w->tm_sec  < sec)  goto before;
10266     goto after;
10267
10268 before:
10269     *past = 0;
10270     return s;
10271 after:
10272     *past = 1;
10273     return s;
10274 }
10275
10276
10277
10278
10279 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
10280
10281 static char *
10282 tz_parse_offset(char *s, int *offset)
10283 {
10284     int hour = 0, min = 0, sec = 0;
10285     int neg = 0;
10286     if (!s) return 0;
10287     if (!offset) return 0;
10288
10289     if (*s == '-') {neg++; s++;}
10290     if (*s == '+') s++;
10291     if (!isdigit(*s)) return 0;
10292     hour = *s++ - '0';
10293     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10294     if (hour > 24) return 0;
10295     if (*s == ':') {
10296         if (!isdigit(*++s)) return 0;
10297         min = *s++ - '0';
10298         if (isdigit(*s)) min = min*10 + (*s++ - '0');
10299         if (min > 59) return 0;
10300         if (*s == ':') {
10301             if (!isdigit(*++s)) return 0;
10302             sec = *s++ - '0';
10303             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10304             if (sec > 59) return 0;
10305         }
10306     }
10307
10308     *offset = (hour*60+min)*60 + sec;
10309     if (neg) *offset = -*offset;
10310     return s;
10311 }
10312
10313 /*
10314     input time is w, whatever type of time the CRTL localtime() uses.
10315     sets dst, the zone, and the gmtoff (seconds)
10316
10317     caches the value of TZ and UCX$TZ env variables; note that
10318     my_setenv looks for these and sets a flag if they're changed
10319     for efficiency.
10320
10321     We have to watch out for the "australian" case (dst starts in
10322     october, ends in april)...flagged by "reverse" and checked by
10323     scanning through the months of the previous year.
10324
10325 */
10326
10327 static int
10328 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10329 {
10330     time_t when;
10331     struct tm *w2;
10332     char *s,*s2;
10333     char *dstzone, *tz, *s_start, *s_end;
10334     int std_off, dst_off, isdst;
10335     int y, dststart, dstend;
10336     static char envtz[1025];  /* longer than any logical, symbol, ... */
10337     static char ucxtz[1025];
10338     static char reversed = 0;
10339
10340     if (!w) return 0;
10341
10342     if (tz_updated) {
10343         tz_updated = 0;
10344         reversed = -1;  /* flag need to check  */
10345         envtz[0] = ucxtz[0] = '\0';
10346         tz = my_getenv("TZ",0);
10347         if (tz) strcpy(envtz, tz);
10348         tz = my_getenv("UCX$TZ",0);
10349         if (tz) strcpy(ucxtz, tz);
10350         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
10351     }
10352     tz = envtz;
10353     if (!*tz) tz = ucxtz;
10354
10355     s = tz;
10356     while (isalpha(*s)) s++;
10357     s = tz_parse_offset(s, &std_off);
10358     if (!s) return 0;
10359     if (!*s) {                  /* no DST, hurray we're done! */
10360         isdst = 0;
10361         goto done;
10362     }
10363
10364     dstzone = s;
10365     while (isalpha(*s)) s++;
10366     s2 = tz_parse_offset(s, &dst_off);
10367     if (s2) {
10368         s = s2;
10369     } else {
10370         dst_off = std_off - 3600;
10371     }
10372
10373     if (!*s) {      /* default dst start/end?? */
10374         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
10375             s = strchr(ucxtz,',');
10376         }
10377         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
10378     }
10379     if (*s != ',') return 0;
10380
10381     when = *w;
10382     when = _toutc(when);      /* convert to utc */
10383     when = when - std_off;    /* convert to pseudolocal time*/
10384
10385     w2 = localtime(&when);
10386     y = w2->tm_year;
10387     s_start = s+1;
10388     s = tz_parse_startend(s_start,w2,&dststart);
10389     if (!s) return 0;
10390     if (*s != ',') return 0;
10391
10392     when = *w;
10393     when = _toutc(when);      /* convert to utc */
10394     when = when - dst_off;    /* convert to pseudolocal time*/
10395     w2 = localtime(&when);
10396     if (w2->tm_year != y) {   /* spans a year, just check one time */
10397         when += dst_off - std_off;
10398         w2 = localtime(&when);
10399     }
10400     s_end = s+1;
10401     s = tz_parse_startend(s_end,w2,&dstend);
10402     if (!s) return 0;
10403
10404     if (reversed == -1) {  /* need to check if start later than end */
10405         int j, ds, de;
10406
10407         when = *w;
10408         if (when < 2*365*86400) {
10409             when += 2*365*86400;
10410         } else {
10411             when -= 365*86400;
10412         }
10413         w2 =localtime(&when);
10414         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
10415
10416         for (j = 0; j < 12; j++) {
10417             w2 =localtime(&when);
10418             tz_parse_startend(s_start,w2,&ds);
10419             tz_parse_startend(s_end,w2,&de);
10420             if (ds != de) break;
10421             when += 30*86400;
10422         }
10423         reversed = 0;
10424         if (de && !ds) reversed = 1;
10425     }
10426
10427     isdst = dststart && !dstend;
10428     if (reversed) isdst = dststart  || !dstend;
10429
10430 done:
10431     if (dst)    *dst = isdst;
10432     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10433     if (isdst)  tz = dstzone;
10434     if (zone) {
10435         while(isalpha(*tz))  *zone++ = *tz++;
10436         *zone = '\0';
10437     }
10438     return 1;
10439 }
10440
10441 #endif /* !RTL_USES_UTC */
10442
10443 /* my_time(), my_localtime(), my_gmtime()
10444  * By default traffic in UTC time values, using CRTL gmtime() or
10445  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10446  * Note: We need to use these functions even when the CRTL has working
10447  * UTC support, since they also handle C<use vmsish qw(times);>
10448  *
10449  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
10450  * Modified by Charles Bailey <bailey@newman.upenn.edu>
10451  */
10452
10453 /*{{{time_t my_time(time_t *timep)*/
10454 time_t Perl_my_time(pTHX_ time_t *timep)
10455 {
10456   time_t when;
10457   struct tm *tm_p;
10458
10459   if (gmtime_emulation_type == 0) {
10460     int dstnow;
10461     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
10462                               /* results of calls to gmtime() and localtime() */
10463                               /* for same &base */
10464
10465     gmtime_emulation_type++;
10466     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10467       char off[LNM$C_NAMLENGTH+1];;
10468
10469       gmtime_emulation_type++;
10470       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10471         gmtime_emulation_type++;
10472         utc_offset_secs = 0;
10473         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10474       }
10475       else { utc_offset_secs = atol(off); }
10476     }
10477     else { /* We've got a working gmtime() */
10478       struct tm gmt, local;
10479
10480       gmt = *tm_p;
10481       tm_p = localtime(&base);
10482       local = *tm_p;
10483       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
10484       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10485       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
10486       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
10487     }
10488   }
10489
10490   when = time(NULL);
10491 # ifdef VMSISH_TIME
10492 # ifdef RTL_USES_UTC
10493   if (VMSISH_TIME) when = _toloc(when);
10494 # else
10495   if (!VMSISH_TIME) when = _toutc(when);
10496 # endif
10497 # endif
10498   if (timep != NULL) *timep = when;
10499   return when;
10500
10501 }  /* end of my_time() */
10502 /*}}}*/
10503
10504
10505 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10506 struct tm *
10507 Perl_my_gmtime(pTHX_ const time_t *timep)
10508 {
10509   char *p;
10510   time_t when;
10511   struct tm *rsltmp;
10512
10513   if (timep == NULL) {
10514     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10515     return NULL;
10516   }
10517   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10518
10519   when = *timep;
10520 # ifdef VMSISH_TIME
10521   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10522 #  endif
10523 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
10524   return gmtime(&when);
10525 # else
10526   /* CRTL localtime() wants local time as input, so does no tz correction */
10527   rsltmp = localtime(&when);
10528   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
10529   return rsltmp;
10530 #endif
10531 }  /* end of my_gmtime() */
10532 /*}}}*/
10533
10534
10535 /*{{{struct tm *my_localtime(const time_t *timep)*/
10536 struct tm *
10537 Perl_my_localtime(pTHX_ const time_t *timep)
10538 {
10539   time_t when, whenutc;
10540   struct tm *rsltmp;
10541   int dst, offset;
10542
10543   if (timep == NULL) {
10544     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10545     return NULL;
10546   }
10547   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10548   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10549
10550   when = *timep;
10551 # ifdef RTL_USES_UTC
10552 # ifdef VMSISH_TIME
10553   if (VMSISH_TIME) when = _toutc(when);
10554 # endif
10555   /* CRTL localtime() wants UTC as input, does tz correction itself */
10556   return localtime(&when);
10557
10558 # else /* !RTL_USES_UTC */
10559   whenutc = when;
10560 # ifdef VMSISH_TIME
10561   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
10562   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
10563 # endif
10564   dst = -1;
10565 #ifndef RTL_USES_UTC
10566   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
10567       when = whenutc - offset;                   /* pseudolocal time*/
10568   }
10569 # endif
10570   /* CRTL localtime() wants local time as input, so does no tz correction */
10571   rsltmp = localtime(&when);
10572   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10573   return rsltmp;
10574 # endif
10575
10576 } /*  end of my_localtime() */
10577 /*}}}*/
10578
10579 /* Reset definitions for later calls */
10580 #define gmtime(t)    my_gmtime(t)
10581 #define localtime(t) my_localtime(t)
10582 #define time(t)      my_time(t)
10583
10584
10585 /* my_utime - update modification/access time of a file
10586  *
10587  * VMS 7.3 and later implementation
10588  * Only the UTC translation is home-grown. The rest is handled by the
10589  * CRTL utime(), which will take into account the relevant feature
10590  * logicals and ODS-5 volume characteristics for true access times.
10591  *
10592  * pre VMS 7.3 implementation:
10593  * The calling sequence is identical to POSIX utime(), but under
10594  * VMS with ODS-2, only the modification time is changed; ODS-2 does
10595  * not maintain access times.  Restrictions differ from the POSIX
10596  * definition in that the time can be changed as long as the
10597  * caller has permission to execute the necessary IO$_MODIFY $QIO;
10598  * no separate checks are made to insure that the caller is the
10599  * owner of the file or has special privs enabled.
10600  * Code here is based on Joe Meadows' FILE utility.
10601  *
10602  */
10603
10604 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10605  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
10606  * in 100 ns intervals.
10607  */
10608 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10609
10610 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10611 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10612 {
10613 #if __CRTL_VER >= 70300000
10614   struct utimbuf utc_utimes, *utc_utimesp;
10615
10616   if (utimes != NULL) {
10617     utc_utimes.actime = utimes->actime;
10618     utc_utimes.modtime = utimes->modtime;
10619 # ifdef VMSISH_TIME
10620     /* If input was local; convert to UTC for sys svc */
10621     if (VMSISH_TIME) {
10622       utc_utimes.actime = _toutc(utimes->actime);
10623       utc_utimes.modtime = _toutc(utimes->modtime);
10624     }
10625 # endif
10626     utc_utimesp = &utc_utimes;
10627   }
10628   else {
10629     utc_utimesp = NULL;
10630   }
10631
10632   return utime(file, utc_utimesp);
10633
10634 #else /* __CRTL_VER < 70300000 */
10635
10636   register int i;
10637   int sts;
10638   long int bintime[2], len = 2, lowbit, unixtime,
10639            secscale = 10000000; /* seconds --> 100 ns intervals */
10640   unsigned long int chan, iosb[2], retsts;
10641   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10642   struct FAB myfab = cc$rms_fab;
10643   struct NAM mynam = cc$rms_nam;
10644 #if defined (__DECC) && defined (__VAX)
10645   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10646    * at least through VMS V6.1, which causes a type-conversion warning.
10647    */
10648 #  pragma message save
10649 #  pragma message disable cvtdiftypes
10650 #endif
10651   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10652   struct fibdef myfib;
10653 #if defined (__DECC) && defined (__VAX)
10654   /* This should be right after the declaration of myatr, but due
10655    * to a bug in VAX DEC C, this takes effect a statement early.
10656    */
10657 #  pragma message restore
10658 #endif
10659   /* cast ok for read only parameter */
10660   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10661                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10662                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10663
10664   if (file == NULL || *file == '\0') {
10665     SETERRNO(ENOENT, LIB$_INVARG);
10666     return -1;
10667   }
10668
10669   /* Convert to VMS format ensuring that it will fit in 255 characters */
10670   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10671       SETERRNO(ENOENT, LIB$_INVARG);
10672       return -1;
10673   }
10674   if (utimes != NULL) {
10675     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
10676      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10677      * Since time_t is unsigned long int, and lib$emul takes a signed long int
10678      * as input, we force the sign bit to be clear by shifting unixtime right
10679      * one bit, then multiplying by an extra factor of 2 in lib$emul().
10680      */
10681     lowbit = (utimes->modtime & 1) ? secscale : 0;
10682     unixtime = (long int) utimes->modtime;
10683 #   ifdef VMSISH_TIME
10684     /* If input was UTC; convert to local for sys svc */
10685     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10686 #   endif
10687     unixtime >>= 1;  secscale <<= 1;
10688     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10689     if (!(retsts & 1)) {
10690       SETERRNO(EVMSERR, retsts);
10691       return -1;
10692     }
10693     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10694     if (!(retsts & 1)) {
10695       SETERRNO(EVMSERR, retsts);
10696       return -1;
10697     }
10698   }
10699   else {
10700     /* Just get the current time in VMS format directly */
10701     retsts = sys$gettim(bintime);
10702     if (!(retsts & 1)) {
10703       SETERRNO(EVMSERR, retsts);
10704       return -1;
10705     }
10706   }
10707
10708   myfab.fab$l_fna = vmsspec;
10709   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10710   myfab.fab$l_nam = &mynam;
10711   mynam.nam$l_esa = esa;
10712   mynam.nam$b_ess = (unsigned char) sizeof esa;
10713   mynam.nam$l_rsa = rsa;
10714   mynam.nam$b_rss = (unsigned char) sizeof rsa;
10715   if (decc_efs_case_preserve)
10716       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10717
10718   /* Look for the file to be affected, letting RMS parse the file
10719    * specification for us as well.  I have set errno using only
10720    * values documented in the utime() man page for VMS POSIX.
10721    */
10722   retsts = sys$parse(&myfab,0,0);
10723   if (!(retsts & 1)) {
10724     set_vaxc_errno(retsts);
10725     if      (retsts == RMS$_PRV) set_errno(EACCES);
10726     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10727     else                         set_errno(EVMSERR);
10728     return -1;
10729   }
10730   retsts = sys$search(&myfab,0,0);
10731   if (!(retsts & 1)) {
10732     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10733     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10734     set_vaxc_errno(retsts);
10735     if      (retsts == RMS$_PRV) set_errno(EACCES);
10736     else if (retsts == RMS$_FNF) set_errno(ENOENT);
10737     else                         set_errno(EVMSERR);
10738     return -1;
10739   }
10740
10741   devdsc.dsc$w_length = mynam.nam$b_dev;
10742   /* cast ok for read only parameter */
10743   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10744
10745   retsts = sys$assign(&devdsc,&chan,0,0);
10746   if (!(retsts & 1)) {
10747     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10748     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10749     set_vaxc_errno(retsts);
10750     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
10751     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
10752     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
10753     else                               set_errno(EVMSERR);
10754     return -1;
10755   }
10756
10757   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10758   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10759
10760   memset((void *) &myfib, 0, sizeof myfib);
10761 #if defined(__DECC) || defined(__DECCXX)
10762   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10763   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10764   /* This prevents the revision time of the file being reset to the current
10765    * time as a result of our IO$_MODIFY $QIO. */
10766   myfib.fib$l_acctl = FIB$M_NORECORD;
10767 #else
10768   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10769   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10770   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10771 #endif
10772   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10773   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10774   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10775   _ckvmssts(sys$dassgn(chan));
10776   if (retsts & 1) retsts = iosb[0];
10777   if (!(retsts & 1)) {
10778     set_vaxc_errno(retsts);
10779     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10780     else                      set_errno(EVMSERR);
10781     return -1;
10782   }
10783
10784   return 0;
10785
10786 #endif /* #if __CRTL_VER >= 70300000 */
10787
10788 }  /* end of my_utime() */
10789 /*}}}*/
10790
10791 /*
10792  * flex_stat, flex_lstat, flex_fstat
10793  * basic stat, but gets it right when asked to stat
10794  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10795  */
10796
10797 #ifndef _USE_STD_STAT
10798 /* encode_dev packs a VMS device name string into an integer to allow
10799  * simple comparisons. This can be used, for example, to check whether two
10800  * files are located on the same device, by comparing their encoded device
10801  * names. Even a string comparison would not do, because stat() reuses the
10802  * device name buffer for each call; so without encode_dev, it would be
10803  * necessary to save the buffer and use strcmp (this would mean a number of
10804  * changes to the standard Perl code, to say nothing of what a Perl script
10805  * would have to do.
10806  *
10807  * The device lock id, if it exists, should be unique (unless perhaps compared
10808  * with lock ids transferred from other nodes). We have a lock id if the disk is
10809  * mounted cluster-wide, which is when we tend to get long (host-qualified)
10810  * device names. Thus we use the lock id in preference, and only if that isn't
10811  * available, do we try to pack the device name into an integer (flagged by
10812  * the sign bit (LOCKID_MASK) being set).
10813  *
10814  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10815  * name and its encoded form, but it seems very unlikely that we will find
10816  * two files on different disks that share the same encoded device names,
10817  * and even more remote that they will share the same file id (if the test
10818  * is to check for the same file).
10819  *
10820  * A better method might be to use sys$device_scan on the first call, and to
10821  * search for the device, returning an index into the cached array.
10822  * The number returned would be more intelligible.
10823  * This is probably not worth it, and anyway would take quite a bit longer
10824  * on the first call.
10825  */
10826 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
10827 static mydev_t encode_dev (pTHX_ const char *dev)
10828 {
10829   int i;
10830   unsigned long int f;
10831   mydev_t enc;
10832   char c;
10833   const char *q;
10834
10835   if (!dev || !dev[0]) return 0;
10836
10837 #if LOCKID_MASK
10838   {
10839     struct dsc$descriptor_s dev_desc;
10840     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10841
10842     /* For cluster-mounted disks, the disk lock identifier is unique, so we
10843        can try that first. */
10844     dev_desc.dsc$w_length =  strlen (dev);
10845     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
10846     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
10847     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
10848     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10849     if (!$VMS_STATUS_SUCCESS(status)) {
10850       switch (status) {
10851         case SS$_NOSUCHDEV:
10852           SETERRNO(ENODEV, status);
10853           return 0;
10854         default:
10855           _ckvmssts(status);
10856       }
10857     }
10858     if (lockid) return (lockid & ~LOCKID_MASK);
10859   }
10860 #endif
10861
10862   /* Otherwise we try to encode the device name */
10863   enc = 0;
10864   f = 1;
10865   i = 0;
10866   for (q = dev + strlen(dev); q--; q >= dev) {
10867     if (*q == ':')
10868         break;
10869     if (isdigit (*q))
10870       c= (*q) - '0';
10871     else if (isalpha (toupper (*q)))
10872       c= toupper (*q) - 'A' + (char)10;
10873     else
10874       continue; /* Skip '$'s */
10875     i++;
10876     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
10877     if (i>1) f *= 36;
10878     enc += f * (unsigned long int) c;
10879   }
10880   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
10881
10882 }  /* end of encode_dev() */
10883 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10884         device_no = encode_dev(aTHX_ devname)
10885 #else
10886 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10887         device_no = new_dev_no
10888 #endif
10889
10890 static int
10891 is_null_device(name)
10892     const char *name;
10893 {
10894   if (decc_bug_devnull != 0) {
10895     if (strncmp("/dev/null", name, 9) == 0)
10896       return 1;
10897   }
10898     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10899        The underscore prefix, controller letter, and unit number are
10900        independently optional; for our purposes, the colon punctuation
10901        is not.  The colon can be trailed by optional directory and/or
10902        filename, but two consecutive colons indicates a nodename rather
10903        than a device.  [pr]  */
10904   if (*name == '_') ++name;
10905   if (tolower(*name++) != 'n') return 0;
10906   if (tolower(*name++) != 'l') return 0;
10907   if (tolower(*name) == 'a') ++name;
10908   if (*name == '0') ++name;
10909   return (*name++ == ':') && (*name != ':');
10910 }
10911
10912
10913 static I32
10914 Perl_cando_by_name_int
10915    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10916 {
10917   static char usrname[L_cuserid];
10918   static struct dsc$descriptor_s usrdsc =
10919          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10920   char vmsname[NAM$C_MAXRSS+1];
10921   char *fileified;
10922   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10923   unsigned short int retlen, trnlnm_iter_count;
10924   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10925   union prvdef curprv;
10926   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10927          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10928          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10929   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10930          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10931          {0,0,0,0}};
10932   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10933          {0,0,0,0}};
10934   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10935
10936   if (!fname || !*fname) return FALSE;
10937   /* Make sure we expand logical names, since sys$check_access doesn't */
10938
10939   fileified = NULL;
10940   if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
10941     fileified = PerlMem_malloc(VMS_MAXRSS);
10942     if (!strpbrk(fname,"/]>:")) {
10943       strcpy(fileified,fname);
10944       trnlnm_iter_count = 0;
10945       while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10946         trnlnm_iter_count++;
10947         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10948       }
10949       fname = fileified;
10950     }
10951     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10952       PerlMem_free(fileified);
10953       return FALSE;
10954     }
10955     retlen = namdsc.dsc$w_length = strlen(vmsname);
10956     namdsc.dsc$a_pointer = vmsname;
10957     if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10958       vmsname[retlen-1] == ':') {
10959       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) return FALSE;
10960       namdsc.dsc$w_length = strlen(fileified);
10961       namdsc.dsc$a_pointer = fileified;
10962     }
10963   }
10964   else {
10965     retlen = namdsc.dsc$w_length = strlen(fname);
10966     namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
10967   }
10968
10969   switch (bit) {
10970     case S_IXUSR: case S_IXGRP: case S_IXOTH:
10971       access = ARM$M_EXECUTE;
10972       flags = CHP$M_READ;
10973       break;
10974     case S_IRUSR: case S_IRGRP: case S_IROTH:
10975       access = ARM$M_READ;
10976       flags = CHP$M_READ | CHP$M_USEREADALL;
10977       break;
10978     case S_IWUSR: case S_IWGRP: case S_IWOTH:
10979       access = ARM$M_WRITE;
10980       flags = CHP$M_READ | CHP$M_WRITE;
10981       break;
10982     case S_IDUSR: case S_IDGRP: case S_IDOTH:
10983       access = ARM$M_DELETE;
10984       flags = CHP$M_READ | CHP$M_WRITE;
10985       break;
10986     default:
10987       if (fileified != NULL)
10988         PerlMem_free(fileified);
10989       return FALSE;
10990   }
10991
10992   /* Before we call $check_access, create a user profile with the current
10993    * process privs since otherwise it just uses the default privs from the
10994    * UAF and might give false positives or negatives.  This only works on
10995    * VMS versions v6.0 and later since that's when sys$create_user_profile
10996    * became available.
10997    */
10998
10999   /* get current process privs and username */
11000   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11001   _ckvmssts(iosb[0]);
11002
11003 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11004
11005   /* find out the space required for the profile */
11006   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11007                                     &usrprodsc.dsc$w_length,0));
11008
11009   /* allocate space for the profile and get it filled in */
11010   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11011   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11012   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11013                                     &usrprodsc.dsc$w_length,0));
11014
11015   /* use the profile to check access to the file; free profile & analyze results */
11016   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
11017   PerlMem_free(usrprodsc.dsc$a_pointer);
11018   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11019
11020 #else
11021
11022   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11023
11024 #endif
11025
11026   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11027       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11028       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11029     set_vaxc_errno(retsts);
11030     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11031     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11032     else set_errno(ENOENT);
11033     if (fileified != NULL)
11034       PerlMem_free(fileified);
11035     return FALSE;
11036   }
11037   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11038     if (fileified != NULL)
11039       PerlMem_free(fileified);
11040     return TRUE;
11041   }
11042   _ckvmssts(retsts);
11043
11044   if (fileified != NULL)
11045     PerlMem_free(fileified);
11046   return FALSE;  /* Should never get here */
11047
11048 }
11049
11050 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
11051 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11052  * subset of the applicable information.
11053  */
11054 bool
11055 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11056 {
11057   return cando_by_name_int
11058         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11059 }  /* end of cando() */
11060 /*}}}*/
11061
11062
11063 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11064 I32
11065 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11066 {
11067    return cando_by_name_int(bit, effective, fname, 0);
11068
11069 }  /* end of cando_by_name() */
11070 /*}}}*/
11071
11072
11073 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11074 int
11075 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11076 {
11077   if (!fstat(fd,(stat_t *) statbufp)) {
11078     char *cptr;
11079     char *vms_filename;
11080     vms_filename = PerlMem_malloc(VMS_MAXRSS);
11081     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11082
11083     /* Save name for cando by name in VMS format */
11084     cptr = getname(fd, vms_filename, 1);
11085
11086     /* This should not happen, but just in case */
11087     if (cptr == NULL) {
11088         statbufp->st_devnam[0] = 0;
11089     }
11090     else {
11091         /* Make sure that the saved name fits in 255 characters */
11092         cptr = do_rmsexpand
11093                        (vms_filename,
11094                         statbufp->st_devnam,
11095                         0,
11096                         NULL,
11097                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11098                         NULL,
11099                         NULL);
11100         if (cptr == NULL)
11101             statbufp->st_devnam[0] = 0;
11102     }
11103     PerlMem_free(vms_filename);
11104
11105     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11106     VMS_DEVICE_ENCODE
11107         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11108
11109 #   ifdef RTL_USES_UTC
11110 #   ifdef VMSISH_TIME
11111     if (VMSISH_TIME) {
11112       statbufp->st_mtime = _toloc(statbufp->st_mtime);
11113       statbufp->st_atime = _toloc(statbufp->st_atime);
11114       statbufp->st_ctime = _toloc(statbufp->st_ctime);
11115     }
11116 #   endif
11117 #   else
11118 #   ifdef VMSISH_TIME
11119     if (!VMSISH_TIME) { /* Return UTC instead of local time */
11120 #   else
11121     if (1) {
11122 #   endif
11123       statbufp->st_mtime = _toutc(statbufp->st_mtime);
11124       statbufp->st_atime = _toutc(statbufp->st_atime);
11125       statbufp->st_ctime = _toutc(statbufp->st_ctime);
11126     }
11127 #endif
11128     return 0;
11129   }
11130   return -1;
11131
11132 }  /* end of flex_fstat() */
11133 /*}}}*/
11134
11135 #if !defined(__VAX) && __CRTL_VER >= 80200000
11136 #ifdef lstat
11137 #undef lstat
11138 #endif
11139 #else
11140 #ifdef lstat
11141 #undef lstat
11142 #endif
11143 #define lstat(_x, _y) stat(_x, _y)
11144 #endif
11145
11146 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11147
11148 static int
11149 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11150 {
11151     char fileified[VMS_MAXRSS];
11152     char temp_fspec[VMS_MAXRSS];
11153     char *save_spec;
11154     int retval = -1;
11155     int saved_errno, saved_vaxc_errno;
11156
11157     if (!fspec) return retval;
11158     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11159     strcpy(temp_fspec, fspec);
11160
11161     if (decc_bug_devnull != 0) {
11162       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11163         memset(statbufp,0,sizeof *statbufp);
11164         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11165         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11166         statbufp->st_uid = 0x00010001;
11167         statbufp->st_gid = 0x0001;
11168         time((time_t *)&statbufp->st_mtime);
11169         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11170         return 0;
11171       }
11172     }
11173
11174     /* Try for a directory name first.  If fspec contains a filename without
11175      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11176      * and sea:[wine.dark]water. exist, we prefer the directory here.
11177      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11178      * not sea:[wine.dark]., if the latter exists.  If the intended target is
11179      * the file with null type, specify this by calling flex_stat() with
11180      * a '.' at the end of fspec.
11181      *
11182      * If we are in Posix filespec mode, accept the filename as is.
11183      */
11184 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11185   if (decc_posix_compliant_pathnames == 0) {
11186 #endif
11187     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11188       if (lstat_flag == 0)
11189         retval = stat(fileified,(stat_t *) statbufp);
11190       else
11191         retval = lstat(fileified,(stat_t *) statbufp);
11192       save_spec = fileified;
11193     }
11194     if (retval) {
11195       if (lstat_flag == 0)
11196         retval = stat(temp_fspec,(stat_t *) statbufp);
11197       else
11198         retval = lstat(temp_fspec,(stat_t *) statbufp);
11199       save_spec = temp_fspec;
11200     }
11201 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11202   } else {
11203     if (lstat_flag == 0)
11204       retval = stat(temp_fspec,(stat_t *) statbufp);
11205     else
11206       retval = lstat(temp_fspec,(stat_t *) statbufp);
11207       save_spec = temp_fspec;
11208   }
11209 #endif
11210     if (!retval) {
11211     char * cptr;
11212       cptr = do_rmsexpand
11213        (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
11214       if (cptr == NULL)
11215         statbufp->st_devnam[0] = 0;
11216
11217       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11218       VMS_DEVICE_ENCODE
11219         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11220 #     ifdef RTL_USES_UTC
11221 #     ifdef VMSISH_TIME
11222       if (VMSISH_TIME) {
11223         statbufp->st_mtime = _toloc(statbufp->st_mtime);
11224         statbufp->st_atime = _toloc(statbufp->st_atime);
11225         statbufp->st_ctime = _toloc(statbufp->st_ctime);
11226       }
11227 #     endif
11228 #     else
11229 #     ifdef VMSISH_TIME
11230       if (!VMSISH_TIME) { /* Return UTC instead of local time */
11231 #     else
11232       if (1) {
11233 #     endif
11234         statbufp->st_mtime = _toutc(statbufp->st_mtime);
11235         statbufp->st_atime = _toutc(statbufp->st_atime);
11236         statbufp->st_ctime = _toutc(statbufp->st_ctime);
11237       }
11238 #     endif
11239     }
11240     /* If we were successful, leave errno where we found it */
11241     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
11242     return retval;
11243
11244 }  /* end of flex_stat_int() */
11245
11246
11247 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
11248 int
11249 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
11250 {
11251    return flex_stat_int(fspec, statbufp, 0);
11252 }
11253 /*}}}*/
11254
11255 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
11256 int
11257 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
11258 {
11259    return flex_stat_int(fspec, statbufp, 1);
11260 }
11261 /*}}}*/
11262
11263
11264 /*{{{char *my_getlogin()*/
11265 /* VMS cuserid == Unix getlogin, except calling sequence */
11266 char *
11267 my_getlogin(void)
11268 {
11269     static char user[L_cuserid];
11270     return cuserid(user);
11271 }
11272 /*}}}*/
11273
11274
11275 /*  rmscopy - copy a file using VMS RMS routines
11276  *
11277  *  Copies contents and attributes of spec_in to spec_out, except owner
11278  *  and protection information.  Name and type of spec_in are used as
11279  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
11280  *  should try to propagate timestamps from the input file to the output file.
11281  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
11282  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
11283  *  propagated to the output file at creation iff the output file specification
11284  *  did not contain an explicit name or type, and the revision date is always
11285  *  updated at the end of the copy operation.  If it is greater than 0, then
11286  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11287  *  other than the revision date should be propagated, and bit 1 indicates
11288  *  that the revision date should be propagated.
11289  *
11290  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11291  *
11292  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11293  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
11294  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
11295  * as part of the Perl standard distribution under the terms of the
11296  * GNU General Public License or the Perl Artistic License.  Copies
11297  * of each may be found in the Perl standard distribution.
11298  */ /* FIXME */
11299 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11300 int
11301 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11302 {
11303     char *vmsin, * vmsout, *esa, *esa_out,
11304          *rsa, *ubf;
11305     unsigned long int i, sts, sts2;
11306     int dna_len;
11307     struct FAB fab_in, fab_out;
11308     struct RAB rab_in, rab_out;
11309     rms_setup_nam(nam);
11310     rms_setup_nam(nam_out);
11311     struct XABDAT xabdat;
11312     struct XABFHC xabfhc;
11313     struct XABRDT xabrdt;
11314     struct XABSUM xabsum;
11315
11316     vmsin = PerlMem_malloc(VMS_MAXRSS);
11317     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11318     vmsout = PerlMem_malloc(VMS_MAXRSS);
11319     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11320     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11321         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11322       PerlMem_free(vmsin);
11323       PerlMem_free(vmsout);
11324       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11325       return 0;
11326     }
11327
11328     esa = PerlMem_malloc(VMS_MAXRSS);
11329     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11330     fab_in = cc$rms_fab;
11331     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11332     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11333     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11334     fab_in.fab$l_fop = FAB$M_SQO;
11335     rms_bind_fab_nam(fab_in, nam);
11336     fab_in.fab$l_xab = (void *) &xabdat;
11337
11338     rsa = PerlMem_malloc(VMS_MAXRSS);
11339     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11340     rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11341     rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11342     rms_nam_esl(nam) = 0;
11343     rms_nam_rsl(nam) = 0;
11344     rms_nam_esll(nam) = 0;
11345     rms_nam_rsll(nam) = 0;
11346 #ifdef NAM$M_NO_SHORT_UPCASE
11347     if (decc_efs_case_preserve)
11348         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11349 #endif
11350
11351     xabdat = cc$rms_xabdat;        /* To get creation date */
11352     xabdat.xab$l_nxt = (void *) &xabfhc;
11353
11354     xabfhc = cc$rms_xabfhc;        /* To get record length */
11355     xabfhc.xab$l_nxt = (void *) &xabsum;
11356
11357     xabsum = cc$rms_xabsum;        /* To get key and area information */
11358
11359     if (!((sts = sys$open(&fab_in)) & 1)) {
11360       PerlMem_free(vmsin);
11361       PerlMem_free(vmsout);
11362       PerlMem_free(esa);
11363       PerlMem_free(rsa);
11364       set_vaxc_errno(sts);
11365       switch (sts) {
11366         case RMS$_FNF: case RMS$_DNF:
11367           set_errno(ENOENT); break;
11368         case RMS$_DIR:
11369           set_errno(ENOTDIR); break;
11370         case RMS$_DEV:
11371           set_errno(ENODEV); break;
11372         case RMS$_SYN:
11373           set_errno(EINVAL); break;
11374         case RMS$_PRV:
11375           set_errno(EACCES); break;
11376         default:
11377           set_errno(EVMSERR);
11378       }
11379       return 0;
11380     }
11381
11382     nam_out = nam;
11383     fab_out = fab_in;
11384     fab_out.fab$w_ifi = 0;
11385     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11386     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11387     fab_out.fab$l_fop = FAB$M_SQO;
11388     rms_bind_fab_nam(fab_out, nam_out);
11389     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11390     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11391     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11392     esa_out = PerlMem_malloc(VMS_MAXRSS);
11393     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11394     rms_set_rsa(nam_out, NULL, 0);
11395     rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11396
11397     if (preserve_dates == 0) {  /* Act like DCL COPY */
11398       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11399       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
11400       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11401         PerlMem_free(vmsin);
11402         PerlMem_free(vmsout);
11403         PerlMem_free(esa);
11404         PerlMem_free(rsa);
11405         PerlMem_free(esa_out);
11406         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11407         set_vaxc_errno(sts);
11408         return 0;
11409       }
11410       fab_out.fab$l_xab = (void *) &xabdat;
11411       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11412         preserve_dates = 1;
11413     }
11414     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
11415       preserve_dates =0;      /* bitmask from this point forward   */
11416
11417     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11418     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11419       PerlMem_free(vmsin);
11420       PerlMem_free(vmsout);
11421       PerlMem_free(esa);
11422       PerlMem_free(rsa);
11423       PerlMem_free(esa_out);
11424       set_vaxc_errno(sts);
11425       switch (sts) {
11426         case RMS$_DNF:
11427           set_errno(ENOENT); break;
11428         case RMS$_DIR:
11429           set_errno(ENOTDIR); break;
11430         case RMS$_DEV:
11431           set_errno(ENODEV); break;
11432         case RMS$_SYN:
11433           set_errno(EINVAL); break;
11434         case RMS$_PRV:
11435           set_errno(EACCES); break;
11436         default:
11437           set_errno(EVMSERR);
11438       }
11439       return 0;
11440     }
11441     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
11442     if (preserve_dates & 2) {
11443       /* sys$close() will process xabrdt, not xabdat */
11444       xabrdt = cc$rms_xabrdt;
11445 #ifndef __GNUC__
11446       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11447 #else
11448       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11449        * is unsigned long[2], while DECC & VAXC use a struct */
11450       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11451 #endif
11452       fab_out.fab$l_xab = (void *) &xabrdt;
11453     }
11454
11455     ubf = PerlMem_malloc(32256);
11456     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11457     rab_in = cc$rms_rab;
11458     rab_in.rab$l_fab = &fab_in;
11459     rab_in.rab$l_rop = RAB$M_BIO;
11460     rab_in.rab$l_ubf = ubf;
11461     rab_in.rab$w_usz = 32256;
11462     if (!((sts = sys$connect(&rab_in)) & 1)) {
11463       sys$close(&fab_in); sys$close(&fab_out);
11464       PerlMem_free(vmsin);
11465       PerlMem_free(vmsout);
11466       PerlMem_free(esa);
11467       PerlMem_free(ubf);
11468       PerlMem_free(rsa);
11469       PerlMem_free(esa_out);
11470       set_errno(EVMSERR); set_vaxc_errno(sts);
11471       return 0;
11472     }
11473
11474     rab_out = cc$rms_rab;
11475     rab_out.rab$l_fab = &fab_out;
11476     rab_out.rab$l_rbf = ubf;
11477     if (!((sts = sys$connect(&rab_out)) & 1)) {
11478       sys$close(&fab_in); sys$close(&fab_out);
11479       PerlMem_free(vmsin);
11480       PerlMem_free(vmsout);
11481       PerlMem_free(esa);
11482       PerlMem_free(ubf);
11483       PerlMem_free(rsa);
11484       PerlMem_free(esa_out);
11485       set_errno(EVMSERR); set_vaxc_errno(sts);
11486       return 0;
11487     }
11488
11489     while ((sts = sys$read(&rab_in))) {  /* always true  */
11490       if (sts == RMS$_EOF) break;
11491       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11492       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11493         sys$close(&fab_in); sys$close(&fab_out);
11494         PerlMem_free(vmsin);
11495         PerlMem_free(vmsout);
11496         PerlMem_free(esa);
11497         PerlMem_free(ubf);
11498         PerlMem_free(rsa);
11499         PerlMem_free(esa_out);
11500         set_errno(EVMSERR); set_vaxc_errno(sts);
11501         return 0;
11502       }
11503     }
11504
11505
11506     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
11507     sys$close(&fab_in);  sys$close(&fab_out);
11508     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11509     if (!(sts & 1)) {
11510       PerlMem_free(vmsin);
11511       PerlMem_free(vmsout);
11512       PerlMem_free(esa);
11513       PerlMem_free(ubf);
11514       PerlMem_free(rsa);
11515       PerlMem_free(esa_out);
11516       set_errno(EVMSERR); set_vaxc_errno(sts);
11517       return 0;
11518     }
11519
11520     PerlMem_free(vmsin);
11521     PerlMem_free(vmsout);
11522     PerlMem_free(esa);
11523     PerlMem_free(ubf);
11524     PerlMem_free(rsa);
11525     PerlMem_free(esa_out);
11526     return 1;
11527
11528 }  /* end of rmscopy() */
11529 /*}}}*/
11530
11531
11532 /***  The following glue provides 'hooks' to make some of the routines
11533  * from this file available from Perl.  These routines are sufficiently
11534  * basic, and are required sufficiently early in the build process,
11535  * that's it's nice to have them available to miniperl as well as the
11536  * full Perl, so they're set up here instead of in an extension.  The
11537  * Perl code which handles importation of these names into a given
11538  * package lives in [.VMS]Filespec.pm in @INC.
11539  */
11540
11541 void
11542 rmsexpand_fromperl(pTHX_ CV *cv)
11543 {
11544   dXSARGS;
11545   char *fspec, *defspec = NULL, *rslt;
11546   STRLEN n_a;
11547   int fs_utf8, dfs_utf8;
11548
11549   fs_utf8 = 0;
11550   dfs_utf8 = 0;
11551   if (!items || items > 2)
11552     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11553   fspec = SvPV(ST(0),n_a);
11554   fs_utf8 = SvUTF8(ST(0));
11555   if (!fspec || !*fspec) XSRETURN_UNDEF;
11556   if (items == 2) {
11557     defspec = SvPV(ST(1),n_a);
11558     dfs_utf8 = SvUTF8(ST(1));
11559   }
11560   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11561   ST(0) = sv_newmortal();
11562   if (rslt != NULL) {
11563     sv_usepvn(ST(0),rslt,strlen(rslt));
11564     if (fs_utf8) {
11565         SvUTF8_on(ST(0));
11566     }
11567   }
11568   XSRETURN(1);
11569 }
11570
11571 void
11572 vmsify_fromperl(pTHX_ CV *cv)
11573 {
11574   dXSARGS;
11575   char *vmsified;
11576   STRLEN n_a;
11577   int utf8_fl;
11578
11579   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11580   utf8_fl = SvUTF8(ST(0));
11581   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11582   ST(0) = sv_newmortal();
11583   if (vmsified != NULL) {
11584     sv_usepvn(ST(0),vmsified,strlen(vmsified));
11585     if (utf8_fl) {
11586         SvUTF8_on(ST(0));
11587     }
11588   }
11589   XSRETURN(1);
11590 }
11591
11592 void
11593 unixify_fromperl(pTHX_ CV *cv)
11594 {
11595   dXSARGS;
11596   char *unixified;
11597   STRLEN n_a;
11598   int utf8_fl;
11599
11600   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11601   utf8_fl = SvUTF8(ST(0));
11602   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11603   ST(0) = sv_newmortal();
11604   if (unixified != NULL) {
11605     sv_usepvn(ST(0),unixified,strlen(unixified));
11606     if (utf8_fl) {
11607         SvUTF8_on(ST(0));
11608     }
11609   }
11610   XSRETURN(1);
11611 }
11612
11613 void
11614 fileify_fromperl(pTHX_ CV *cv)
11615 {
11616   dXSARGS;
11617   char *fileified;
11618   STRLEN n_a;
11619   int utf8_fl;
11620
11621   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11622   utf8_fl = SvUTF8(ST(0));
11623   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11624   ST(0) = sv_newmortal();
11625   if (fileified != NULL) {
11626     sv_usepvn(ST(0),fileified,strlen(fileified));
11627     if (utf8_fl) {
11628         SvUTF8_on(ST(0));
11629     }
11630   }
11631   XSRETURN(1);
11632 }
11633
11634 void
11635 pathify_fromperl(pTHX_ CV *cv)
11636 {
11637   dXSARGS;
11638   char *pathified;
11639   STRLEN n_a;
11640   int utf8_fl;
11641
11642   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11643   utf8_fl = SvUTF8(ST(0));
11644   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11645   ST(0) = sv_newmortal();
11646   if (pathified != NULL) {
11647     sv_usepvn(ST(0),pathified,strlen(pathified));
11648     if (utf8_fl) {
11649         SvUTF8_on(ST(0));
11650     }
11651   }
11652   XSRETURN(1);
11653 }
11654
11655 void
11656 vmspath_fromperl(pTHX_ CV *cv)
11657 {
11658   dXSARGS;
11659   char *vmspath;
11660   STRLEN n_a;
11661   int utf8_fl;
11662
11663   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11664   utf8_fl = SvUTF8(ST(0));
11665   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11666   ST(0) = sv_newmortal();
11667   if (vmspath != NULL) {
11668     sv_usepvn(ST(0),vmspath,strlen(vmspath));
11669     if (utf8_fl) {
11670         SvUTF8_on(ST(0));
11671     }
11672   }
11673   XSRETURN(1);
11674 }
11675
11676 void
11677 unixpath_fromperl(pTHX_ CV *cv)
11678 {
11679   dXSARGS;
11680   char *unixpath;
11681   STRLEN n_a;
11682   int utf8_fl;
11683
11684   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11685   utf8_fl = SvUTF8(ST(0));
11686   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11687   ST(0) = sv_newmortal();
11688   if (unixpath != NULL) {
11689     sv_usepvn(ST(0),unixpath,strlen(unixpath));
11690     if (utf8_fl) {
11691         SvUTF8_on(ST(0));
11692     }
11693   }
11694   XSRETURN(1);
11695 }
11696
11697 void
11698 candelete_fromperl(pTHX_ CV *cv)
11699 {
11700   dXSARGS;
11701   char *fspec, *fsp;
11702   SV *mysv;
11703   IO *io;
11704   STRLEN n_a;
11705
11706   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11707
11708   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11709   Newx(fspec, VMS_MAXRSS, char);
11710   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11711   if (SvTYPE(mysv) == SVt_PVGV) {
11712     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11713       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11714       ST(0) = &PL_sv_no;
11715       Safefree(fspec);
11716       XSRETURN(1);
11717     }
11718     fsp = fspec;
11719   }
11720   else {
11721     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11722       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11723       ST(0) = &PL_sv_no;
11724       Safefree(fspec);
11725       XSRETURN(1);
11726     }
11727   }
11728
11729   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11730   Safefree(fspec);
11731   XSRETURN(1);
11732 }
11733
11734 void
11735 rmscopy_fromperl(pTHX_ CV *cv)
11736 {
11737   dXSARGS;
11738   char *inspec, *outspec, *inp, *outp;
11739   int date_flag;
11740   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11741                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11742   unsigned long int sts;
11743   SV *mysv;
11744   IO *io;
11745   STRLEN n_a;
11746
11747   if (items < 2 || items > 3)
11748     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11749
11750   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11751   Newx(inspec, VMS_MAXRSS, char);
11752   if (SvTYPE(mysv) == SVt_PVGV) {
11753     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11754       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11755       ST(0) = &PL_sv_no;
11756       Safefree(inspec);
11757       XSRETURN(1);
11758     }
11759     inp = inspec;
11760   }
11761   else {
11762     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11763       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11764       ST(0) = &PL_sv_no;
11765       Safefree(inspec);
11766       XSRETURN(1);
11767     }
11768   }
11769   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11770   Newx(outspec, VMS_MAXRSS, char);
11771   if (SvTYPE(mysv) == SVt_PVGV) {
11772     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11773       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11774       ST(0) = &PL_sv_no;
11775       Safefree(inspec);
11776       Safefree(outspec);
11777       XSRETURN(1);
11778     }
11779     outp = outspec;
11780   }
11781   else {
11782     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11783       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11784       ST(0) = &PL_sv_no;
11785       Safefree(inspec);
11786       Safefree(outspec);
11787       XSRETURN(1);
11788     }
11789   }
11790   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11791
11792   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11793   Safefree(inspec);
11794   Safefree(outspec);
11795   XSRETURN(1);
11796 }
11797
11798 /* The mod2fname is limited to shorter filenames by design, so it should
11799  * not be modified to support longer EFS pathnames
11800  */
11801 void
11802 mod2fname(pTHX_ CV *cv)
11803 {
11804   dXSARGS;
11805   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11806        workbuff[NAM$C_MAXRSS*1 + 1];
11807   int total_namelen = 3, counter, num_entries;
11808   /* ODS-5 ups this, but we want to be consistent, so... */
11809   int max_name_len = 39;
11810   AV *in_array = (AV *)SvRV(ST(0));
11811
11812   num_entries = av_len(in_array);
11813
11814   /* All the names start with PL_. */
11815   strcpy(ultimate_name, "PL_");
11816
11817   /* Clean up our working buffer */
11818   Zero(work_name, sizeof(work_name), char);
11819
11820   /* Run through the entries and build up a working name */
11821   for(counter = 0; counter <= num_entries; counter++) {
11822     /* If it's not the first name then tack on a __ */
11823     if (counter) {
11824       strcat(work_name, "__");
11825     }
11826     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11827                            PL_na));
11828   }
11829
11830   /* Check to see if we actually have to bother...*/
11831   if (strlen(work_name) + 3 <= max_name_len) {
11832     strcat(ultimate_name, work_name);
11833   } else {
11834     /* It's too darned big, so we need to go strip. We use the same */
11835     /* algorithm as xsubpp does. First, strip out doubled __ */
11836     char *source, *dest, last;
11837     dest = workbuff;
11838     last = 0;
11839     for (source = work_name; *source; source++) {
11840       if (last == *source && last == '_') {
11841         continue;
11842       }
11843       *dest++ = *source;
11844       last = *source;
11845     }
11846     /* Go put it back */
11847     strcpy(work_name, workbuff);
11848     /* Is it still too big? */
11849     if (strlen(work_name) + 3 > max_name_len) {
11850       /* Strip duplicate letters */
11851       last = 0;
11852       dest = workbuff;
11853       for (source = work_name; *source; source++) {
11854         if (last == toupper(*source)) {
11855         continue;
11856         }
11857         *dest++ = *source;
11858         last = toupper(*source);
11859       }
11860       strcpy(work_name, workbuff);
11861     }
11862
11863     /* Is it *still* too big? */
11864     if (strlen(work_name) + 3 > max_name_len) {
11865       /* Too bad, we truncate */
11866       work_name[max_name_len - 2] = 0;
11867     }
11868     strcat(ultimate_name, work_name);
11869   }
11870
11871   /* Okay, return it */
11872   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11873   XSRETURN(1);
11874 }
11875
11876 void
11877 hushexit_fromperl(pTHX_ CV *cv)
11878 {
11879     dXSARGS;
11880
11881     if (items > 0) {
11882         VMSISH_HUSHED = SvTRUE(ST(0));
11883     }
11884     ST(0) = boolSV(VMSISH_HUSHED);
11885     XSRETURN(1);
11886 }
11887
11888
11889 PerlIO *
11890 Perl_vms_start_glob
11891    (pTHX_ SV *tmpglob,
11892     IO *io)
11893 {
11894     PerlIO *fp;
11895     struct vs_str_st *rslt;
11896     char *vmsspec;
11897     char *rstr;
11898     char *begin, *cp;
11899     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11900     PerlIO *tmpfp;
11901     STRLEN i;
11902     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11903     struct dsc$descriptor_vs rsdsc;
11904     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11905     unsigned long hasver = 0, isunix = 0;
11906     unsigned long int lff_flags = 0;
11907     int rms_sts;
11908
11909 #ifdef VMS_LONGNAME_SUPPORT
11910     lff_flags = LIB$M_FIL_LONG_NAMES;
11911 #endif
11912     /* The Newx macro will not allow me to assign a smaller array
11913      * to the rslt pointer, so we will assign it to the begin char pointer
11914      * and then copy the value into the rslt pointer.
11915      */
11916     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11917     rslt = (struct vs_str_st *)begin;
11918     rslt->length = 0;
11919     rstr = &rslt->str[0];
11920     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11921     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11922     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11923     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11924
11925     Newx(vmsspec, VMS_MAXRSS, char);
11926
11927         /* We could find out if there's an explicit dev/dir or version
11928            by peeking into lib$find_file's internal context at
11929            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11930            but that's unsupported, so I don't want to do it now and
11931            have it bite someone in the future. */
11932         /* Fix-me: vms_split_path() is the only way to do this, the
11933            existing method will fail with many legal EFS or UNIX specifications
11934          */
11935
11936     cp = SvPV(tmpglob,i);
11937
11938     for (; i; i--) {
11939         if (cp[i] == ';') hasver = 1;
11940         if (cp[i] == '.') {
11941             if (sts) hasver = 1;
11942             else sts = 1;
11943         }
11944         if (cp[i] == '/') {
11945             hasdir = isunix = 1;
11946             break;
11947         }
11948         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11949             hasdir = 1;
11950             break;
11951         }
11952     }
11953     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11954         Stat_t st;
11955         int stat_sts;
11956         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11957         if (!stat_sts && S_ISDIR(st.st_mode)) {
11958             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
11959             ok = (wilddsc.dsc$a_pointer != NULL);
11960         }
11961         else {
11962             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
11963             ok = (wilddsc.dsc$a_pointer != NULL);
11964         }
11965         if (ok)
11966             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11967
11968         /* If not extended character set, replace ? with % */
11969         /* With extended character set, ? is a wildcard single character */
11970         if (!decc_efs_case_preserve) {
11971             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11972                 if (*cp == '?') *cp = '%';
11973         }
11974         sts = SS$_NORMAL;
11975         while (ok && $VMS_STATUS_SUCCESS(sts)) {
11976          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11977          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11978
11979             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11980                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
11981             if (!$VMS_STATUS_SUCCESS(sts))
11982                 break;
11983
11984             /* with varying string, 1st word of buffer contains result length */
11985             rstr[rslt->length] = '\0';
11986
11987              /* Find where all the components are */
11988              v_sts = vms_split_path
11989                        (rstr,
11990                         &v_spec,
11991                         &v_len,
11992                         &r_spec,
11993                         &r_len,
11994                         &d_spec,
11995                         &d_len,
11996                         &n_spec,
11997                         &n_len,
11998                         &e_spec,
11999                         &e_len,
12000                         &vs_spec,
12001                         &vs_len);
12002
12003             /* If no version on input, truncate the version on output */
12004             if (!hasver && (vs_len > 0)) {
12005                 *vs_spec = '\0';
12006                 vs_len = 0;
12007
12008                 /* No version & a null extension on UNIX handling */
12009                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12010                     e_len = 0;
12011                     *e_spec = '\0';
12012                 }
12013             }
12014
12015             if (!decc_efs_case_preserve) {
12016                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12017             }
12018
12019             if (hasdir) {
12020                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12021                 begin = rstr;
12022             }
12023             else {
12024                 /* Start with the name */
12025                 begin = n_spec;
12026             }
12027             strcat(begin,"\n");
12028             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12029         }
12030         if (cxt) (void)lib$find_file_end(&cxt);
12031         if (ok && sts != RMS$_NMF &&
12032             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12033         if (!ok) {
12034             if (!(sts & 1)) {
12035                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12036             }
12037             PerlIO_close(tmpfp);
12038             fp = NULL;
12039         }
12040         else {
12041             PerlIO_rewind(tmpfp);
12042             IoTYPE(io) = IoTYPE_RDONLY;
12043             IoIFP(io) = fp = tmpfp;
12044             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
12045         }
12046     }
12047     Safefree(vmsspec);
12048     Safefree(rslt);
12049     return fp;
12050 }
12051
12052
12053 #ifdef HAS_SYMLINK
12054 static char *
12055 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
12056
12057 void
12058 vms_realpath_fromperl(pTHX_ CV *cv)
12059 {
12060   dXSARGS;
12061   char *fspec, *rslt_spec, *rslt;
12062   STRLEN n_a;
12063
12064   if (!items || items != 1)
12065     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12066
12067   fspec = SvPV(ST(0),n_a);
12068   if (!fspec || !*fspec) XSRETURN_UNDEF;
12069
12070   Newx(rslt_spec, VMS_MAXRSS + 1, char);
12071   rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12072   ST(0) = sv_newmortal();
12073   if (rslt != NULL)
12074     sv_usepvn(ST(0),rslt,strlen(rslt));
12075   else
12076     Safefree(rslt_spec);
12077   XSRETURN(1);
12078 }
12079 #endif
12080
12081 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12082 int do_vms_case_tolerant(void);
12083
12084 void
12085 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12086 {
12087   dXSARGS;
12088   ST(0) = boolSV(do_vms_case_tolerant());
12089   XSRETURN(1);
12090 }
12091 #endif
12092
12093 void
12094 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12095                           struct interp_intern *dst)
12096 {
12097     memcpy(dst,src,sizeof(struct interp_intern));
12098 }
12099
12100 void
12101 Perl_sys_intern_clear(pTHX)
12102 {
12103 }
12104
12105 void
12106 Perl_sys_intern_init(pTHX)
12107 {
12108     unsigned int ix = RAND_MAX;
12109     double x;
12110
12111     VMSISH_HUSHED = 0;
12112
12113     /* fix me later to track running under GNV */
12114     /* this allows some limited testing */
12115     MY_POSIX_EXIT = decc_filename_unix_report;
12116
12117     x = (float)ix;
12118     MY_INV_RAND_MAX = 1./x;
12119 }
12120
12121 void
12122 init_os_extras(void)
12123 {
12124   dTHX;
12125   char* file = __FILE__;
12126   if (decc_disable_to_vms_logname_translation) {
12127     no_translate_barewords = TRUE;
12128   } else {
12129     no_translate_barewords = FALSE;
12130   }
12131
12132   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
12133   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
12134   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
12135   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
12136   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
12137   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
12138   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
12139   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
12140   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
12141   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
12142   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
12143 #ifdef HAS_SYMLINK
12144   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
12145 #endif
12146 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12147   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
12148 #endif
12149
12150   store_pipelocs(aTHX);         /* will redo any earlier attempts */
12151
12152   return;
12153 }
12154
12155 #ifdef HAS_SYMLINK
12156
12157 #if __CRTL_VER == 80200000
12158 /* This missed getting in to the DECC SDK for 8.2 */
12159 char *realpath(const char *file_name, char * resolved_name, ...);
12160 #endif
12161
12162 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
12163 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
12164  * The perl fallback routine to provide realpath() is not as efficient
12165  * on OpenVMS.
12166  */
12167 static char *
12168 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12169 {
12170     return realpath(filespec, outbuf);
12171 }
12172
12173 /*}}}*/
12174 /* External entry points */
12175 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12176 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
12177 #else
12178 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12179 { return NULL; }
12180 #endif
12181
12182
12183 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12184 /* case_tolerant */
12185
12186 /*{{{int do_vms_case_tolerant(void)*/
12187 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
12188  * controlled by a process setting.
12189  */
12190 int do_vms_case_tolerant(void)
12191 {
12192     return vms_process_case_tolerant;
12193 }
12194 /*}}}*/
12195 /* External entry points */
12196 int Perl_vms_case_tolerant(void)
12197 { return do_vms_case_tolerant(); }
12198 #else
12199 int Perl_vms_case_tolerant(void)
12200 { return vms_process_case_tolerant; }
12201 #endif
12202
12203
12204  /* Start of DECC RTL Feature handling */
12205
12206 static int sys_trnlnm
12207    (const char * logname,
12208     char * value,
12209     int value_len)
12210 {
12211     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
12212     const unsigned long attr = LNM$M_CASE_BLIND;
12213     struct dsc$descriptor_s name_dsc;
12214     int status;
12215     unsigned short result;
12216     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
12217                                 {0, 0, 0, 0}};
12218
12219     name_dsc.dsc$w_length = strlen(logname);
12220     name_dsc.dsc$a_pointer = (char *)logname;
12221     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12222     name_dsc.dsc$b_class = DSC$K_CLASS_S;
12223
12224     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
12225
12226     if ($VMS_STATUS_SUCCESS(status)) {
12227
12228          /* Null terminate and return the string */
12229         /*--------------------------------------*/
12230         value[result] = 0;
12231     }
12232
12233     return status;
12234 }
12235
12236 static int sys_crelnm
12237    (const char * logname,
12238     const char * value)
12239 {
12240     int ret_val;
12241     const char * proc_table = "LNM$PROCESS_TABLE";
12242     struct dsc$descriptor_s proc_table_dsc;
12243     struct dsc$descriptor_s logname_dsc;
12244     struct itmlst_3 item_list[2];
12245
12246     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
12247     proc_table_dsc.dsc$w_length = strlen(proc_table);
12248     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12249     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
12250
12251     logname_dsc.dsc$a_pointer = (char *) logname;
12252     logname_dsc.dsc$w_length = strlen(logname);
12253     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12254     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
12255
12256     item_list[0].buflen = strlen(value);
12257     item_list[0].itmcode = LNM$_STRING;
12258     item_list[0].bufadr = (char *)value;
12259     item_list[0].retlen = NULL;
12260
12261     item_list[1].buflen = 0;
12262     item_list[1].itmcode = 0;
12263
12264     ret_val = sys$crelnm
12265                        (NULL,
12266                         (const struct dsc$descriptor_s *)&proc_table_dsc,
12267                         (const struct dsc$descriptor_s *)&logname_dsc,
12268                         NULL,
12269                         (const struct item_list_3 *) item_list);
12270
12271     return ret_val;
12272 }
12273
12274 /* C RTL Feature settings */
12275
12276 static int set_features
12277    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
12278     int (* cli_routine)(void),  /* Not documented */
12279     void *image_info)           /* Not documented */
12280 {
12281     int status;
12282     int s;
12283     int dflt;
12284     char* str;
12285     char val_str[10];
12286 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12287     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12288     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12289     unsigned long case_perm;
12290     unsigned long case_image;
12291 #endif
12292
12293     /* Allow an exception to bring Perl into the VMS debugger */
12294     vms_debug_on_exception = 0;
12295     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12296     if ($VMS_STATUS_SUCCESS(status)) {
12297        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12298          vms_debug_on_exception = 1;
12299        else
12300          vms_debug_on_exception = 0;
12301     }
12302
12303     /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
12304     vms_vtf7_filenames = 0;
12305     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12306     if ($VMS_STATUS_SUCCESS(status)) {
12307        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12308          vms_vtf7_filenames = 1;
12309        else
12310          vms_vtf7_filenames = 0;
12311     }
12312
12313     /* Dectect running under GNV Bash or other UNIX like shell */
12314 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12315     gnv_unix_shell = 0;
12316     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12317     if ($VMS_STATUS_SUCCESS(status)) {
12318        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12319          gnv_unix_shell = 1;
12320          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12321          set_feature_default("DECC$EFS_CHARSET", 1);
12322          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12323          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12324          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12325          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12326        }
12327        else
12328          gnv_unix_shell = 0;
12329     }
12330 #endif
12331
12332     /* hacks to see if known bugs are still present for testing */
12333
12334     /* Readdir is returning filenames in VMS syntax always */
12335     decc_bug_readdir_efs1 = 1;
12336     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12337     if ($VMS_STATUS_SUCCESS(status)) {
12338        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12339          decc_bug_readdir_efs1 = 1;
12340        else
12341          decc_bug_readdir_efs1 = 0;
12342     }
12343
12344     /* PCP mode requires creating /dev/null special device file */
12345     decc_bug_devnull = 0;
12346     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12347     if ($VMS_STATUS_SUCCESS(status)) {
12348        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12349           decc_bug_devnull = 1;
12350        else
12351           decc_bug_devnull = 0;
12352     }
12353
12354     /* fgetname returning a VMS name in UNIX mode */
12355     decc_bug_fgetname = 1;
12356     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12357     if ($VMS_STATUS_SUCCESS(status)) {
12358       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12359         decc_bug_fgetname = 1;
12360       else
12361         decc_bug_fgetname = 0;
12362     }
12363
12364     /* UNIX directory names with no paths are broken in a lot of places */
12365     decc_dir_barename = 1;
12366     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12367     if ($VMS_STATUS_SUCCESS(status)) {
12368       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12369         decc_dir_barename = 1;
12370       else
12371         decc_dir_barename = 0;
12372     }
12373
12374 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12375     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12376     if (s >= 0) {
12377         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12378         if (decc_disable_to_vms_logname_translation < 0)
12379             decc_disable_to_vms_logname_translation = 0;
12380     }
12381
12382     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12383     if (s >= 0) {
12384         decc_efs_case_preserve = decc$feature_get_value(s, 1);
12385         if (decc_efs_case_preserve < 0)
12386             decc_efs_case_preserve = 0;
12387     }
12388
12389     s = decc$feature_get_index("DECC$EFS_CHARSET");
12390     if (s >= 0) {
12391         decc_efs_charset = decc$feature_get_value(s, 1);
12392         if (decc_efs_charset < 0)
12393             decc_efs_charset = 0;
12394     }
12395
12396     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12397     if (s >= 0) {
12398         decc_filename_unix_report = decc$feature_get_value(s, 1);
12399         if (decc_filename_unix_report > 0)
12400             decc_filename_unix_report = 1;
12401         else
12402             decc_filename_unix_report = 0;
12403     }
12404
12405     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12406     if (s >= 0) {
12407         decc_filename_unix_only = decc$feature_get_value(s, 1);
12408         if (decc_filename_unix_only > 0) {
12409             decc_filename_unix_only = 1;
12410         }
12411         else {
12412             decc_filename_unix_only = 0;
12413         }
12414     }
12415
12416     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12417     if (s >= 0) {
12418         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12419         if (decc_filename_unix_no_version < 0)
12420             decc_filename_unix_no_version = 0;
12421     }
12422
12423     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12424     if (s >= 0) {
12425         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12426         if (decc_readdir_dropdotnotype < 0)
12427             decc_readdir_dropdotnotype = 0;
12428     }
12429
12430     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12431     if ($VMS_STATUS_SUCCESS(status)) {
12432         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12433         if (s >= 0) {
12434             dflt = decc$feature_get_value(s, 4);
12435             if (dflt > 0) {
12436                 decc_disable_posix_root = decc$feature_get_value(s, 1);
12437                 if (decc_disable_posix_root <= 0) {
12438                     decc$feature_set_value(s, 1, 1);
12439                     decc_disable_posix_root = 1;
12440                 }
12441             }
12442             else {
12443                 /* Traditionally Perl assumes this is off */
12444                 decc_disable_posix_root = 1;
12445                 decc$feature_set_value(s, 1, 1);
12446             }
12447         }
12448     }
12449
12450 #if __CRTL_VER >= 80200000
12451     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12452     if (s >= 0) {
12453         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12454         if (decc_posix_compliant_pathnames < 0)
12455             decc_posix_compliant_pathnames = 0;
12456         if (decc_posix_compliant_pathnames > 4)
12457             decc_posix_compliant_pathnames = 0;
12458     }
12459
12460 #endif
12461 #else
12462     status = sys_trnlnm
12463         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12464     if ($VMS_STATUS_SUCCESS(status)) {
12465         val_str[0] = _toupper(val_str[0]);
12466         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12467            decc_disable_to_vms_logname_translation = 1;
12468         }
12469     }
12470
12471 #ifndef __VAX
12472     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12473     if ($VMS_STATUS_SUCCESS(status)) {
12474         val_str[0] = _toupper(val_str[0]);
12475         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12476            decc_efs_case_preserve = 1;
12477         }
12478     }
12479 #endif
12480
12481     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12482     if ($VMS_STATUS_SUCCESS(status)) {
12483         val_str[0] = _toupper(val_str[0]);
12484         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12485            decc_filename_unix_report = 1;
12486         }
12487     }
12488     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12489     if ($VMS_STATUS_SUCCESS(status)) {
12490         val_str[0] = _toupper(val_str[0]);
12491         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12492            decc_filename_unix_only = 1;
12493            decc_filename_unix_report = 1;
12494         }
12495     }
12496     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12497     if ($VMS_STATUS_SUCCESS(status)) {
12498         val_str[0] = _toupper(val_str[0]);
12499         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12500            decc_filename_unix_no_version = 1;
12501         }
12502     }
12503     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12504     if ($VMS_STATUS_SUCCESS(status)) {
12505         val_str[0] = _toupper(val_str[0]);
12506         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12507            decc_readdir_dropdotnotype = 1;
12508         }
12509     }
12510 #endif
12511
12512 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12513
12514      /* Report true case tolerance */
12515     /*----------------------------*/
12516     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12517     if (!$VMS_STATUS_SUCCESS(status))
12518         case_perm = PPROP$K_CASE_BLIND;
12519     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12520     if (!$VMS_STATUS_SUCCESS(status))
12521         case_image = PPROP$K_CASE_BLIND;
12522     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12523         (case_image == PPROP$K_CASE_SENSITIVE))
12524         vms_process_case_tolerant = 0;
12525
12526 #endif
12527
12528
12529     /* CRTL can be initialized past this point, but not before. */
12530 /*    DECC$CRTL_INIT(); */
12531
12532     return SS$_NORMAL;
12533 }
12534
12535 #ifdef __DECC
12536 /* DECC dependent attributes */
12537 #if __DECC_VER < 60560002
12538 #define relative
12539 #define not_executable
12540 #else
12541 #define relative ,rel
12542 #define not_executable ,noexe
12543 #endif
12544 #pragma nostandard
12545 #pragma extern_model save
12546 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12547 #endif
12548         const __align (LONGWORD) int spare[8] = {0};
12549 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
12550 /*                        NOWRT, LONG */
12551 #ifdef __DECC
12552 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
12553         nowrt,noshr relative not_executable
12554 #endif
12555 const long vms_cc_features = (const long)set_features;
12556
12557 /*
12558 ** Force a reference to LIB$INITIALIZE to ensure it
12559 ** exists in the image.
12560 */
12561 int lib$initialize(void);
12562 #ifdef __DECC
12563 #pragma extern_model strict_refdef
12564 #endif
12565     int lib_init_ref = (int) lib$initialize;
12566
12567 #ifdef __DECC
12568 #pragma extern_model restore
12569 #pragma standard
12570 #endif
12571
12572 /*  End of vms.c */