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 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  95
  96 static int set_feature_default(const char *name, int value)
  97 {
  98     int status;
  99     int index;
 100
 101     index = decc$feature_get_index(name);
 102
 103     status = decc$feature_set_value(index, 1, value);
 104     if (index == -1 || (status == -1)) {
 105       return -1;
 106     }
 107
 108     status = decc$feature_get_value(index, 1);
 109     if (status != value) {
 110       return -1;
 111     }
 112
 113 return 0;
 114 }
 115 #endif
 116
 117 /* Older versions of ssdef.h don't have these */
 118 #ifndef SS$_INVFILFOROP
 119 #  define SS$_INVFILFOROP 3930
 120 #endif
 121 #ifndef SS$_NOSUCHOBJECT
 122 #  define SS$_NOSUCHOBJECT 2696
 123 #endif
 124
 125 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 126 #define PERLIO_NOT_STDIO 0
 127
 128 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 129  * code below needs to get to the underlying CRTL routines. */
 130 #define DONT_MASK_RTL_CALLS
 131 #include "EXTERN.h"
 132 #include "perl.h"
 133 #include "XSUB.h"
 134 /* Anticipating future expansion in lexical warnings . . . */
 135 #ifndef WARN_INTERNAL
 136 #  define WARN_INTERNAL WARN_MISC
 137 #endif
 138
 139 #ifdef VMS_LONGNAME_SUPPORT
 140 #include <libfildef.h>
 141 #endif
 142
 143 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 144 #  define RTL_USES_UTC 1
 145 #endif
 146
 147 #ifdef USE_VMS_DECTERM
 148
 149 /* Routine to create a decterm for use with the Perl debugger */
 150 /* No headers, this information was found in the Programming Concepts Manual */
 151
 152 int decw$term_port
 153    (const struct dsc$descriptor_s * display,
 154     const struct dsc$descriptor_s * setup_file,
 155     const struct dsc$descriptor_s * customization,
 156     struct dsc$descriptor_s * result_device_name,
 157     unsigned short * result_device_name_length,
 158     void * controller,
 159     void * char_buffer,
 160     void * char_change_buffer);
 161 #endif
 162
 163 /* gcc's header files don't #define direct access macros
 164  * corresponding to VAXC's variant structs */
 165 #ifdef __GNUC__
 166 #  define uic$v_format uic$r_uic_form.uic$v_format
 167 #  define uic$v_group uic$r_uic_form.uic$v_group
 168 #  define uic$v_member uic$r_uic_form.uic$v_member
 169 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 170 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 171 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 172 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 173 #endif
 174
 175 #if defined(NEED_AN_H_ERRNO)
 176 dEXT int h_errno;
 177 #endif
 178
 179 #ifdef __DECC
 180 #pragma message disable pragma
 181 #pragma member_alignment save
 182 #pragma nomember_alignment longword
 183 #pragma message save
 184 #pragma message disable misalgndmem
 185 #endif
 186 struct itmlst_3 {
 187   unsigned short int buflen;
 188   unsigned short int itmcode;
 189   void *bufadr;
 190   unsigned short int *retlen;
 191 };
 192
 193 struct filescan_itmlst_2 {
 194     unsigned short length;
 195     unsigned short itmcode;
 196     char * component;
 197 };
 198
 199 struct vs_str_st {
 200     unsigned short length;
 201     char str[65536];
 202 };
 203
 204 #ifdef __DECC
 205 #pragma message restore
 206 #pragma member_alignment restore
 207 #endif
 208
 209 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 210 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 211 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 212 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 213 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 214 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 215 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 216 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 217 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 218 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 219 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 220
 221 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 222 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 223 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 224 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 225
 226 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 227 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 228
 229 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 230  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 231  * the Perl facility.
 232  */
 233 #define PERL_LNM_MAX_ITER 10
 234
 235   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 236 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 237 #define MAX_DCL_SYMBOL          (8192)
 238 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 239 #else
 240 #define MAX_DCL_SYMBOL          (1024)
 241 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 242 #endif
 243
 244 static char *__mystrtolower(char *str)
 245 {
 246   if (str) for (; *str; ++str) *str= tolower(*str);
 247   return str;
 248 }
 249
 250 static struct dsc$descriptor_s fildevdsc =
 251   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 252 static struct dsc$descriptor_s crtlenvdsc =
 253   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 254 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 255 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 256 static struct dsc$descriptor_s **env_tables = defenv;
 257 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 258
 259 /* True if we shouldn't treat barewords as logicals during directory */
 260 /* munching */
 261 static int no_translate_barewords;
 262
 263 #ifndef RTL_USES_UTC
 264 static int tz_updated = 1;
 265 #endif
 266
 267 /* DECC Features that may need to affect how Perl interprets
 268  * displays filename information
 269  */
 270 static int decc_disable_to_vms_logname_translation = 1;
 271 static int decc_disable_posix_root = 1;
 272 int decc_efs_case_preserve = 0;
 273 static int decc_efs_charset = 0;
 274 static int decc_filename_unix_no_version = 0;
 275 static int decc_filename_unix_only = 0;
 276 int decc_filename_unix_report = 0;
 277 int decc_posix_compliant_pathnames = 0;
 278 int decc_readdir_dropdotnotype = 0;
 279 static int vms_process_case_tolerant = 1;
 280 int vms_vtf7_filenames = 0;
 281 int gnv_unix_shell = 0;
 282
 283 /* bug workarounds if needed */
 284 int decc_bug_readdir_efs1 = 0;
 285 int decc_bug_devnull = 1;
 286 int decc_bug_fgetname = 0;
 287 int decc_dir_barename = 0;
 288
 289 static int vms_debug_on_exception = 0;
 290
 291 /* Is this a UNIX file specification?
 292  *   No longer a simple check with EFS file specs
 293  *   For now, not a full check, but need to
 294  *   handle POSIX ^UP^ specifications
 295  *   Fixing to handle ^/ cases would require
 296  *   changes to many other conversion routines.
 297  */
 298
 299 static int is_unix_filespec(const char *path)
 300 {
 301 int ret_val;
 302 const char * pch1;
 303
 304     ret_val = 0;
 305     if (strncmp(path,"\"^UP^",5) != 0) {
 306         pch1 = strchr(path, '/');
 307         if (pch1 != NULL)
 308             ret_val = 1;
 309         else {
 310
 311             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 312             if (decc_filename_unix_report || decc_filename_unix_only) {
 313             if (strcmp(path,".") == 0)
 314                 ret_val = 1;
 315             }
 316         }
 317     }
 318     return ret_val;
 319 }
 320
 321 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 322  */
 323
 324 static void ucs2_to_vtf7
 325    (char *outspec,
 326     unsigned long ucs2_char,
 327     int * output_cnt)
 328 {
 329 unsigned char * ucs_ptr;
 330 int hex;
 331
 332     ucs_ptr = (unsigned char *)&ucs2_char;
 333
 334     outspec[0] = '^';
 335     outspec[1] = 'U';
 336     hex = (ucs_ptr[1] >> 4) & 0xf;
 337     if (hex < 0xA)
 338         outspec[2] = hex + '0';
 339     else
 340         outspec[2] = (hex - 9) + 'A';
 341     hex = ucs_ptr[1] & 0xF;
 342     if (hex < 0xA)
 343         outspec[3] = hex + '0';
 344     else {
 345         outspec[3] = (hex - 9) + 'A';
 346     }
 347     hex = (ucs_ptr[0] >> 4) & 0xf;
 348     if (hex < 0xA)
 349         outspec[4] = hex + '0';
 350     else
 351         outspec[4] = (hex - 9) + 'A';
 352     hex = ucs_ptr[1] & 0xF;
 353     if (hex < 0xA)
 354         outspec[5] = hex + '0';
 355     else {
 356         outspec[5] = (hex - 9) + 'A';
 357     }
 358     *output_cnt = 6;
 359 }
 360
 361
 362 /* This handles the conversion of a UNIX extended character set to a ^
 363  * escaped VMS character.
 364  * in a UNIX file specification.
 365  *
 366  * The output count variable contains the number of characters added
 367  * to the output string.
 368  *
 369  * The return value is the number of characters read from the input string
 370  */
 371 static int copy_expand_unix_filename_escape
 372   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 373 {
 374 int count;
 375 int scnt;
 376 int utf8_flag;
 377
 378     utf8_flag = 0;
 379     if (utf8_fl)
 380       utf8_flag = *utf8_fl;
 381
 382     count = 0;
 383     *output_cnt = 0;
 384     if (*inspec >= 0x80) {
 385         if (utf8_fl && vms_vtf7_filenames) {
 386         unsigned long ucs_char;
 387
 388             ucs_char = 0;
 389
 390             if ((*inspec & 0xE0) == 0xC0) {
 391                 /* 2 byte Unicode */
 392                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 393                 if (ucs_char >= 0x80) {
 394                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 395                     return 2;
 396                 }
 397             } else if ((*inspec & 0xF0) == 0xE0) {
 398                 /* 3 byte Unicode */
 399                 ucs_char = ((inspec[0] & 0xF) << 12) +
 400                    ((inspec[1] & 0x3f) << 6) +
 401                    (inspec[2] & 0x3f);
 402                 if (ucs_char >= 0x800) {
 403                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 404                     return 3;
 405                 }
 406
 407 #if 0 /* I do not see longer sequences supported by OpenVMS */
 408       /* Maybe some one can fix this later */
 409             } else if ((*inspec & 0xF8) == 0xF0) {
 410                 /* 4 byte Unicode */
 411                 /* UCS-4 to UCS-2 */
 412             } else if ((*inspec & 0xFC) == 0xF8) {
 413                 /* 5 byte Unicode */
 414                 /* UCS-4 to UCS-2 */
 415             } else if ((*inspec & 0xFE) == 0xFC) {
 416                 /* 6 byte Unicode */
 417                 /* UCS-4 to UCS-2 */
 418 #endif
 419             }
 420         }
 421
 422         /* High bit set, but not a unicode character! */
 423
 424         /* Non printing DECMCS or ISO Latin-1 character? */
 425         if (*inspec <= 0x9F) {
 426         int hex;
 427             outspec[0] = '^';
 428             outspec++;
 429             hex = (*inspec >> 4) & 0xF;
 430             if (hex < 0xA)
 431                 outspec[1] = hex + '0';
 432             else {
 433                 outspec[1] = (hex - 9) + 'A';
 434             }
 435             hex = *inspec & 0xF;
 436             if (hex < 0xA)
 437                 outspec[2] = hex + '0';
 438             else {
 439                 outspec[2] = (hex - 9) + 'A';
 440             }
 441             *output_cnt = 3;
 442             return 1;
 443         } else if (*inspec == 0xA0) {
 444             outspec[0] = '^';
 445             outspec[1] = 'A';
 446             outspec[2] = '0';
 447             *output_cnt = 3;
 448             return 1;
 449         } else if (*inspec == 0xFF) {
 450             outspec[0] = '^';
 451             outspec[1] = 'F';
 452             outspec[2] = 'F';
 453             *output_cnt = 3;
 454             return 1;
 455         }
 456         *outspec = *inspec;
 457         *output_cnt = 1;
 458         return 1;
 459     }
 460
 461     /* Is this a macro that needs to be passed through?
 462      * Macros start with $( and an alpha character, followed
 463      * by a string of alpha numeric characters ending with a )
 464      * If this does not match, then encode it as ODS-5.
 465      */
 466     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 467     int tcnt;
 468
 469         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 470             tcnt = 3;
 471             outspec[0] = inspec[0];
 472             outspec[1] = inspec[1];
 473             outspec[2] = inspec[2];
 474
 475             while(isalnum(inspec[tcnt]) ||
 476                   (inspec[2] == '.') || (inspec[2] == '_')) {
 477                 outspec[tcnt] = inspec[tcnt];
 478                 tcnt++;
 479             }
 480             if (inspec[tcnt] == ')') {
 481                 outspec[tcnt] = inspec[tcnt];
 482                 tcnt++;
 483                 *output_cnt = tcnt;
 484                 return tcnt;
 485             }
 486         }
 487     }
 488
 489     switch (*inspec) {
 490     case 0x7f:
 491         outspec[0] = '^';
 492         outspec[1] = '7';
 493         outspec[2] = 'F';
 494         *output_cnt = 3;
 495         return 1;
 496         break;
 497     case '?':
 498         if (decc_efs_charset == 0)
 499           outspec[0] = '%';
 500         else
 501           outspec[0] = '?';
 502         *output_cnt = 1;
 503         return 1;
 504         break;
 505     case '.':
 506     case '~':
 507     case '!':
 508     case '#':
 509     case '&':
 510     case '\'':
 511     case '`':
 512     case '(':
 513     case ')':
 514     case '+':
 515     case '@':
 516     case '{':
 517     case '}':
 518     case ',':
 519     case ';':
 520     case '[':
 521     case ']':
 522     case '%':
 523     case '^':
 524     case '=':
 525         /* Assume that this is to be escaped */
 526         outspec[0] = '^';
 527         outspec[1] = *inspec;
 528         *output_cnt = 2;
 529         return 1;
 530         break;
 531     case ' ': /* space */
 532         /* Assume that this is to be escaped */
 533         outspec[0] = '^';
 534         outspec[1] = '_';
 535         *output_cnt = 2;
 536         return 1;
 537         break;
 538     default:
 539         *outspec = *inspec;
 540         *output_cnt = 1;
 541         return 1;
 542         break;
 543     }
 544 }
 545
 546
 547 /* This handles the expansion of a '^' prefix to the proper character
 548  * in a UNIX file specification.
 549  *
 550  * The output count variable contains the number of characters added
 551  * to the output string.
 552  *
 553  * The return value is the number of characters read from the input
 554  * string
 555  */
 556 static int copy_expand_vms_filename_escape
 557   (char *outspec, const char *inspec, int *output_cnt)
 558 {
 559 int count;
 560 int scnt;
 561
 562     count = 0;
 563     *output_cnt = 0;
 564     if (*inspec == '^') {
 565         inspec++;
 566         switch (*inspec) {
 567         case '.':
 568             /* Non trailing dots should just be passed through */
 569             *outspec = *inspec;
 570             count++;
 571             (*output_cnt)++;
 572             break;
 573         case '_': /* space */
 574             *outspec = ' ';
 575             inspec++;
 576             count++;
 577             (*output_cnt)++;
 578             break;
 579         case 'U': /* Unicode - FIX-ME this is wrong. */
 580             inspec++;
 581             count++;
 582             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 583             if (scnt == 4) {
 584                 unsigned int c1, c2;
 585                 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
 586                 outspec[0] == c1 & 0xff;
 587                 outspec[1] == c2 & 0xff;
 588                 if (scnt > 1) {
 589                     (*output_cnt) += 2;
 590                     count += 4;
 591                 }
 592             }
 593             else {
 594                 /* Error - do best we can to continue */
 595                 *outspec = 'U';
 596                 outspec++;
 597                 (*output_cnt++);
 598                 *outspec = *inspec;
 599                 count++;
 600                 (*output_cnt++);
 601             }
 602             break;
 603         default:
 604             scnt = strspn(inspec, "0123456789ABCDEFabcdef");
 605             if (scnt == 2) {
 606                 /* Hex encoded */
 607                 unsigned int c1;
 608                 scnt = sscanf(inspec, "%2x", &c1);
 609                 outspec[0] = c1 & 0xff;
 610                 if (scnt > 0) {
 611                     (*output_cnt++);
 612                     count += 2;
 613                 }
 614             }
 615             else {
 616                 *outspec = *inspec;
 617                 count++;
 618                 (*output_cnt++);
 619             }
 620         }
 621     }
 622     else {
 623         *outspec = *inspec;
 624         count++;
 625         (*output_cnt)++;
 626     }
 627     return count;
 628 }
 629
 630
 631 int SYS$FILESCAN
 632    (const struct dsc$descriptor_s * srcstr,
 633     struct filescan_itmlst_2 * valuelist,
 634     unsigned long * fldflags,
 635     struct dsc$descriptor_s *auxout,
 636     unsigned short * retlen);
 637
 638 /* vms_split_path - Verify that the input file specification is a
 639  * VMS format file specification, and provide pointers to the components of
 640  * it.  With EFS format filenames, this is virtually the only way to
 641  * parse a VMS path specification into components.
 642  *
 643  * If the sum of the components do not add up to the length of the
 644  * string, then the passed file specification is probably a UNIX style
 645  * path.
 646  */
 647 static int vms_split_path
 648    (const char * path,
 649     char * * volume,
 650     int * vol_len,
 651     char * * root,
 652     int * root_len,
 653     char * * dir,
 654     int * dir_len,
 655     char * * name,
 656     int * name_len,
 657     char * * ext,
 658     int * ext_len,
 659     char * * version,
 660     int * ver_len)
 661 {
 662 struct dsc$descriptor path_desc;
 663 int status;
 664 unsigned long flags;
 665 int ret_stat;
 666 struct filescan_itmlst_2 item_list[9];
 667 const int filespec = 0;
 668 const int nodespec = 1;
 669 const int devspec = 2;
 670 const int rootspec = 3;
 671 const int dirspec = 4;
 672 const int namespec = 5;
 673 const int typespec = 6;
 674 const int verspec = 7;
 675
 676     /* Assume the worst for an easy exit */
 677     ret_stat = -1;
 678     *volume = NULL;
 679     *vol_len = 0;
 680     *root = NULL;
 681     *root_len = 0;
 682     *dir = NULL;
 683     *dir_len;
 684     *name = NULL;
 685     *name_len = 0;
 686     *ext = NULL;
 687     *ext_len = 0;
 688     *version = NULL;
 689     *ver_len = 0;
 690
 691     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 692     path_desc.dsc$w_length = strlen(path);
 693     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 694     path_desc.dsc$b_class = DSC$K_CLASS_S;
 695
 696     /* Get the total length, if it is shorter than the string passed
 697      * then this was probably not a VMS formatted file specification
 698      */
 699     item_list[filespec].itmcode = FSCN$_FILESPEC;
 700     item_list[filespec].length = 0;
 701     item_list[filespec].component = NULL;
 702
 703     /* If the node is present, then it gets considered as part of the
 704      * volume name to hopefully make things simple.
 705      */
 706     item_list[nodespec].itmcode = FSCN$_NODE;
 707     item_list[nodespec].length = 0;
 708     item_list[nodespec].component = NULL;
 709
 710     item_list[devspec].itmcode = FSCN$_DEVICE;
 711     item_list[devspec].length = 0;
 712     item_list[devspec].component = NULL;
 713
 714     /* root is a special case,  adding it to either the directory or
 715      * the device components will probalby complicate things for the
 716      * callers of this routine, so leave it separate.
 717      */
 718     item_list[rootspec].itmcode = FSCN$_ROOT;
 719     item_list[rootspec].length = 0;
 720     item_list[rootspec].component = NULL;
 721
 722     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 723     item_list[dirspec].length = 0;
 724     item_list[dirspec].component = NULL;
 725
 726     item_list[namespec].itmcode = FSCN$_NAME;
 727     item_list[namespec].length = 0;
 728     item_list[namespec].component = NULL;
 729
 730     item_list[typespec].itmcode = FSCN$_TYPE;
 731     item_list[typespec].length = 0;
 732     item_list[typespec].component = NULL;
 733
 734     item_list[verspec].itmcode = FSCN$_VERSION;
 735     item_list[verspec].length = 0;
 736     item_list[verspec].component = NULL;
 737
 738     item_list[8].itmcode = 0;
 739     item_list[8].length = 0;
 740     item_list[8].component = NULL;
 741
 742     status = SYS$FILESCAN
 743        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 744         &flags, NULL, NULL);
 745     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 746
 747     /* If we parsed it successfully these two lengths should be the same */
 748     if (path_desc.dsc$w_length != item_list[filespec].length)
 749         return ret_stat;
 750
 751     /* If we got here, then it is a VMS file specification */
 752     ret_stat = 0;
 753
 754     /* set the volume name */
 755     if (item_list[nodespec].length > 0) {
 756         *volume = item_list[nodespec].component;
 757         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 758     }
 759     else {
 760         *volume = item_list[devspec].component;
 761         *vol_len = item_list[devspec].length;
 762     }
 763
 764     *root = item_list[rootspec].component;
 765     *root_len = item_list[rootspec].length;
 766
 767     *dir = item_list[dirspec].component;
 768     *dir_len = item_list[dirspec].length;
 769
 770     /* Now fun with versions and EFS file specifications
 771      * The parser can not tell the difference when a "." is a version
 772      * delimiter or a part of the file specification.
 773      */
 774     if ((decc_efs_charset) &&
 775         (item_list[verspec].length > 0) &&
 776         (item_list[verspec].component[0] == '.')) {
 777         *name = item_list[namespec].component;
 778         *name_len = item_list[namespec].length + item_list[typespec].length;
 779         *ext = item_list[verspec].component;
 780         *ext_len = item_list[verspec].length;
 781         *version = NULL;
 782         *ver_len = 0;
 783     }
 784     else {
 785         *name = item_list[namespec].component;
 786         *name_len = item_list[namespec].length;
 787         *ext = item_list[typespec].component;
 788         *ext_len = item_list[typespec].length;
 789         *version = item_list[verspec].component;
 790         *ver_len = item_list[verspec].length;
 791     }
 792     return ret_stat;
 793 }
 794
 795
 796 /* my_maxidx
 797  * Routine to retrieve the maximum equivalence index for an input
 798  * logical name.  Some calls to this routine have no knowledge if
 799  * the variable is a logical or not.  So on error we return a max
 800  * index of zero.
 801  */
 802 /*{{{int my_maxidx(const char *lnm) */
 803 static int
 804 my_maxidx(const char *lnm)
 805 {
 806     int status;
 807     int midx;
 808     int attr = LNM$M_CASE_BLIND;
 809     struct dsc$descriptor lnmdsc;
 810     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 811                                 {0, 0, 0, 0}};
 812
 813     lnmdsc.dsc$w_length = strlen(lnm);
 814     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 815     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 816     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 817
 818     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 819     if ((status & 1) == 0)
 820        midx = 0;
 821
 822     return (midx);
 823 }
 824 /*}}}*/
 825
 826 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 827 int
 828 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 829   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 830 {
 831     const char *cp1;
 832     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 833     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 834     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 835     int midx;
 836     unsigned char acmode;
 837     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 838                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 839     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 840                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 841                                  {0, 0, 0, 0}};
 842     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 843 #if defined(PERL_IMPLICIT_CONTEXT)
 844     pTHX = NULL;
 845     if (PL_curinterp) {
 846       aTHX = PERL_GET_INTERP;
 847     } else {
 848       aTHX = NULL;
 849     }
 850 #endif
 851
 852     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 853       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 854     }
 855     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 856       *cp2 = _toupper(*cp1);
 857       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 858         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 859         return 0;
 860       }
 861     }
 862     lnmdsc.dsc$w_length = cp1 - lnm;
 863     lnmdsc.dsc$a_pointer = uplnm;
 864     uplnm[lnmdsc.dsc$w_length] = '\0';
 865     secure = flags & PERL__TRNENV_SECURE;
 866     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 867     if (!tabvec || !*tabvec) tabvec = env_tables;
 868
 869     for (curtab = 0; tabvec[curtab]; curtab++) {
 870       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 871         if (!ivenv && !secure) {
 872           char *eq, *end;
 873           int i;
 874           if (!environ) {
 875             ivenv = 1;
 876             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 877             continue;
 878           }
 879           retsts = SS$_NOLOGNAM;
 880           for (i = 0; environ[i]; i++) {
 881             if ((eq = strchr(environ[i],'=')) &&
 882                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 883                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 884               eq++;
 885               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 886               if (!eqvlen) continue;
 887               retsts = SS$_NORMAL;
 888               break;
 889             }
 890           }
 891           if (retsts != SS$_NOLOGNAM) break;
 892         }
 893       }
 894       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 895                !str$case_blind_compare(&tmpdsc,&clisym)) {
 896         if (!ivsym && !secure) {
 897           unsigned short int deflen = LNM$C_NAMLENGTH;
 898           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 899           /* dynamic dsc to accomodate possible long value */
 900           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 901           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 902           if (retsts & 1) {
 903             if (eqvlen > MAX_DCL_SYMBOL) {
 904               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 905               eqvlen = MAX_DCL_SYMBOL;
 906               /* Special hack--we might be called before the interpreter's */
 907               /* fully initialized, in which case either thr or PL_curcop */
 908               /* might be bogus. We have to check, since ckWARN needs them */
 909               /* both to be valid if running threaded */
 910                 if (ckWARN(WARN_MISC)) {
 911                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 912                 }
 913             }
 914             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 915           }
 916           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 917           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 918           if (retsts == LIB$_NOSUCHSYM) continue;
 919           break;
 920         }
 921       }
 922       else if (!ivlnm) {
 923         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 924           midx = my_maxidx(lnm);
 925           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 926             lnmlst[1].bufadr = cp2;
 927             eqvlen = 0;
 928             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 929             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 930             if (retsts == SS$_NOLOGNAM) break;
 931             /* PPFs have a prefix */
 932             if (
 933 #if INTSIZE == 4
 934                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 935 #endif
 936                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 937                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 938                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 939                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 940                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 941               memmove(eqv,eqv+4,eqvlen-4);
 942               eqvlen -= 4;
 943             }
 944             cp2 += eqvlen;
 945             *cp2 = '\0';
 946           }
 947           if ((retsts == SS$_IVLOGNAM) ||
 948               (retsts == SS$_NOLOGNAM)) { continue; }
 949         }
 950         else {
 951           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 952           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 953           if (retsts == SS$_NOLOGNAM) continue;
 954           eqv[eqvlen] = '\0';
 955         }
 956         eqvlen = strlen(eqv);
 957         break;
 958       }
 959     }
 960     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 961     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 962              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 963              retsts == SS$_NOLOGNAM) {
 964       set_errno(EINVAL);  set_vaxc_errno(retsts);
 965     }
 966     else _ckvmssts(retsts);
 967     return 0;
 968 }  /* end of vmstrnenv */
 969 /*}}}*/
 970
 971 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 972 /* Define as a function so we can access statics. */
 973 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 974 {
 975   return vmstrnenv(lnm,eqv,idx,fildev,
 976 #ifdef SECURE_INTERNAL_GETENV
 977                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 978 #else
 979                    0
 980 #endif
 981                                                                               );
 982 }
 983 /*}}}*/
 984
 985 /* my_getenv
 986  * Note: Uses Perl temp to store result so char * can be returned to
 987  * caller; this pointer will be invalidated at next Perl statement
 988  * transition.
 989  * We define this as a function rather than a macro in terms of my_getenv_len()
 990  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 991  * allocate SVs).
 992  */
 993 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 994 char *
 995 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 996 {
 997     const char *cp1;
 998     static char *__my_getenv_eqv = NULL;
 999     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1000     unsigned long int idx = 0;
1001     int trnsuccess, success, secure, saverr, savvmserr;
1002     int midx, flags;
1003     SV *tmpsv;
1004
1005     midx = my_maxidx(lnm) + 1;
1006
1007     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1008       /* Set up a temporary buffer for the return value; Perl will
1009        * clean it up at the next statement transition */
1010       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1011       if (!tmpsv) return NULL;
1012       eqv = SvPVX(tmpsv);
1013     }
1014     else {
1015       /* Assume no interpreter ==> single thread */
1016       if (__my_getenv_eqv != NULL) {
1017         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1018       }
1019       else {
1020         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1021       }
1022       eqv = __my_getenv_eqv;
1023     }
1024
1025     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1026     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1027       int len;
1028       getcwd(eqv,LNM$C_NAMLENGTH);
1029
1030       len = strlen(eqv);
1031
1032       /* Get rid of "000000/ in rooted filespecs */
1033       if (len > 7) {
1034         char * zeros;
1035         zeros = strstr(eqv, "/000000/");
1036         if (zeros != NULL) {
1037           int mlen;
1038           mlen = len - (zeros - eqv) - 7;
1039           memmove(zeros, &zeros[7], mlen);
1040           len = len - 7;
1041           eqv[len] = '\0';
1042         }
1043       }
1044       return eqv;
1045     }
1046     else {
1047       /* Impose security constraints only if tainting */
1048       if (sys) {
1049         /* Impose security constraints only if tainting */
1050         secure = PL_curinterp ? PL_tainting : will_taint;
1051         saverr = errno;  savvmserr = vaxc$errno;
1052       }
1053       else {
1054         secure = 0;
1055       }
1056
1057       flags =
1058 #ifdef SECURE_INTERNAL_GETENV
1059               secure ? PERL__TRNENV_SECURE : 0
1060 #else
1061               0
1062 #endif
1063       ;
1064
1065       /* For the getenv interface we combine all the equivalence names
1066        * of a search list logical into one value to acquire a maximum
1067        * value length of 255*128 (assuming %ENV is using logicals).
1068        */
1069       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1070
1071       /* If the name contains a semicolon-delimited index, parse it
1072        * off and make sure we only retrieve the equivalence name for
1073        * that index.  */
1074       if ((cp2 = strchr(lnm,';')) != NULL) {
1075         strcpy(uplnm,lnm);
1076         uplnm[cp2-lnm] = '\0';
1077         idx = strtoul(cp2+1,NULL,0);
1078         lnm = uplnm;
1079         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1080       }
1081
1082       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1083
1084       /* Discard NOLOGNAM on internal calls since we're often looking
1085        * for an optional name, and this "error" often shows up as the
1086        * (bogus) exit status for a die() call later on.  */
1087       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1088       return success ? eqv : Nullch;
1089     }
1090
1091 }  /* end of my_getenv() */
1092 /*}}}*/
1093
1094
1095 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1096 char *
1097 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1098 {
1099     const char *cp1;
1100     char *buf, *cp2;
1101     unsigned long idx = 0;
1102     int midx, flags;
1103     static char *__my_getenv_len_eqv = NULL;
1104     int secure, saverr, savvmserr;
1105     SV *tmpsv;
1106
1107     midx = my_maxidx(lnm) + 1;
1108
1109     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1110       /* Set up a temporary buffer for the return value; Perl will
1111        * clean it up at the next statement transition */
1112       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1113       if (!tmpsv) return NULL;
1114       buf = SvPVX(tmpsv);
1115     }
1116     else {
1117       /* Assume no interpreter ==> single thread */
1118       if (__my_getenv_len_eqv != NULL) {
1119         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1120       }
1121       else {
1122         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1123       }
1124       buf = __my_getenv_len_eqv;
1125     }
1126
1127     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1128     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1129     char * zeros;
1130
1131       getcwd(buf,LNM$C_NAMLENGTH);
1132       *len = strlen(buf);
1133
1134       /* Get rid of "000000/ in rooted filespecs */
1135       if (*len > 7) {
1136       zeros = strstr(buf, "/000000/");
1137       if (zeros != NULL) {
1138         int mlen;
1139         mlen = *len - (zeros - buf) - 7;
1140         memmove(zeros, &zeros[7], mlen);
1141         *len = *len - 7;
1142         buf[*len] = '\0';
1143         }
1144       }
1145       return buf;
1146     }
1147     else {
1148       if (sys) {
1149         /* Impose security constraints only if tainting */
1150         secure = PL_curinterp ? PL_tainting : will_taint;
1151         saverr = errno;  savvmserr = vaxc$errno;
1152       }
1153       else {
1154         secure = 0;
1155       }
1156
1157       flags =
1158 #ifdef SECURE_INTERNAL_GETENV
1159               secure ? PERL__TRNENV_SECURE : 0
1160 #else
1161               0
1162 #endif
1163       ;
1164
1165       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1166
1167       if ((cp2 = strchr(lnm,';')) != NULL) {
1168         strcpy(buf,lnm);
1169         buf[cp2-lnm] = '\0';
1170         idx = strtoul(cp2+1,NULL,0);
1171         lnm = buf;
1172         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1173       }
1174
1175       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1176
1177       /* Get rid of "000000/ in rooted filespecs */
1178       if (*len > 7) {
1179       char * zeros;
1180         zeros = strstr(buf, "/000000/");
1181         if (zeros != NULL) {
1182           int mlen;
1183           mlen = *len - (zeros - buf) - 7;
1184           memmove(zeros, &zeros[7], mlen);
1185           *len = *len - 7;
1186           buf[*len] = '\0';
1187         }
1188       }
1189
1190       /* Discard NOLOGNAM on internal calls since we're often looking
1191        * for an optional name, and this "error" often shows up as the
1192        * (bogus) exit status for a die() call later on.  */
1193       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1194       return *len ? buf : Nullch;
1195     }
1196
1197 }  /* end of my_getenv_len() */
1198 /*}}}*/
1199
1200 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1201
1202 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1203
1204 /*{{{ void prime_env_iter() */
1205 void
1206 prime_env_iter(void)
1207 /* Fill the %ENV associative array with all logical names we can
1208  * find, in preparation for iterating over it.
1209  */
1210 {
1211   static int primed = 0;
1212   HV *seenhv = NULL, *envhv;
1213   SV *sv = NULL;
1214   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1215   unsigned short int chan;
1216 #ifndef CLI$M_TRUSTED
1217 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1218 #endif
1219   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1220   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1221   long int i;
1222   bool have_sym = FALSE, have_lnm = FALSE;
1223   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1224   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1225   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1226   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1227   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1228 #if defined(PERL_IMPLICIT_CONTEXT)
1229   pTHX;
1230 #endif
1231 #if defined(USE_ITHREADS)
1232   static perl_mutex primenv_mutex;
1233   MUTEX_INIT(&primenv_mutex);
1234 #endif
1235
1236 #if defined(PERL_IMPLICIT_CONTEXT)
1237     /* We jump through these hoops because we can be called at */
1238     /* platform-specific initialization time, which is before anything is */
1239     /* set up--we can't even do a plain dTHX since that relies on the */
1240     /* interpreter structure to be initialized */
1241     if (PL_curinterp) {
1242       aTHX = PERL_GET_INTERP;
1243     } else {
1244       aTHX = NULL;
1245     }
1246 #endif
1247
1248   if (primed || !PL_envgv) return;
1249   MUTEX_LOCK(&primenv_mutex);
1250   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1251   envhv = GvHVn(PL_envgv);
1252   /* Perform a dummy fetch as an lval to insure that the hash table is
1253    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1254   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1255
1256   for (i = 0; env_tables[i]; i++) {
1257      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1258          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1259      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1260   }
1261   if (have_sym || have_lnm) {
1262     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1263     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1264     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1265     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1266   }
1267
1268   for (i--; i >= 0; i--) {
1269     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1270       char *start;
1271       int j;
1272       for (j = 0; environ[j]; j++) {
1273         if (!(start = strchr(environ[j],'='))) {
1274           if (ckWARN(WARN_INTERNAL))
1275             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1276         }
1277         else {
1278           start++;
1279           sv = newSVpv(start,0);
1280           SvTAINTED_on(sv);
1281           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1282         }
1283       }
1284       continue;
1285     }
1286     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1287              !str$case_blind_compare(&tmpdsc,&clisym)) {
1288       strcpy(cmd,"Show Symbol/Global *");
1289       cmddsc.dsc$w_length = 20;
1290       if (env_tables[i]->dsc$w_length == 12 &&
1291           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1292           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1293       flags = defflags | CLI$M_NOLOGNAM;
1294     }
1295     else {
1296       strcpy(cmd,"Show Logical *");
1297       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1298         strcat(cmd," /Table=");
1299         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1300         cmddsc.dsc$w_length = strlen(cmd);
1301       }
1302       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1303       flags = defflags | CLI$M_NOCLISYM;
1304     }
1305
1306     /* Create a new subprocess to execute each command, to exclude the
1307      * remote possibility that someone could subvert a mbx or file used
1308      * to write multiple commands to a single subprocess.
1309      */
1310     do {
1311       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1312                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1313       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1314       defflags &= ~CLI$M_TRUSTED;
1315     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1316     _ckvmssts(retsts);
1317     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1318     if (seenhv) SvREFCNT_dec(seenhv);
1319     seenhv = newHV();
1320     while (1) {
1321       char *cp1, *cp2, *key;
1322       unsigned long int sts, iosb[2], retlen, keylen;
1323       register U32 hash;
1324
1325       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1326       if (sts & 1) sts = iosb[0] & 0xffff;
1327       if (sts == SS$_ENDOFFILE) {
1328         int wakect = 0;
1329         while (substs == 0) { sys$hiber(); wakect++;}
1330         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1331         _ckvmssts(substs);
1332         break;
1333       }
1334       _ckvmssts(sts);
1335       retlen = iosb[0] >> 16;
1336       if (!retlen) continue;  /* blank line */
1337       buf[retlen] = '\0';
1338       if (iosb[1] != subpid) {
1339         if (iosb[1]) {
1340           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1341         }
1342         continue;
1343       }
1344       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1345         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1346
1347       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1348       if (*cp1 == '(' || /* Logical name table name */
1349           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1350       if (*cp1 == '"') cp1++;
1351       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1352       key = cp1;  keylen = cp2 - cp1;
1353       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1354       while (*cp2 && *cp2 != '=') cp2++;
1355       while (*cp2 && *cp2 == '=') cp2++;
1356       while (*cp2 && *cp2 == ' ') cp2++;
1357       if (*cp2 == '"') {  /* String translation; may embed "" */
1358         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1359         cp2++;  cp1--; /* Skip "" surrounding translation */
1360       }
1361       else {  /* Numeric translation */
1362         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1363         cp1--;  /* stop on last non-space char */
1364       }
1365       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1366         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1367         continue;
1368       }
1369       PERL_HASH(hash,key,keylen);
1370
1371       if (cp1 == cp2 && *cp2 == '.') {
1372         /* A single dot usually means an unprintable character, such as a null
1373          * to indicate a zero-length value.  Get the actual value to make sure.
1374          */
1375         char lnm[LNM$C_NAMLENGTH+1];
1376         char eqv[MAX_DCL_SYMBOL+1];
1377         int trnlen;
1378         strncpy(lnm, key, keylen);
1379         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1380         sv = newSVpvn(eqv, strlen(eqv));
1381       }
1382       else {
1383         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1384       }
1385
1386       SvTAINTED_on(sv);
1387       hv_store(envhv,key,keylen,sv,hash);
1388       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1389     }
1390     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1391       /* get the PPFs for this process, not the subprocess */
1392       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1393       char eqv[LNM$C_NAMLENGTH+1];
1394       int trnlen, i;
1395       for (i = 0; ppfs[i]; i++) {
1396         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1397         sv = newSVpv(eqv,trnlen);
1398         SvTAINTED_on(sv);
1399         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1400       }
1401     }
1402   }
1403   primed = 1;
1404   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1405   if (buf) Safefree(buf);
1406   if (seenhv) SvREFCNT_dec(seenhv);
1407   MUTEX_UNLOCK(&primenv_mutex);
1408   return;
1409
1410 }  /* end of prime_env_iter */
1411 /*}}}*/
1412
1413
1414 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1415 /* Define or delete an element in the same "environment" as
1416  * vmstrnenv().  If an element is to be deleted, it's removed from
1417  * the first place it's found.  If it's to be set, it's set in the
1418  * place designated by the first element of the table vector.
1419  * Like setenv() returns 0 for success, non-zero on error.
1420  */
1421 int
1422 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1423 {
1424     const char *cp1;
1425     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1426     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1427     int nseg = 0, j;
1428     unsigned long int retsts, usermode = PSL$C_USER;
1429     struct itmlst_3 *ile, *ilist;
1430     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1431                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1432                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1433     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1434     $DESCRIPTOR(local,"_LOCAL");
1435
1436     if (!lnm) {
1437         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1438         return SS$_IVLOGNAM;
1439     }
1440
1441     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1442       *cp2 = _toupper(*cp1);
1443       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1444         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1445         return SS$_IVLOGNAM;
1446       }
1447     }
1448     lnmdsc.dsc$w_length = cp1 - lnm;
1449     if (!tabvec || !*tabvec) tabvec = env_tables;
1450
1451     if (!eqv) {  /* we're deleting n element */
1452       for (curtab = 0; tabvec[curtab]; curtab++) {
1453         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1454         int i;
1455           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1456             if ((cp1 = strchr(environ[i],'=')) &&
1457                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1458                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1459 #ifdef HAS_SETENV
1460               return setenv(lnm,"",1) ? vaxc$errno : 0;
1461             }
1462           }
1463           ivenv = 1; retsts = SS$_NOLOGNAM;
1464 #else
1465               if (ckWARN(WARN_INTERNAL))
1466                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1467               ivenv = 1; retsts = SS$_NOSUCHPGM;
1468               break;
1469             }
1470           }
1471 #endif
1472         }
1473         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1474                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1475           unsigned int symtype;
1476           if (tabvec[curtab]->dsc$w_length == 12 &&
1477               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1478               !str$case_blind_compare(&tmpdsc,&local))
1479             symtype = LIB$K_CLI_LOCAL_SYM;
1480           else symtype = LIB$K_CLI_GLOBAL_SYM;
1481           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1482           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1483           if (retsts == LIB$_NOSUCHSYM) continue;
1484           break;
1485         }
1486         else if (!ivlnm) {
1487           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1488           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1489           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1490           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1491           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1492         }
1493       }
1494     }
1495     else {  /* we're defining a value */
1496       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1497 #ifdef HAS_SETENV
1498         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1499 #else
1500         if (ckWARN(WARN_INTERNAL))
1501           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1502         retsts = SS$_NOSUCHPGM;
1503 #endif
1504       }
1505       else {
1506         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1507         eqvdsc.dsc$w_length  = strlen(eqv);
1508         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1509             !str$case_blind_compare(&tmpdsc,&clisym)) {
1510           unsigned int symtype;
1511           if (tabvec[0]->dsc$w_length == 12 &&
1512               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1513                !str$case_blind_compare(&tmpdsc,&local))
1514             symtype = LIB$K_CLI_LOCAL_SYM;
1515           else symtype = LIB$K_CLI_GLOBAL_SYM;
1516           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1517         }
1518         else {
1519           if (!*eqv) eqvdsc.dsc$w_length = 1;
1520           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1521
1522             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1523             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1524               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1525                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1526               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1527               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1528             }
1529
1530             Newx(ilist,nseg+1,struct itmlst_3);
1531             ile = ilist;
1532             if (!ile) {
1533               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1534               return SS$_INSFMEM;
1535             }
1536             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1537
1538             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1539               ile->itmcode = LNM$_STRING;
1540               ile->bufadr = c;
1541               if ((j+1) == nseg) {
1542                 ile->buflen = strlen(c);
1543                 /* in case we are truncating one that's too long */
1544                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1545               }
1546               else {
1547                 ile->buflen = LNM$C_NAMLENGTH;
1548               }
1549             }
1550
1551             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1552             Safefree (ilist);
1553           }
1554           else {
1555             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1556           }
1557         }
1558       }
1559     }
1560     if (!(retsts & 1)) {
1561       switch (retsts) {
1562         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1563         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1564           set_errno(EVMSERR); break;
1565         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1566         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1567           set_errno(EINVAL); break;
1568         case SS$_NOPRIV:
1569           set_errno(EACCES); break;
1570         default:
1571           _ckvmssts(retsts);
1572           set_errno(EVMSERR);
1573        }
1574        set_vaxc_errno(retsts);
1575        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1576     }
1577     else {
1578       /* We reset error values on success because Perl does an hv_fetch()
1579        * before each hv_store(), and if the thing we're setting didn't
1580        * previously exist, we've got a leftover error message.  (Of course,
1581        * this fails in the face of
1582        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1583        * in that the error reported in $! isn't spurious,
1584        * but it's right more often than not.)
1585        */
1586       set_errno(0); set_vaxc_errno(retsts);
1587       return 0;
1588     }
1589
1590 }  /* end of vmssetenv() */
1591 /*}}}*/
1592
1593 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1594 /* This has to be a function since there's a prototype for it in proto.h */
1595 void
1596 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1597 {
1598     if (lnm && *lnm) {
1599       int len = strlen(lnm);
1600       if  (len == 7) {
1601         char uplnm[8];
1602         int i;
1603         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1604         if (!strcmp(uplnm,"DEFAULT")) {
1605           if (eqv && *eqv) my_chdir(eqv);
1606           return;
1607         }
1608     }
1609 #ifndef RTL_USES_UTC
1610     if (len == 6 || len == 2) {
1611       char uplnm[7];
1612       int i;
1613       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1614       uplnm[len] = '\0';
1615       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1616       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1617     }
1618 #endif
1619   }
1620   (void) vmssetenv(lnm,eqv,NULL);
1621 }
1622 /*}}}*/
1623
1624 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1625 /*  vmssetuserlnm
1626  *  sets a user-mode logical in the process logical name table
1627  *  used for redirection of sys$error
1628  */
1629 void
1630 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1631 {
1632     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1633     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1634     unsigned long int iss, attr = LNM$M_CONFINE;
1635     unsigned char acmode = PSL$C_USER;
1636     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1637                                  {0, 0, 0, 0}};
1638     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1639     d_name.dsc$w_length = strlen(name);
1640
1641     lnmlst[0].buflen = strlen(eqv);
1642     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1643
1644     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1645     if (!(iss&1)) lib$signal(iss);
1646 }
1647 /*}}}*/
1648
1649
1650 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1651 /* my_crypt - VMS password hashing
1652  * my_crypt() provides an interface compatible with the Unix crypt()
1653  * C library function, and uses sys$hash_password() to perform VMS
1654  * password hashing.  The quadword hashed password value is returned
1655  * as a NUL-terminated 8 character string.  my_crypt() does not change
1656  * the case of its string arguments; in order to match the behavior
1657  * of LOGINOUT et al., alphabetic characters in both arguments must
1658  *  be upcased by the caller.
1659  *
1660  * - fix me to call ACM services when available
1661  */
1662 char *
1663 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1664 {
1665 #   ifndef UAI$C_PREFERRED_ALGORITHM
1666 #     define UAI$C_PREFERRED_ALGORITHM 127
1667 #   endif
1668     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1669     unsigned short int salt = 0;
1670     unsigned long int sts;
1671     struct const_dsc {
1672         unsigned short int dsc$w_length;
1673         unsigned char      dsc$b_type;
1674         unsigned char      dsc$b_class;
1675         const char *       dsc$a_pointer;
1676     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1677        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1678     struct itmlst_3 uailst[3] = {
1679         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1680         { sizeof salt, UAI$_SALT,    &salt, 0},
1681         { 0,           0,            NULL,  NULL}};
1682     static char hash[9];
1683
1684     usrdsc.dsc$w_length = strlen(usrname);
1685     usrdsc.dsc$a_pointer = usrname;
1686     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1687       switch (sts) {
1688         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1689           set_errno(EACCES);
1690           break;
1691         case RMS$_RNF:
1692           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1693           break;
1694         default:
1695           set_errno(EVMSERR);
1696       }
1697       set_vaxc_errno(sts);
1698       if (sts != RMS$_RNF) return NULL;
1699     }
1700
1701     txtdsc.dsc$w_length = strlen(textpasswd);
1702     txtdsc.dsc$a_pointer = textpasswd;
1703     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1704       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1705     }
1706
1707     return (char *) hash;
1708
1709 }  /* end of my_crypt() */
1710 /*}}}*/
1711
1712
1713 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1714 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1715 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1716
1717 /* fixup barenames that are directories for internal use.
1718  * There have been problems with the consistent handling of UNIX
1719  * style directory names when routines are presented with a name that
1720  * has no directory delimitors at all.  So this routine will eventually
1721  * fix the issue.
1722  */
1723 static char * fixup_bare_dirnames(const char * name)
1724 {
1725   if (decc_disable_to_vms_logname_translation) {
1726 /* fix me */
1727   }
1728   return NULL;
1729 }
1730
1731 /* mp_do_kill_file
1732  * A little hack to get around a bug in some implemenation of remove()
1733  * that do not know how to delete a directory
1734  *
1735  * Delete any file to which user has control access, regardless of whether
1736  * delete access is explicitly allowed.
1737  * Limitations: User must have write access to parent directory.
1738  *              Does not block signals or ASTs; if interrupted in midstream
1739  *              may leave file with an altered ACL.
1740  * HANDLE WITH CARE!
1741  */
1742 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1743 static int
1744 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1745 {
1746     char *vmsname, *rspec;
1747     char *remove_name;
1748     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1749     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1750     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1751     struct myacedef {
1752       unsigned char myace$b_length;
1753       unsigned char myace$b_type;
1754       unsigned short int myace$w_flags;
1755       unsigned long int myace$l_access;
1756       unsigned long int myace$l_ident;
1757     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1758                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1759       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1760      struct itmlst_3
1761        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1762                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1763        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1764        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1765        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1766        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1767
1768     /* Expand the input spec using RMS, since the CRTL remove() and
1769      * system services won't do this by themselves, so we may miss
1770      * a file "hiding" behind a logical name or search list. */
1771     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1772     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1773
1774     if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1775       PerlMem_free(vmsname);
1776       return -1;
1777     }
1778
1779     if (decc_posix_compliant_pathnames) {
1780       /* In POSIX mode, we prefer to remove the UNIX name */
1781       rspec = vmsname;
1782       remove_name = (char *)name;
1783     }
1784     else {
1785       rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1786       if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1787       if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1788         PerlMem_free(rspec);
1789         PerlMem_free(vmsname);
1790         return -1;
1791       }
1792       PerlMem_free(vmsname);
1793       remove_name = rspec;
1794     }
1795
1796 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1797     if (dirflag != 0) {
1798         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1799           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1800           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1801
1802           do_pathify_dirspec(name, remove_name, 0, NULL);
1803           if (!rmdir(remove_name)) {
1804
1805             PerlMem_free(remove_name);
1806             PerlMem_free(rspec);
1807             return 0;   /* Can we just get rid of it? */
1808           }
1809         }
1810         else {
1811           if (!rmdir(remove_name)) {
1812             PerlMem_free(rspec);
1813             return 0;   /* Can we just get rid of it? */
1814           }
1815         }
1816     }
1817     else
1818 #endif
1819       if (!remove(remove_name)) {
1820         PerlMem_free(rspec);
1821         return 0;   /* Can we just get rid of it? */
1822       }
1823
1824     /* If not, can changing protections help? */
1825     if (vaxc$errno != RMS$_PRV) {
1826       PerlMem_free(rspec);
1827       return -1;
1828     }
1829
1830     /* No, so we get our own UIC to use as a rights identifier,
1831      * and the insert an ACE at the head of the ACL which allows us
1832      * to delete the file.
1833      */
1834     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1835     fildsc.dsc$w_length = strlen(rspec);
1836     fildsc.dsc$a_pointer = rspec;
1837     cxt = 0;
1838     newace.myace$l_ident = oldace.myace$l_ident;
1839     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1840       switch (aclsts) {
1841         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1842           set_errno(ENOENT); break;
1843         case RMS$_DIR:
1844           set_errno(ENOTDIR); break;
1845         case RMS$_DEV:
1846           set_errno(ENODEV); break;
1847         case RMS$_SYN: case SS$_INVFILFOROP:
1848           set_errno(EINVAL); break;
1849         case RMS$_PRV:
1850           set_errno(EACCES); break;
1851         default:
1852           _ckvmssts(aclsts);
1853       }
1854       set_vaxc_errno(aclsts);
1855       PerlMem_free(rspec);
1856       return -1;
1857     }
1858     /* Grab any existing ACEs with this identifier in case we fail */
1859     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1860     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1861                     || fndsts == SS$_NOMOREACE ) {
1862       /* Add the new ACE . . . */
1863       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1864         goto yourroom;
1865
1866 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1867       if (dirflag != 0)
1868         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1869           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1870           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1871
1872           do_pathify_dirspec(name, remove_name, 0, NULL);
1873           rmsts = rmdir(remove_name);
1874           PerlMem_free(remove_name);
1875         }
1876         else {
1877         rmsts = rmdir(remove_name);
1878         }
1879       else
1880 #endif
1881         rmsts = remove(remove_name);
1882       if (rmsts) {
1883         /* We blew it - dir with files in it, no write priv for
1884          * parent directory, etc.  Put things back the way they were. */
1885         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1886           goto yourroom;
1887         if (fndsts & 1) {
1888           addlst[0].bufadr = &oldace;
1889           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1890             goto yourroom;
1891         }
1892       }
1893     }
1894
1895     yourroom:
1896     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1897     /* We just deleted it, so of course it's not there.  Some versions of
1898      * VMS seem to return success on the unlock operation anyhow (after all
1899      * the unlock is successful), but others don't.
1900      */
1901     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1902     if (aclsts & 1) aclsts = fndsts;
1903     if (!(aclsts & 1)) {
1904       set_errno(EVMSERR);
1905       set_vaxc_errno(aclsts);
1906       PerlMem_free(rspec);
1907       return -1;
1908     }
1909
1910     PerlMem_free(rspec);
1911     return rmsts;
1912
1913 }  /* end of kill_file() */
1914 /*}}}*/
1915
1916
1917 /*{{{int do_rmdir(char *name)*/
1918 int
1919 Perl_do_rmdir(pTHX_ const char *name)
1920 {
1921     char dirfile[NAM$C_MAXRSS+1];
1922     int retval;
1923     Stat_t st;
1924
1925     if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1926     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1927     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1928     return retval;
1929
1930 }  /* end of do_rmdir */
1931 /*}}}*/
1932
1933 /* kill_file
1934  * Delete any file to which user has control access, regardless of whether
1935  * delete access is explicitly allowed.
1936  * Limitations: User must have write access to parent directory.
1937  *              Does not block signals or ASTs; if interrupted in midstream
1938  *              may leave file with an altered ACL.
1939  * HANDLE WITH CARE!
1940  */
1941 /*{{{int kill_file(char *name)*/
1942 int
1943 Perl_kill_file(pTHX_ const char *name)
1944 {
1945     char rspec[NAM$C_MAXRSS+1];
1946     char *tspec;
1947     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1948     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1949     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1950     struct myacedef {
1951       unsigned char myace$b_length;
1952       unsigned char myace$b_type;
1953       unsigned short int myace$w_flags;
1954       unsigned long int myace$l_access;
1955       unsigned long int myace$l_ident;
1956     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1957                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1958       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1959      struct itmlst_3
1960        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1961                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1962        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1963        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1964        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1965        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1966
1967     /* Expand the input spec using RMS, since the CRTL remove() and
1968      * system services won't do this by themselves, so we may miss
1969      * a file "hiding" behind a logical name or search list. */
1970     tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1971     if (tspec == NULL) return -1;
1972     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1973     /* If not, can changing protections help? */
1974     if (vaxc$errno != RMS$_PRV) return -1;
1975
1976     /* No, so we get our own UIC to use as a rights identifier,
1977      * and the insert an ACE at the head of the ACL which allows us
1978      * to delete the file.
1979      */
1980     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1981     fildsc.dsc$w_length = strlen(rspec);
1982     fildsc.dsc$a_pointer = rspec;
1983     cxt = 0;
1984     newace.myace$l_ident = oldace.myace$l_ident;
1985     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1986       switch (aclsts) {
1987         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1988           set_errno(ENOENT); break;
1989         case RMS$_DIR:
1990           set_errno(ENOTDIR); break;
1991         case RMS$_DEV:
1992           set_errno(ENODEV); break;
1993         case RMS$_SYN: case SS$_INVFILFOROP:
1994           set_errno(EINVAL); break;
1995         case RMS$_PRV:
1996           set_errno(EACCES); break;
1997         default:
1998           _ckvmssts(aclsts);
1999       }
2000       set_vaxc_errno(aclsts);
2001       return -1;
2002     }
2003     /* Grab any existing ACEs with this identifier in case we fail */
2004     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2005     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2006                     || fndsts == SS$_NOMOREACE ) {
2007       /* Add the new ACE . . . */
2008       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2009         goto yourroom;
2010       if ((rmsts = remove(name))) {
2011         /* We blew it - dir with files in it, no write priv for
2012          * parent directory, etc.  Put things back the way they were. */
2013         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2014           goto yourroom;
2015         if (fndsts & 1) {
2016           addlst[0].bufadr = &oldace;
2017           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2018             goto yourroom;
2019         }
2020       }
2021     }
2022
2023     yourroom:
2024     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2025     /* We just deleted it, so of course it's not there.  Some versions of
2026      * VMS seem to return success on the unlock operation anyhow (after all
2027      * the unlock is successful), but others don't.
2028      */
2029     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2030     if (aclsts & 1) aclsts = fndsts;
2031     if (!(aclsts & 1)) {
2032       set_errno(EVMSERR);
2033       set_vaxc_errno(aclsts);
2034       return -1;
2035     }
2036
2037     return rmsts;
2038
2039 }  /* end of kill_file() */
2040 /*}}}*/
2041
2042
2043 /*{{{int my_mkdir(char *,Mode_t)*/
2044 int
2045 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2046 {
2047   STRLEN dirlen = strlen(dir);
2048
2049   /* zero length string sometimes gives ACCVIO */
2050   if (dirlen == 0) return -1;
2051
2052   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2053    * null file name/type.  However, it's commonplace under Unix,
2054    * so we'll allow it for a gain in portability.
2055    */
2056   if (dir[dirlen-1] == '/') {
2057     char *newdir = savepvn(dir,dirlen-1);
2058     int ret = mkdir(newdir,mode);
2059     Safefree(newdir);
2060     return ret;
2061   }
2062   else return mkdir(dir,mode);
2063 }  /* end of my_mkdir */
2064 /*}}}*/
2065
2066 /*{{{int my_chdir(char *)*/
2067 int
2068 Perl_my_chdir(pTHX_ const char *dir)
2069 {
2070   STRLEN dirlen = strlen(dir);
2071
2072   /* zero length string sometimes gives ACCVIO */
2073   if (dirlen == 0) return -1;
2074   const char *dir1;
2075
2076   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2077    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2078    * so that existing scripts do not need to be changed.
2079    */
2080   dir1 = dir;
2081   while ((dirlen > 0) && (*dir1 == ' ')) {
2082     dir1++;
2083     dirlen--;
2084   }
2085
2086   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2087    * that implies
2088    * null file name/type.  However, it's commonplace under Unix,
2089    * so we'll allow it for a gain in portability.
2090    *
2091    * - Preview- '/' will be valid soon on VMS
2092    */
2093   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2094     char *newdir = savepvn(dir1,dirlen-1);
2095     int ret = chdir(newdir);
2096     Safefree(newdir);
2097     return ret;
2098   }
2099   else return chdir(dir1);
2100 }  /* end of my_chdir */
2101 /*}}}*/
2102
2103
2104 /*{{{FILE *my_tmpfile()*/
2105 FILE *
2106 my_tmpfile(void)
2107 {
2108   FILE *fp;
2109   char *cp;
2110
2111   if ((fp = tmpfile())) return fp;
2112
2113   cp = PerlMem_malloc(L_tmpnam+24);
2114   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2115
2116   if (decc_filename_unix_only == 0)
2117     strcpy(cp,"Sys$Scratch:");
2118   else
2119     strcpy(cp,"/tmp/");
2120   tmpnam(cp+strlen(cp));
2121   strcat(cp,".Perltmp");
2122   fp = fopen(cp,"w+","fop=dlt");
2123   PerlMem_free(cp);
2124   return fp;
2125 }
2126 /*}}}*/
2127
2128
2129 #ifndef HOMEGROWN_POSIX_SIGNALS
2130 /*
2131  * The C RTL's sigaction fails to check for invalid signal numbers so we
2132  * help it out a bit.  The docs are correct, but the actual routine doesn't
2133  * do what the docs say it will.
2134  */
2135 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2136 int
2137 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2138                    struct sigaction* oact)
2139 {
2140   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2141         SETERRNO(EINVAL, SS$_INVARG);
2142         return -1;
2143   }
2144   return sigaction(sig, act, oact);
2145 }
2146 /*}}}*/
2147 #endif
2148
2149 #ifdef KILL_BY_SIGPRC
2150 #include <errnodef.h>
2151
2152 /* We implement our own kill() using the undocumented system service
2153    sys$sigprc for one of two reasons:
2154
2155    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2156    target process to do a sys$exit, which usually can't be handled
2157    gracefully...certainly not by Perl and the %SIG{} mechanism.
2158
2159    2.) If the kill() in the CRTL can't be called from a signal
2160    handler without disappearing into the ether, i.e., the signal
2161    it purportedly sends is never trapped. Still true as of VMS 7.3.
2162
2163    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2164    in the target process rather than calling sys$exit.
2165
2166    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2167    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2168    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2169    with condition codes C$_SIG0+nsig*8, catching the exception on the
2170    target process and resignaling with appropriate arguments.
2171
2172    But we don't have that VMS 7.0+ exception handler, so if you
2173    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2174
2175    Also note that SIGTERM is listed in the docs as being "unimplemented",
2176    yet always seems to be signaled with a VMS condition code of 4 (and
2177    correctly handled for that code).  So we hardwire it in.
2178
2179    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2180    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2181    than signalling with an unrecognized (and unhandled by CRTL) code.
2182 */
2183
2184 #define _MY_SIG_MAX 28
2185
2186 static unsigned int
2187 Perl_sig_to_vmscondition_int(int sig)
2188 {
2189     static unsigned int sig_code[_MY_SIG_MAX+1] =
2190     {
2191         0,                  /*  0 ZERO     */
2192         SS$_HANGUP,         /*  1 SIGHUP   */
2193         SS$_CONTROLC,       /*  2 SIGINT   */
2194         SS$_CONTROLY,       /*  3 SIGQUIT  */
2195         SS$_RADRMOD,        /*  4 SIGILL   */
2196         SS$_BREAK,          /*  5 SIGTRAP  */
2197         SS$_OPCCUS,         /*  6 SIGABRT  */
2198         SS$_COMPAT,         /*  7 SIGEMT   */
2199 #ifdef __VAX
2200         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2201 #else
2202         SS$_HPARITH,        /*  8 SIGFPE AXP */
2203 #endif
2204         SS$_ABORT,          /*  9 SIGKILL  */
2205         SS$_ACCVIO,         /* 10 SIGBUS   */
2206         SS$_ACCVIO,         /* 11 SIGSEGV  */
2207         SS$_BADPARAM,       /* 12 SIGSYS   */
2208         SS$_NOMBX,          /* 13 SIGPIPE  */
2209         SS$_ASTFLT,         /* 14 SIGALRM  */
2210         4,                  /* 15 SIGTERM  */
2211         0,                  /* 16 SIGUSR1  */
2212         0,                  /* 17 SIGUSR2  */
2213         0,                  /* 18 */
2214         0,                  /* 19 */
2215         0,                  /* 20 SIGCHLD  */
2216         0,                  /* 21 SIGCONT  */
2217         0,                  /* 22 SIGSTOP  */
2218         0,                  /* 23 SIGTSTP  */
2219         0,                  /* 24 SIGTTIN  */
2220         0,                  /* 25 SIGTTOU  */
2221         0,                  /* 26 */
2222         0,                  /* 27 */
2223         0                   /* 28 SIGWINCH  */
2224     };
2225
2226 #if __VMS_VER >= 60200000
2227     static int initted = 0;
2228     if (!initted) {
2229         initted = 1;
2230         sig_code[16] = C$_SIGUSR1;
2231         sig_code[17] = C$_SIGUSR2;
2232 #if __CRTL_VER >= 70000000
2233         sig_code[20] = C$_SIGCHLD;
2234 #endif
2235 #if __CRTL_VER >= 70300000
2236         sig_code[28] = C$_SIGWINCH;
2237 #endif
2238     }
2239 #endif
2240
2241     if (sig < _SIG_MIN) return 0;
2242     if (sig > _MY_SIG_MAX) return 0;
2243     return sig_code[sig];
2244 }
2245
2246 unsigned int
2247 Perl_sig_to_vmscondition(int sig)
2248 {
2249 #ifdef SS$_DEBUG
2250     if (vms_debug_on_exception != 0)
2251         lib$signal(SS$_DEBUG);
2252 #endif
2253     return Perl_sig_to_vmscondition_int(sig);
2254 }
2255
2256
2257 int
2258 Perl_my_kill(int pid, int sig)
2259 {
2260     dTHX;
2261     int iss;
2262     unsigned int code;
2263     int sys$sigprc(unsigned int *pidadr,
2264                      struct dsc$descriptor_s *prcname,
2265                      unsigned int code);
2266
2267      /* sig 0 means validate the PID */
2268     /*------------------------------*/
2269     if (sig == 0) {
2270         const unsigned long int jpicode = JPI$_PID;
2271         pid_t ret_pid;
2272         int status;
2273         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2274         if ($VMS_STATUS_SUCCESS(status))
2275            return 0;
2276         switch (status) {
2277         case SS$_NOSUCHNODE:
2278         case SS$_UNREACHABLE:
2279         case SS$_NONEXPR:
2280            errno = ESRCH;
2281            break;
2282         case SS$_NOPRIV:
2283            errno = EPERM;
2284            break;
2285         default:
2286            errno = EVMSERR;
2287         }
2288         vaxc$errno=status;
2289         return -1;
2290     }
2291
2292     code = Perl_sig_to_vmscondition_int(sig);
2293
2294     if (!code) {
2295         SETERRNO(EINVAL, SS$_BADPARAM);
2296         return -1;
2297     }
2298
2299     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2300      * signals are to be sent to multiple processes.
2301      *  pid = 0 - all processes in group except ones that the system exempts
2302      *  pid = -1 - all processes except ones that the system exempts
2303      *  pid = -n - all processes in group (abs(n)) except ...
2304      * For now, just report as not supported.
2305      */
2306
2307     if (pid <= 0) {
2308         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2309         return -1;
2310     }
2311
2312     iss = sys$sigprc((unsigned int *)&pid,0,code);
2313     if (iss&1) return 0;
2314
2315     switch (iss) {
2316       case SS$_NOPRIV:
2317         set_errno(EPERM);  break;
2318       case SS$_NONEXPR:
2319       case SS$_NOSUCHNODE:
2320       case SS$_UNREACHABLE:
2321         set_errno(ESRCH);  break;
2322       case SS$_INSFMEM:
2323         set_errno(ENOMEM); break;
2324       default:
2325         _ckvmssts(iss);
2326         set_errno(EVMSERR);
2327     }
2328     set_vaxc_errno(iss);
2329
2330     return -1;
2331 }
2332 #endif
2333
2334 /* Routine to convert a VMS status code to a UNIX status code.
2335 ** More tricky than it appears because of conflicting conventions with
2336 ** existing code.
2337 **
2338 ** VMS status codes are a bit mask, with the least significant bit set for
2339 ** success.
2340 **
2341 ** Special UNIX status of EVMSERR indicates that no translation is currently
2342 ** available, and programs should check the VMS status code.
2343 **
2344 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2345 ** decoding.
2346 */
2347
2348 #ifndef C_FACILITY_NO
2349 #define C_FACILITY_NO 0x350000
2350 #endif
2351 #ifndef DCL_IVVERB
2352 #define DCL_IVVERB 0x38090
2353 #endif
2354
2355 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2356 {
2357 int facility;
2358 int fac_sp;
2359 int msg_no;
2360 int msg_status;
2361 int unix_status;
2362
2363   /* Assume the best or the worst */
2364   if (vms_status & STS$M_SUCCESS)
2365     unix_status = 0;
2366   else
2367     unix_status = EVMSERR;
2368
2369   msg_status = vms_status & ~STS$M_CONTROL;
2370
2371   facility = vms_status & STS$M_FAC_NO;
2372   fac_sp = vms_status & STS$M_FAC_SP;
2373   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2374
2375   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2376     switch(msg_no) {
2377     case SS$_NORMAL:
2378         unix_status = 0;
2379         break;
2380     case SS$_ACCVIO:
2381         unix_status = EFAULT;
2382         break;
2383     case SS$_DEVOFFLINE:
2384         unix_status = EBUSY;
2385         break;
2386     case SS$_CLEARED:
2387         unix_status = ENOTCONN;
2388         break;
2389     case SS$_IVCHAN:
2390     case SS$_IVLOGNAM:
2391     case SS$_BADPARAM:
2392     case SS$_IVLOGTAB:
2393     case SS$_NOLOGNAM:
2394     case SS$_NOLOGTAB:
2395     case SS$_INVFILFOROP:
2396     case SS$_INVARG:
2397     case SS$_NOSUCHID:
2398     case SS$_IVIDENT:
2399         unix_status = EINVAL;
2400         break;
2401     case SS$_UNSUPPORTED:
2402         unix_status = ENOTSUP;
2403         break;
2404     case SS$_FILACCERR:
2405     case SS$_NOGRPPRV:
2406     case SS$_NOSYSPRV:
2407         unix_status = EACCES;
2408         break;
2409     case SS$_DEVICEFULL:
2410         unix_status = ENOSPC;
2411         break;
2412     case SS$_NOSUCHDEV:
2413         unix_status = ENODEV;
2414         break;
2415     case SS$_NOSUCHFILE:
2416     case SS$_NOSUCHOBJECT:
2417         unix_status = ENOENT;
2418         break;
2419     case SS$_ABORT:                                 /* Fatal case */
2420     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2421     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2422         unix_status = EINTR;
2423         break;
2424     case SS$_BUFFEROVF:
2425         unix_status = E2BIG;
2426         break;
2427     case SS$_INSFMEM:
2428         unix_status = ENOMEM;
2429         break;
2430     case SS$_NOPRIV:
2431         unix_status = EPERM;
2432         break;
2433     case SS$_NOSUCHNODE:
2434     case SS$_UNREACHABLE:
2435         unix_status = ESRCH;
2436         break;
2437     case SS$_NONEXPR:
2438         unix_status = ECHILD;
2439         break;
2440     default:
2441         if ((facility == 0) && (msg_no < 8)) {
2442           /* These are not real VMS status codes so assume that they are
2443           ** already UNIX status codes
2444           */
2445           unix_status = msg_no;
2446           break;
2447         }
2448     }
2449   }
2450   else {
2451     /* Translate a POSIX exit code to a UNIX exit code */
2452     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2453         unix_status = (msg_no & 0x07F8) >> 3;
2454     }
2455     else {
2456
2457          /* Documented traditional behavior for handling VMS child exits */
2458         /*--------------------------------------------------------------*/
2459         if (child_flag != 0) {
2460
2461              /* Success / Informational return 0 */
2462             /*----------------------------------*/
2463             if (msg_no & STS$K_SUCCESS)
2464                 return 0;
2465
2466              /* Warning returns 1 */
2467             /*-------------------*/
2468             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2469                 return 1;
2470
2471              /* Everything else pass through the severity bits */
2472             /*------------------------------------------------*/
2473             return (msg_no & STS$M_SEVERITY);
2474         }
2475
2476          /* Normal VMS status to ERRNO mapping attempt */
2477         /*--------------------------------------------*/
2478         switch(msg_status) {
2479         /* case RMS$_EOF: */ /* End of File */
2480         case RMS$_FNF:  /* File Not Found */
2481         case RMS$_DNF:  /* Dir Not Found */
2482                 unix_status = ENOENT;
2483                 break;
2484         case RMS$_RNF:  /* Record Not Found */
2485                 unix_status = ESRCH;
2486                 break;
2487         case RMS$_DIR:
2488                 unix_status = ENOTDIR;
2489                 break;
2490         case RMS$_DEV:
2491                 unix_status = ENODEV;
2492                 break;
2493         case RMS$_IFI:
2494         case RMS$_FAC:
2495         case RMS$_ISI:
2496                 unix_status = EBADF;
2497                 break;
2498         case RMS$_FEX:
2499                 unix_status = EEXIST;
2500                 break;
2501         case RMS$_SYN:
2502         case RMS$_FNM:
2503         case LIB$_INVSTRDES:
2504         case LIB$_INVARG:
2505         case LIB$_NOSUCHSYM:
2506         case LIB$_INVSYMNAM:
2507         case DCL_IVVERB:
2508                 unix_status = EINVAL;
2509                 break;
2510         case CLI$_BUFOVF:
2511         case RMS$_RTB:
2512         case CLI$_TKNOVF:
2513         case CLI$_RSLOVF:
2514                 unix_status = E2BIG;
2515                 break;
2516         case RMS$_PRV:  /* No privilege */
2517         case RMS$_ACC:  /* ACP file access failed */
2518         case RMS$_WLK:  /* Device write locked */
2519                 unix_status = EACCES;
2520                 break;
2521         /* case RMS$_NMF: */  /* No more files */
2522         }
2523     }
2524   }
2525
2526   return unix_status;
2527 }
2528
2529 /* Try to guess at what VMS error status should go with a UNIX errno
2530  * value.  This is hard to do as there could be many possible VMS
2531  * error statuses that caused the errno value to be set.
2532  */
2533
2534 int Perl_unix_status_to_vms(int unix_status)
2535 {
2536 int test_unix_status;
2537
2538      /* Trivial cases first */
2539     /*---------------------*/
2540     if (unix_status == EVMSERR)
2541         return vaxc$errno;
2542
2543      /* Is vaxc$errno sane? */
2544     /*---------------------*/
2545     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2546     if (test_unix_status == unix_status)
2547         return vaxc$errno;
2548
2549      /* If way out of range, must be VMS code already */
2550     /*-----------------------------------------------*/
2551     if (unix_status > EVMSERR)
2552         return unix_status;
2553
2554      /* If out of range, punt */
2555     /*-----------------------*/
2556     if (unix_status > __ERRNO_MAX)
2557         return SS$_ABORT;
2558
2559
2560      /* Ok, now we have to do it the hard way. */
2561     /*----------------------------------------*/
2562     switch(unix_status) {
2563     case 0:     return SS$_NORMAL;
2564     case EPERM: return SS$_NOPRIV;
2565     case ENOENT: return SS$_NOSUCHOBJECT;
2566     case ESRCH: return SS$_UNREACHABLE;
2567     case EINTR: return SS$_ABORT;
2568     /* case EIO: */
2569     /* case ENXIO:  */
2570     case E2BIG: return SS$_BUFFEROVF;
2571     /* case ENOEXEC */
2572     case EBADF: return RMS$_IFI;
2573     case ECHILD: return SS$_NONEXPR;
2574     /* case EAGAIN */
2575     case ENOMEM: return SS$_INSFMEM;
2576     case EACCES: return SS$_FILACCERR;
2577     case EFAULT: return SS$_ACCVIO;
2578     /* case ENOTBLK */
2579     case EBUSY: return SS$_DEVOFFLINE;
2580     case EEXIST: return RMS$_FEX;
2581     /* case EXDEV */
2582     case ENODEV: return SS$_NOSUCHDEV;
2583     case ENOTDIR: return RMS$_DIR;
2584     /* case EISDIR */
2585     case EINVAL: return SS$_INVARG;
2586     /* case ENFILE */
2587     /* case EMFILE */
2588     /* case ENOTTY */
2589     /* case ETXTBSY */
2590     /* case EFBIG */
2591     case ENOSPC: return SS$_DEVICEFULL;
2592     case ESPIPE: return LIB$_INVARG;
2593     /* case EROFS: */
2594     /* case EMLINK: */
2595     /* case EPIPE: */
2596     /* case EDOM */
2597     case ERANGE: return LIB$_INVARG;
2598     /* case EWOULDBLOCK */
2599     /* case EINPROGRESS */
2600     /* case EALREADY */
2601     /* case ENOTSOCK */
2602     /* case EDESTADDRREQ */
2603     /* case EMSGSIZE */
2604     /* case EPROTOTYPE */
2605     /* case ENOPROTOOPT */
2606     /* case EPROTONOSUPPORT */
2607     /* case ESOCKTNOSUPPORT */
2608     /* case EOPNOTSUPP */
2609     /* case EPFNOSUPPORT */
2610     /* case EAFNOSUPPORT */
2611     /* case EADDRINUSE */
2612     /* case EADDRNOTAVAIL */
2613     /* case ENETDOWN */
2614     /* case ENETUNREACH */
2615     /* case ENETRESET */
2616     /* case ECONNABORTED */
2617     /* case ECONNRESET */
2618     /* case ENOBUFS */
2619     /* case EISCONN */
2620     case ENOTCONN: return SS$_CLEARED;
2621     /* case ESHUTDOWN */
2622     /* case ETOOMANYREFS */
2623     /* case ETIMEDOUT */
2624     /* case ECONNREFUSED */
2625     /* case ELOOP */
2626     /* case ENAMETOOLONG */
2627     /* case EHOSTDOWN */
2628     /* case EHOSTUNREACH */
2629     /* case ENOTEMPTY */
2630     /* case EPROCLIM */
2631     /* case EUSERS  */
2632     /* case EDQUOT  */
2633     /* case ENOMSG  */
2634     /* case EIDRM */
2635     /* case EALIGN */
2636     /* case ESTALE */
2637     /* case EREMOTE */
2638     /* case ENOLCK */
2639     /* case ENOSYS */
2640     /* case EFTYPE */
2641     /* case ECANCELED */
2642     /* case EFAIL */
2643     /* case EINPROG */
2644     case ENOTSUP:
2645         return SS$_UNSUPPORTED;
2646     /* case EDEADLK */
2647     /* case ENWAIT */
2648     /* case EILSEQ */
2649     /* case EBADCAT */
2650     /* case EBADMSG */
2651     /* case EABANDONED */
2652     default:
2653         return SS$_ABORT; /* punt */
2654     }
2655
2656   return SS$_ABORT; /* Should not get here */
2657 }
2658
2659
2660 /* default piping mailbox size */
2661 #define PERL_BUFSIZ        512
2662
2663
2664 static void
2665 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2666 {
2667   unsigned long int mbxbufsiz;
2668   static unsigned long int syssize = 0;
2669   unsigned long int dviitm = DVI$_DEVNAM;
2670   char csize[LNM$C_NAMLENGTH+1];
2671   int sts;
2672
2673   if (!syssize) {
2674     unsigned long syiitm = SYI$_MAXBUF;
2675     /*
2676      * Get the SYSGEN parameter MAXBUF
2677      *
2678      * If the logical 'PERL_MBX_SIZE' is defined
2679      * use the value of the logical instead of PERL_BUFSIZ, but
2680      * keep the size between 128 and MAXBUF.
2681      *
2682      */
2683     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2684   }
2685
2686   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2687       mbxbufsiz = atoi(csize);
2688   } else {
2689       mbxbufsiz = PERL_BUFSIZ;
2690   }
2691   if (mbxbufsiz < 128) mbxbufsiz = 128;
2692   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2693
2694   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2695
2696   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2697   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2698
2699 }  /* end of create_mbx() */
2700
2701
2702 /*{{{  my_popen and my_pclose*/
2703
2704 typedef struct _iosb           IOSB;
2705 typedef struct _iosb*         pIOSB;
2706 typedef struct _pipe           Pipe;
2707 typedef struct _pipe*         pPipe;
2708 typedef struct pipe_details    Info;
2709 typedef struct pipe_details*  pInfo;
2710 typedef struct _srqp            RQE;
2711 typedef struct _srqp*          pRQE;
2712 typedef struct _tochildbuf      CBuf;
2713 typedef struct _tochildbuf*    pCBuf;
2714
2715 struct _iosb {
2716     unsigned short status;
2717     unsigned short count;
2718     unsigned long  dvispec;
2719 };
2720
2721 #pragma member_alignment save
2722 #pragma nomember_alignment quadword
2723 struct _srqp {          /* VMS self-relative queue entry */
2724     unsigned long qptr[2];
2725 };
2726 #pragma member_alignment restore
2727 static RQE  RQE_ZERO = {0,0};
2728
2729 struct _tochildbuf {
2730     RQE             q;
2731     int             eof;
2732     unsigned short  size;
2733     char            *buf;
2734 };
2735
2736 struct _pipe {
2737     RQE            free;
2738     RQE            wait;
2739     int            fd_out;
2740     unsigned short chan_in;
2741     unsigned short chan_out;
2742     char          *buf;
2743     unsigned int   bufsize;
2744     IOSB           iosb;
2745     IOSB           iosb2;
2746     int           *pipe_done;
2747     int            retry;
2748     int            type;
2749     int            shut_on_empty;
2750     int            need_wake;
2751     pPipe         *home;
2752     pInfo          info;
2753     pCBuf          curr;
2754     pCBuf          curr2;
2755 #if defined(PERL_IMPLICIT_CONTEXT)
2756     void            *thx;           /* Either a thread or an interpreter */
2757                                     /* pointer, depending on how we're built */
2758 #endif
2759 };
2760
2761
2762 struct pipe_details
2763 {
2764     pInfo           next;
2765     PerlIO *fp;  /* file pointer to pipe mailbox */
2766     int useFILE; /* using stdio, not perlio */
2767     int pid;   /* PID of subprocess */
2768     int mode;  /* == 'r' if pipe open for reading */
2769     int done;  /* subprocess has completed */
2770     int waiting; /* waiting for completion/closure */
2771     int             closing;        /* my_pclose is closing this pipe */
2772     unsigned long   completion;     /* termination status of subprocess */
2773     pPipe           in;             /* pipe in to sub */
2774     pPipe           out;            /* pipe out of sub */
2775     pPipe           err;            /* pipe of sub's sys$error */
2776     int             in_done;        /* true when in pipe finished */
2777     int             out_done;
2778     int             err_done;
2779     unsigned short  xchan;          /* channel to debug xterm */
2780     unsigned short  xchan_valid;    /* channel is assigned */
2781 };
2782
2783 struct exit_control_block
2784 {
2785     struct exit_control_block *flink;
2786     unsigned long int   (*exit_routine)();
2787     unsigned long int arg_count;
2788     unsigned long int *status_address;
2789     unsigned long int exit_status;
2790 };
2791
2792 typedef struct _closed_pipes    Xpipe;
2793 typedef struct _closed_pipes*  pXpipe;
2794
2795 struct _closed_pipes {
2796     int             pid;            /* PID of subprocess */
2797     unsigned long   completion;     /* termination status of subprocess */
2798 };
2799 #define NKEEPCLOSED 50
2800 static Xpipe closed_list[NKEEPCLOSED];
2801 static int   closed_index = 0;
2802 static int   closed_num = 0;
2803
2804 #define RETRY_DELAY     "0 ::0.20"
2805 #define MAX_RETRY              50
2806
2807 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2808 static unsigned long mypid;
2809 static unsigned long delaytime[2];
2810
2811 static pInfo open_pipes = NULL;
2812 static $DESCRIPTOR(nl_desc, "NL:");
2813
2814 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2815
2816
2817
2818 static unsigned long int
2819 pipe_exit_routine(pTHX)
2820 {
2821     pInfo info;
2822     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2823     int sts, did_stuff, need_eof, j;
2824
2825     /*
2826         flush any pending i/o
2827     */
2828     info = open_pipes;
2829     while (info) {
2830         if (info->fp) {
2831            if (!info->useFILE)
2832                PerlIO_flush(info->fp);   /* first, flush data */
2833            else
2834                fflush((FILE *)info->fp);
2835         }
2836         info = info->next;
2837     }
2838
2839     /*
2840      next we try sending an EOF...ignore if doesn't work, make sure we
2841      don't hang
2842     */
2843     did_stuff = 0;
2844     info = open_pipes;
2845
2846     while (info) {
2847       int need_eof;
2848       _ckvmssts_noperl(sys$setast(0));
2849       if (info->in && !info->in->shut_on_empty) {
2850         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2851                           0, 0, 0, 0, 0, 0));
2852         info->waiting = 1;
2853         did_stuff = 1;
2854       }
2855       _ckvmssts_noperl(sys$setast(1));
2856       info = info->next;
2857     }
2858
2859     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2860
2861     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2862         int nwait = 0;
2863
2864         info = open_pipes;
2865         while (info) {
2866           _ckvmssts_noperl(sys$setast(0));
2867           if (info->waiting && info->done)
2868                 info->waiting = 0;
2869           nwait += info->waiting;
2870           _ckvmssts_noperl(sys$setast(1));
2871           info = info->next;
2872         }
2873         if (!nwait) break;
2874         sleep(1);
2875     }
2876
2877     did_stuff = 0;
2878     info = open_pipes;
2879     while (info) {
2880       _ckvmssts_noperl(sys$setast(0));
2881       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2882         sts = sys$forcex(&info->pid,0,&abort);
2883         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2884         did_stuff = 1;
2885       }
2886       _ckvmssts_noperl(sys$setast(1));
2887       info = info->next;
2888     }
2889
2890     /* again, wait for effect */
2891
2892     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2893         int nwait = 0;
2894
2895         info = open_pipes;
2896         while (info) {
2897           _ckvmssts_noperl(sys$setast(0));
2898           if (info->waiting && info->done)
2899                 info->waiting = 0;
2900           nwait += info->waiting;
2901           _ckvmssts_noperl(sys$setast(1));
2902           info = info->next;
2903         }
2904         if (!nwait) break;
2905         sleep(1);
2906     }
2907
2908     info = open_pipes;
2909     while (info) {
2910       _ckvmssts_noperl(sys$setast(0));
2911       if (!info->done) {  /* We tried to be nice . . . */
2912         sts = sys$delprc(&info->pid,0);
2913         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2914         info->done = 1;  /* sys$delprc is as done as we're going to get. */
2915       }
2916       _ckvmssts_noperl(sys$setast(1));
2917       info = info->next;
2918     }
2919
2920     while(open_pipes) {
2921       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2922       else if (!(sts & 1)) retsts = sts;
2923     }
2924     return retsts;
2925 }
2926
2927 static struct exit_control_block pipe_exitblock =
2928        {(struct exit_control_block *) 0,
2929         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2930
2931 static void pipe_mbxtofd_ast(pPipe p);
2932 static void pipe_tochild1_ast(pPipe p);
2933 static void pipe_tochild2_ast(pPipe p);
2934
2935 static void
2936 popen_completion_ast(pInfo info)
2937 {
2938   pInfo i = open_pipes;
2939   int iss;
2940   int sts;
2941   pXpipe x;
2942
2943   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2944   closed_list[closed_index].pid = info->pid;
2945   closed_list[closed_index].completion = info->completion;
2946   closed_index++;
2947   if (closed_index == NKEEPCLOSED)
2948     closed_index = 0;
2949   closed_num++;
2950
2951   while (i) {
2952     if (i == info) break;
2953     i = i->next;
2954   }
2955   if (!i) return;       /* unlinked, probably freed too */
2956
2957   info->done = TRUE;
2958
2959 /*
2960     Writing to subprocess ...
2961             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2962
2963             chan_out may be waiting for "done" flag, or hung waiting
2964             for i/o completion to child...cancel the i/o.  This will
2965             put it into "snarf mode" (done but no EOF yet) that discards
2966             input.
2967
2968     Output from subprocess (stdout, stderr) needs to be flushed and
2969     shut down.   We try sending an EOF, but if the mbx is full the pipe
2970     routine should still catch the "shut_on_empty" flag, telling it to
2971     use immediate-style reads so that "mbx empty" -> EOF.
2972
2973
2974 */
2975   if (info->in && !info->in_done) {               /* only for mode=w */
2976         if (info->in->shut_on_empty && info->in->need_wake) {
2977             info->in->need_wake = FALSE;
2978             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2979         } else {
2980             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2981         }
2982   }
2983
2984   if (info->out && !info->out_done) {             /* were we also piping output? */
2985       info->out->shut_on_empty = TRUE;
2986       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2987       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2988       _ckvmssts_noperl(iss);
2989   }
2990
2991   if (info->err && !info->err_done) {        /* we were piping stderr */
2992         info->err->shut_on_empty = TRUE;
2993         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2994         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2995         _ckvmssts_noperl(iss);
2996   }
2997   _ckvmssts_noperl(sys$setef(pipe_ef));
2998
2999 }
3000
3001 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3002 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3003
3004 /*
3005     we actually differ from vmstrnenv since we use this to
3006     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3007     are pointing to the same thing
3008 */
3009
3010 static unsigned short
3011 popen_translate(pTHX_ char *logical, char *result)
3012 {
3013     int iss;
3014     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3015     $DESCRIPTOR(d_log,"");
3016     struct _il3 {
3017         unsigned short length;
3018         unsigned short code;
3019         char *         buffer_addr;
3020         unsigned short *retlenaddr;
3021     } itmlst[2];
3022     unsigned short l, ifi;
3023
3024     d_log.dsc$a_pointer = logical;
3025     d_log.dsc$w_length  = strlen(logical);
3026
3027     itmlst[0].code = LNM$_STRING;
3028     itmlst[0].length = 255;
3029     itmlst[0].buffer_addr = result;
3030     itmlst[0].retlenaddr = &l;
3031
3032     itmlst[1].code = 0;
3033     itmlst[1].length = 0;
3034     itmlst[1].buffer_addr = 0;
3035     itmlst[1].retlenaddr = 0;
3036
3037     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3038     if (iss == SS$_NOLOGNAM) {
3039         iss = SS$_NORMAL;
3040         l = 0;
3041     }
3042     if (!(iss&1)) lib$signal(iss);
3043     result[l] = '\0';
3044 /*
3045     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3046     strip it off and return the ifi, if any
3047 */
3048     ifi  = 0;
3049     if (result[0] == 0x1b && result[1] == 0x00) {
3050         memmove(&ifi,result+2,2);
3051         strcpy(result,result+4);
3052     }
3053     return ifi;     /* this is the RMS internal file id */
3054 }
3055
3056 static void pipe_infromchild_ast(pPipe p);
3057
3058 /*
3059     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3060     inside an AST routine without worrying about reentrancy and which Perl
3061     memory allocator is being used.
3062
3063     We read data and queue up the buffers, then spit them out one at a
3064     time to the output mailbox when the output mailbox is ready for one.
3065
3066 */
3067 #define INITIAL_TOCHILDQUEUE  2
3068
3069 static pPipe
3070 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3071 {
3072     pPipe p;
3073     pCBuf b;
3074     char mbx1[64], mbx2[64];
3075     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3076                                       DSC$K_CLASS_S, mbx1},
3077                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3078                                       DSC$K_CLASS_S, mbx2};
3079     unsigned int dviitm = DVI$_DEVBUFSIZ;
3080     int j, n;
3081
3082     n = sizeof(Pipe);
3083     _ckvmssts(lib$get_vm(&n, &p));
3084
3085     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3086     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3087     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3088
3089     p->buf           = 0;
3090     p->shut_on_empty = FALSE;
3091     p->need_wake     = FALSE;
3092     p->type          = 0;
3093     p->retry         = 0;
3094     p->iosb.status   = SS$_NORMAL;
3095     p->iosb2.status  = SS$_NORMAL;
3096     p->free          = RQE_ZERO;
3097     p->wait          = RQE_ZERO;
3098     p->curr          = 0;
3099     p->curr2         = 0;
3100     p->info          = 0;
3101 #ifdef PERL_IMPLICIT_CONTEXT
3102     p->thx           = aTHX;
3103 #endif
3104
3105     n = sizeof(CBuf) + p->bufsize;
3106
3107     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3108         _ckvmssts(lib$get_vm(&n, &b));
3109         b->buf = (char *) b + sizeof(CBuf);
3110         _ckvmssts(lib$insqhi(b, &p->free));
3111     }
3112
3113     pipe_tochild2_ast(p);
3114     pipe_tochild1_ast(p);
3115     strcpy(wmbx, mbx1);
3116     strcpy(rmbx, mbx2);
3117     return p;
3118 }
3119
3120 /*  reads the MBX Perl is writing, and queues */
3121
3122 static void
3123 pipe_tochild1_ast(pPipe p)
3124 {
3125     pCBuf b = p->curr;
3126     int iss = p->iosb.status;
3127     int eof = (iss == SS$_ENDOFFILE);
3128     int sts;
3129 #ifdef PERL_IMPLICIT_CONTEXT
3130     pTHX = p->thx;
3131 #endif
3132
3133     if (p->retry) {
3134         if (eof) {
3135             p->shut_on_empty = TRUE;
3136             b->eof     = TRUE;
3137             _ckvmssts(sys$dassgn(p->chan_in));
3138         } else  {
3139             _ckvmssts(iss);
3140         }
3141
3142         b->eof  = eof;
3143         b->size = p->iosb.count;
3144         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3145         if (p->need_wake) {
3146             p->need_wake = FALSE;
3147             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3148         }
3149     } else {
3150         p->retry = 1;   /* initial call */
3151     }
3152
3153     if (eof) {                  /* flush the free queue, return when done */
3154         int n = sizeof(CBuf) + p->bufsize;
3155         while (1) {
3156             iss = lib$remqti(&p->free, &b);
3157             if (iss == LIB$_QUEWASEMP) return;
3158             _ckvmssts(iss);
3159             _ckvmssts(lib$free_vm(&n, &b));
3160         }
3161     }
3162
3163     iss = lib$remqti(&p->free, &b);
3164     if (iss == LIB$_QUEWASEMP) {
3165         int n = sizeof(CBuf) + p->bufsize;
3166         _ckvmssts(lib$get_vm(&n, &b));
3167         b->buf = (char *) b + sizeof(CBuf);
3168     } else {
3169        _ckvmssts(iss);
3170     }
3171
3172     p->curr = b;
3173     iss = sys$qio(0,p->chan_in,
3174              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3175              &p->iosb,
3176              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3177     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3178     _ckvmssts(iss);
3179 }
3180
3181
3182 /* writes queued buffers to output, waits for each to complete before
3183    doing the next */
3184
3185 static void
3186 pipe_tochild2_ast(pPipe p)
3187 {
3188     pCBuf b = p->curr2;
3189     int iss = p->iosb2.status;
3190     int n = sizeof(CBuf) + p->bufsize;
3191     int done = (p->info && p->info->done) ||
3192               iss == SS$_CANCEL || iss == SS$_ABORT;
3193 #if defined(PERL_IMPLICIT_CONTEXT)
3194     pTHX = p->thx;
3195 #endif
3196
3197     do {
3198         if (p->type) {         /* type=1 has old buffer, dispose */
3199             if (p->shut_on_empty) {
3200                 _ckvmssts(lib$free_vm(&n, &b));
3201             } else {
3202                 _ckvmssts(lib$insqhi(b, &p->free));
3203             }
3204             p->type = 0;
3205         }
3206
3207         iss = lib$remqti(&p->wait, &b);
3208         if (iss == LIB$_QUEWASEMP) {
3209             if (p->shut_on_empty) {
3210                 if (done) {
3211                     _ckvmssts(sys$dassgn(p->chan_out));
3212                     *p->pipe_done = TRUE;
3213                     _ckvmssts(sys$setef(pipe_ef));
3214                 } else {
3215                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3216                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3217                 }
3218                 return;
3219             }
3220             p->need_wake = TRUE;
3221             return;
3222         }
3223         _ckvmssts(iss);
3224         p->type = 1;
3225     } while (done);
3226
3227
3228     p->curr2 = b;
3229     if (b->eof) {
3230         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3231             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3232     } else {
3233         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3234             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3235     }
3236
3237     return;
3238
3239 }
3240
3241
3242 static pPipe
3243 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3244 {
3245     pPipe p;
3246     char mbx1[64], mbx2[64];
3247     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3248                                       DSC$K_CLASS_S, mbx1},
3249                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3250                                       DSC$K_CLASS_S, mbx2};
3251     unsigned int dviitm = DVI$_DEVBUFSIZ;
3252
3253     int n = sizeof(Pipe);
3254     _ckvmssts(lib$get_vm(&n, &p));
3255     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3256     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3257
3258     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3259     n = p->bufsize * sizeof(char);
3260     _ckvmssts(lib$get_vm(&n, &p->buf));
3261     p->shut_on_empty = FALSE;
3262     p->info   = 0;
3263     p->type   = 0;
3264     p->iosb.status = SS$_NORMAL;
3265 #if defined(PERL_IMPLICIT_CONTEXT)
3266     p->thx = aTHX;
3267 #endif
3268     pipe_infromchild_ast(p);
3269
3270     strcpy(wmbx, mbx1);
3271     strcpy(rmbx, mbx2);
3272     return p;
3273 }
3274
3275 static void
3276 pipe_infromchild_ast(pPipe p)
3277 {
3278     int iss = p->iosb.status;
3279     int eof = (iss == SS$_ENDOFFILE);
3280     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3281     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3282 #if defined(PERL_IMPLICIT_CONTEXT)
3283     pTHX = p->thx;
3284 #endif
3285
3286     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3287         _ckvmssts(sys$dassgn(p->chan_out));
3288         p->chan_out = 0;
3289     }
3290
3291     /* read completed:
3292             input shutdown if EOF from self (done or shut_on_empty)
3293             output shutdown if closing flag set (my_pclose)
3294             send data/eof from child or eof from self
3295             otherwise, re-read (snarf of data from child)
3296     */
3297
3298     if (p->type == 1) {
3299         p->type = 0;
3300         if (myeof && p->chan_in) {                  /* input shutdown */
3301             _ckvmssts(sys$dassgn(p->chan_in));
3302             p->chan_in = 0;
3303         }
3304
3305         if (p->chan_out) {
3306             if (myeof || kideof) {      /* pass EOF to parent */
3307                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3308                               pipe_infromchild_ast, p,
3309                               0, 0, 0, 0, 0, 0));
3310                 return;
3311             } else if (eof) {       /* eat EOF --- fall through to read*/
3312
3313             } else {                /* transmit data */
3314                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3315                               pipe_infromchild_ast,p,
3316                               p->buf, p->iosb.count, 0, 0, 0, 0));
3317                 return;
3318             }
3319         }
3320     }
3321
3322     /*  everything shut? flag as done */
3323
3324     if (!p->chan_in && !p->chan_out) {
3325         *p->pipe_done = TRUE;
3326         _ckvmssts(sys$setef(pipe_ef));
3327         return;
3328     }
3329
3330     /* write completed (or read, if snarfing from child)
3331             if still have input active,
3332                queue read...immediate mode if shut_on_empty so we get EOF if empty
3333             otherwise,
3334                check if Perl reading, generate EOFs as needed
3335     */
3336
3337     if (p->type == 0) {
3338         p->type = 1;
3339         if (p->chan_in) {
3340             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3341                           pipe_infromchild_ast,p,
3342                           p->buf, p->bufsize, 0, 0, 0, 0);
3343             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3344             _ckvmssts(iss);
3345         } else {           /* send EOFs for extra reads */
3346             p->iosb.status = SS$_ENDOFFILE;
3347             p->iosb.dvispec = 0;
3348             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3349                       0, 0, 0,
3350                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3351         }
3352     }
3353 }
3354
3355 static pPipe
3356 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3357 {
3358     pPipe p;
3359     char mbx[64];
3360     unsigned long dviitm = DVI$_DEVBUFSIZ;
3361     struct stat s;
3362     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3363                                       DSC$K_CLASS_S, mbx};
3364     int n = sizeof(Pipe);
3365
3366     /* things like terminals and mbx's don't need this filter */
3367     if (fd && fstat(fd,&s) == 0) {
3368         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3369         char device[65];
3370         unsigned short dev_len;
3371         struct dsc$descriptor_s d_dev;
3372         char * cptr;
3373         struct item_list_3 items[3];
3374         int status;
3375         unsigned short dvi_iosb[4];
3376
3377         cptr = getname(fd, out, 1);
3378         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3379         d_dev.dsc$a_pointer = out;
3380         d_dev.dsc$w_length = strlen(out);
3381         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3382         d_dev.dsc$b_class = DSC$K_CLASS_S;
3383
3384         items[0].len = 4;
3385         items[0].code = DVI$_DEVCHAR;
3386         items[0].bufadr = &devchar;
3387         items[0].retadr = NULL;
3388         items[1].len = 64;
3389         items[1].code = DVI$_FULLDEVNAM;
3390         items[1].bufadr = device;
3391         items[1].retadr = &dev_len;
3392         items[2].len = 0;
3393         items[2].code = 0;
3394
3395         status = sys$getdviw
3396                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3397         _ckvmssts(status);
3398         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3399             device[dev_len] = 0;
3400
3401             if (!(devchar & DEV$M_DIR)) {
3402                 strcpy(out, device);
3403                 return 0;
3404             }
3405         }
3406     }
3407
3408     _ckvmssts(lib$get_vm(&n, &p));
3409     p->fd_out = dup(fd);
3410     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3411     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3412     n = (p->bufsize+1) * sizeof(char);
3413     _ckvmssts(lib$get_vm(&n, &p->buf));
3414     p->shut_on_empty = FALSE;
3415     p->retry = 0;
3416     p->info  = 0;
3417     strcpy(out, mbx);
3418
3419     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3420                   pipe_mbxtofd_ast, p,
3421                   p->buf, p->bufsize, 0, 0, 0, 0));
3422
3423     return p;
3424 }
3425
3426 static void
3427 pipe_mbxtofd_ast(pPipe p)
3428 {
3429     int iss = p->iosb.status;
3430     int done = p->info->done;
3431     int iss2;
3432     int eof = (iss == SS$_ENDOFFILE);
3433     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3434     int err = !(iss&1) && !eof;
3435 #if defined(PERL_IMPLICIT_CONTEXT)
3436     pTHX = p->thx;
3437 #endif
3438
3439     if (done && myeof) {               /* end piping */
3440         close(p->fd_out);
3441         sys$dassgn(p->chan_in);
3442         *p->pipe_done = TRUE;
3443         _ckvmssts(sys$setef(pipe_ef));
3444         return;
3445     }
3446
3447     if (!err && !eof) {             /* good data to send to file */
3448         p->buf[p->iosb.count] = '\n';
3449         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3450         if (iss2 < 0) {
3451             p->retry++;
3452             if (p->retry < MAX_RETRY) {
3453                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3454                 return;
3455             }
3456         }
3457         p->retry = 0;
3458     } else if (err) {
3459         _ckvmssts(iss);
3460     }
3461
3462
3463     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3464           pipe_mbxtofd_ast, p,
3465           p->buf, p->bufsize, 0, 0, 0, 0);
3466     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3467     _ckvmssts(iss);
3468 }
3469
3470
3471 typedef struct _pipeloc     PLOC;
3472 typedef struct _pipeloc*   pPLOC;
3473
3474 struct _pipeloc {
3475     pPLOC   next;
3476     char    dir[NAM$C_MAXRSS+1];
3477 };
3478 static pPLOC  head_PLOC = 0;
3479
3480 void
3481 free_pipelocs(pTHX_ void *head)
3482 {
3483     pPLOC p, pnext;
3484     pPLOC *pHead = (pPLOC *)head;
3485
3486     p = *pHead;
3487     while (p) {
3488         pnext = p->next;
3489         PerlMem_free(p);
3490         p = pnext;
3491     }
3492     *pHead = 0;
3493 }
3494
3495 static void
3496 store_pipelocs(pTHX)
3497 {
3498     int    i;
3499     pPLOC  p;
3500     AV    *av = 0;
3501     SV    *dirsv;
3502     GV    *gv;
3503     char  *dir, *x;
3504     char  *unixdir;
3505     char  temp[NAM$C_MAXRSS+1];
3506     STRLEN n_a;
3507
3508     if (head_PLOC)
3509         free_pipelocs(aTHX_ &head_PLOC);
3510
3511 /*  the . directory from @INC comes last */
3512
3513     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3514     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3515     p->next = head_PLOC;
3516     head_PLOC = p;
3517     strcpy(p->dir,"./");
3518
3519 /*  get the directory from $^X */
3520
3521     unixdir = PerlMem_malloc(VMS_MAXRSS);
3522     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3523
3524 #ifdef PERL_IMPLICIT_CONTEXT
3525     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3526 #else
3527     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3528 #endif
3529         strcpy(temp, PL_origargv[0]);
3530         x = strrchr(temp,']');
3531         if (x == NULL) {
3532         x = strrchr(temp,'>');
3533           if (x == NULL) {
3534             /* It could be a UNIX path */
3535             x = strrchr(temp,'/');
3536           }
3537         }
3538         if (x)
3539           x[1] = '\0';
3540         else {
3541           /* Got a bare name, so use default directory */
3542           temp[0] = '.';
3543           temp[1] = '\0';
3544         }
3545
3546         if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3547             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3548             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3549             p->next = head_PLOC;
3550             head_PLOC = p;
3551             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3552             p->dir[NAM$C_MAXRSS] = '\0';
3553         }
3554     }
3555
3556 /*  reverse order of @INC entries, skip "." since entered above */
3557
3558 #ifdef PERL_IMPLICIT_CONTEXT
3559     if (aTHX)
3560 #endif
3561     if (PL_incgv) av = GvAVn(PL_incgv);
3562
3563     for (i = 0; av && i <= AvFILL(av); i++) {
3564         dirsv = *av_fetch(av,i,TRUE);
3565
3566         if (SvROK(dirsv)) continue;
3567         dir = SvPVx(dirsv,n_a);
3568         if (strcmp(dir,".") == 0) continue;
3569         if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3570             continue;
3571
3572         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3573         p->next = head_PLOC;
3574         head_PLOC = p;
3575         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3576         p->dir[NAM$C_MAXRSS] = '\0';
3577     }
3578
3579 /* most likely spot (ARCHLIB) put first in the list */
3580
3581 #ifdef ARCHLIB_EXP
3582     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3583         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3584         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3585         p->next = head_PLOC;
3586         head_PLOC = p;
3587         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3588         p->dir[NAM$C_MAXRSS] = '\0';
3589     }
3590 #endif
3591     PerlMem_free(unixdir);
3592 }
3593
3594 static I32
3595 Perl_cando_by_name_int
3596    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3597 #if !defined(PERL_IMPLICIT_CONTEXT)
3598 #define cando_by_name_int               Perl_cando_by_name_int
3599 #else
3600 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3601 #endif
3602
3603 static char *
3604 find_vmspipe(pTHX)
3605 {
3606     static int   vmspipe_file_status = 0;
3607     static char  vmspipe_file[NAM$C_MAXRSS+1];
3608
3609     /* already found? Check and use ... need read+execute permission */
3610
3611     if (vmspipe_file_status == 1) {
3612         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3613          && cando_by_name_int
3614            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3615             return vmspipe_file;
3616         }
3617         vmspipe_file_status = 0;
3618     }
3619
3620     /* scan through stored @INC, $^X */
3621
3622     if (vmspipe_file_status == 0) {
3623         char file[NAM$C_MAXRSS+1];
3624         pPLOC  p = head_PLOC;
3625
3626         while (p) {
3627             char * exp_res;
3628             int dirlen;
3629             strcpy(file, p->dir);
3630             dirlen = strlen(file);
3631             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3632             file[NAM$C_MAXRSS] = '\0';
3633             p = p->next;
3634
3635             exp_res = do_rmsexpand
3636                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3637             if (!exp_res) continue;
3638
3639             if (cando_by_name_int
3640                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3641              && cando_by_name_int
3642                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3643                 vmspipe_file_status = 1;
3644                 return vmspipe_file;
3645             }
3646         }
3647         vmspipe_file_status = -1;   /* failed, use tempfiles */
3648     }
3649
3650     return 0;
3651 }
3652
3653 static FILE *
3654 vmspipe_tempfile(pTHX)
3655 {
3656     char file[NAM$C_MAXRSS+1];
3657     FILE *fp;
3658     static int index = 0;
3659     Stat_t s0, s1;
3660     int cmp_result;
3661
3662     /* create a tempfile */
3663
3664     /* we can't go from   W, shr=get to  R, shr=get without
3665        an intermediate vulnerable state, so don't bother trying...
3666
3667        and lib$spawn doesn't shr=put, so have to close the write
3668
3669        So... match up the creation date/time and the FID to
3670        make sure we're dealing with the same file
3671
3672     */
3673
3674     index++;
3675     if (!decc_filename_unix_only) {
3676       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3677       fp = fopen(file,"w");
3678       if (!fp) {
3679         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3680         fp = fopen(file,"w");
3681         if (!fp) {
3682             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3683             fp = fopen(file,"w");
3684         }
3685       }
3686      }
3687      else {
3688       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3689       fp = fopen(file,"w");
3690       if (!fp) {
3691         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3692         fp = fopen(file,"w");
3693         if (!fp) {
3694           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3695           fp = fopen(file,"w");
3696         }
3697       }
3698     }
3699     if (!fp) return 0;  /* we're hosed */
3700
3701     fprintf(fp,"$! 'f$verify(0)'\n");
3702     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3703     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3704     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3705     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3706     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3707     fprintf(fp,"$ perl_del    = \"delete\"\n");
3708     fprintf(fp,"$ pif         = \"if\"\n");
3709     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3710     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3711     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3712     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3713     fprintf(fp,"$!  --- build command line to get max possible length\n");
3714     fprintf(fp,"$c=perl_popen_cmd0\n");
3715     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3716     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3717     fprintf(fp,"$x=perl_popen_cmd3\n");
3718     fprintf(fp,"$c=c+x\n");
3719     fprintf(fp,"$ perl_on\n");
3720     fprintf(fp,"$ 'c'\n");
3721     fprintf(fp,"$ perl_status = $STATUS\n");
3722     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3723     fprintf(fp,"$ perl_exit 'perl_status'\n");
3724     fsync(fileno(fp));
3725
3726     fgetname(fp, file, 1);
3727     fstat(fileno(fp), (struct stat *)&s0);
3728     fclose(fp);
3729
3730     if (decc_filename_unix_only)
3731         do_tounixspec(file, file, 0, NULL);
3732     fp = fopen(file,"r","shr=get");
3733     if (!fp) return 0;
3734     fstat(fileno(fp), (struct stat *)&s1);
3735
3736     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3737     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3738         fclose(fp);
3739         return 0;
3740     }
3741
3742     return fp;
3743 }
3744
3745
3746 #ifdef USE_VMS_DECTERM
3747
3748 static int vms_is_syscommand_xterm(void)
3749 {
3750     const static struct dsc$descriptor_s syscommand_dsc =
3751       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3752
3753     const static struct dsc$descriptor_s decwdisplay_dsc =
3754       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3755
3756     struct item_list_3 items[2];
3757     unsigned short dvi_iosb[4];
3758     unsigned long devchar;
3759     unsigned long devclass;
3760     int status;
3761
3762     /* Very simple check to guess if sys$command is a decterm? */
3763     /* First see if the DECW$DISPLAY: device exists */
3764     items[0].len = 4;
3765     items[0].code = DVI$_DEVCHAR;
3766     items[0].bufadr = &devchar;
3767     items[0].retadr = NULL;
3768     items[1].len = 0;
3769     items[1].code = 0;
3770
3771     status = sys$getdviw
3772         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3773
3774     if ($VMS_STATUS_SUCCESS(status)) {
3775         status = dvi_iosb[0];
3776     }
3777
3778     if (!$VMS_STATUS_SUCCESS(status)) {
3779         SETERRNO(EVMSERR, status);
3780         return -1;
3781     }
3782
3783     /* If it does, then for now assume that we are on a workstation */
3784     /* Now verify that SYS$COMMAND is a terminal */
3785     /* for creating the debugger DECTerm */
3786
3787     items[0].len = 4;
3788     items[0].code = DVI$_DEVCLASS;
3789     items[0].bufadr = &devclass;
3790     items[0].retadr = NULL;
3791     items[1].len = 0;
3792     items[1].code = 0;
3793
3794     status = sys$getdviw
3795         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3796
3797     if ($VMS_STATUS_SUCCESS(status)) {
3798         status = dvi_iosb[0];
3799     }
3800
3801     if (!$VMS_STATUS_SUCCESS(status)) {
3802         SETERRNO(EVMSERR, status);
3803         return -1;
3804     }
3805     else {
3806         if (devclass == DC$_TERM) {
3807             return 0;
3808         }
3809     }
3810     return -1;
3811 }
3812
3813 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3814 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3815 {
3816     int status;
3817     int ret_stat;
3818     char * ret_char;
3819     char device_name[65];
3820     unsigned short device_name_len;
3821     struct dsc$descriptor_s customization_dsc;
3822     struct dsc$descriptor_s device_name_dsc;
3823     const char * cptr;
3824     char * tptr;
3825     char customization[200];
3826     char title[40];
3827     pInfo info = NULL;
3828     char mbx1[64];
3829     unsigned short p_chan;
3830     int n;
3831     unsigned short iosb[4];
3832     struct item_list_3 items[2];
3833     const char * cust_str =
3834         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3835     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3836                                           DSC$K_CLASS_S, mbx1};
3837
3838     ret_char = strstr(cmd," xterm ");
3839     if (ret_char == NULL)
3840         return NULL;
3841     cptr = ret_char + 7;
3842     ret_char = strstr(cmd,"tty");
3843     if (ret_char == NULL)
3844         return NULL;
3845     ret_char = strstr(cmd,"sleep");
3846     if (ret_char == NULL)
3847         return NULL;
3848
3849     /* Are we on a workstation? */
3850     /* to do: capture the rows / columns and pass their properties */
3851     ret_stat = vms_is_syscommand_xterm();
3852     if (ret_stat < 0)
3853         return NULL;
3854
3855     /* Make the title: */
3856     ret_char = strstr(cptr,"-title");
3857     if (ret_char != NULL) {
3858         while ((*cptr != 0) && (*cptr != '\"')) {
3859             cptr++;
3860         }
3861         if (*cptr == '\"')
3862             cptr++;
3863         n = 0;
3864         while ((*cptr != 0) && (*cptr != '\"')) {
3865             title[n] = *cptr;
3866             n++;
3867             if (n == 39) {
3868                 title[39] == 0;
3869                 break;
3870             }
3871             cptr++;
3872         }
3873         title[n] = 0;
3874     }
3875     else {
3876             /* Default title */
3877             strcpy(title,"Perl Debug DECTerm");
3878     }
3879     sprintf(customization, cust_str, title);
3880
3881     customization_dsc.dsc$a_pointer = customization;
3882     customization_dsc.dsc$w_length = strlen(customization);
3883     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3884     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3885
3886     device_name_dsc.dsc$a_pointer = device_name;
3887     device_name_dsc.dsc$w_length = sizeof device_name -1;
3888     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3889     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3890
3891     device_name_len = 0;
3892
3893     /* Try to create the window */
3894      status = decw$term_port
3895        (NULL,
3896         NULL,
3897         &customization_dsc,
3898         &device_name_dsc,
3899         &device_name_len,
3900         NULL,
3901         NULL,
3902         NULL);
3903     if (!$VMS_STATUS_SUCCESS(status)) {
3904         SETERRNO(EVMSERR, status);
3905         return NULL;
3906     }
3907
3908     device_name[device_name_len] = '\0';
3909
3910     /* Need to set this up to look like a pipe for cleanup */
3911     n = sizeof(Info);
3912     status = lib$get_vm(&n, &info);
3913     if (!$VMS_STATUS_SUCCESS(status)) {
3914         SETERRNO(ENOMEM, status);
3915         return NULL;
3916     }
3917
3918     info->mode = *mode;
3919     info->done = FALSE;
3920     info->completion = 0;
3921     info->closing    = FALSE;
3922     info->in         = 0;
3923     info->out        = 0;
3924     info->err        = 0;
3925     info->fp         = Nullfp;
3926     info->useFILE    = 0;
3927     info->waiting    = 0;
3928     info->in_done    = TRUE;
3929     info->out_done   = TRUE;
3930     info->err_done   = TRUE;
3931
3932     /* Assign a channel on this so that it will persist, and not login */
3933     /* We stash this channel in the info structure for reference. */
3934     /* The created xterm self destructs when the last channel is removed */
3935     /* and it appears that perl5db.pl (perl debugger) does this routinely */
3936     /* So leave this assigned. */
3937     device_name_dsc.dsc$w_length = device_name_len;
3938     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
3939     if (!$VMS_STATUS_SUCCESS(status)) {
3940         SETERRNO(EVMSERR, status);
3941         return NULL;
3942     }
3943     info->xchan_valid = 1;
3944
3945     /* Now create a mailbox to be read by the application */
3946
3947     create_mbx(aTHX_ &p_chan, &d_mbx1);
3948
3949     /* write the name of the created terminal to the mailbox */
3950     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
3951             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
3952
3953     if (!$VMS_STATUS_SUCCESS(status)) {
3954         SETERRNO(EVMSERR, status);
3955         return NULL;
3956     }
3957
3958     info->fp  = PerlIO_open(mbx1, mode);
3959
3960     /* Done with this channel */
3961     sys$dassgn(p_chan);
3962
3963     /* If any errors, then clean up */
3964     if (!info->fp) {
3965         n = sizeof(Info);
3966         _ckvmssts(lib$free_vm(&n, &info));
3967         return NULL;
3968         }
3969
3970     /* All done */
3971     return info->fp;
3972 }
3973 #endif
3974
3975 static PerlIO *
3976 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3977 {
3978     static int handler_set_up = FALSE;
3979     unsigned long int sts, flags = CLI$M_NOWAIT;
3980     /* The use of a GLOBAL table (as was done previously) rendered
3981      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3982      * environment.  Hence we've switched to LOCAL symbol table.
3983      */
3984     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3985     int j, wait = 0, n;
3986     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3987     char *in, *out, *err, mbx[512];
3988     FILE *tpipe = 0;
3989     char tfilebuf[NAM$C_MAXRSS+1];
3990     pInfo info = NULL;
3991     char cmd_sym_name[20];
3992     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3993                                       DSC$K_CLASS_S, symbol};
3994     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3995                                       DSC$K_CLASS_S, 0};
3996     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3997                                       DSC$K_CLASS_S, cmd_sym_name};
3998     struct dsc$descriptor_s *vmscmd;
3999     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4000     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4001     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4002
4003 #ifdef USE_VMS_DECTERM
4004     /* Check here for Xterm create request.  This means looking for
4005      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4006      *  is possible to create an xterm.
4007      */
4008     if (*in_mode == 'r') {
4009         PerlIO * xterm_fd;
4010
4011         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4012         if (xterm_fd != Nullfp)
4013             return xterm_fd;
4014     }
4015 #endif
4016
4017     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4018
4019     /* once-per-program initialization...
4020        note that the SETAST calls and the dual test of pipe_ef
4021        makes sure that only the FIRST thread through here does
4022        the initialization...all other threads wait until it's
4023        done.
4024
4025        Yeah, uglier than a pthread call, it's got all the stuff inline
4026        rather than in a separate routine.
4027     */
4028
4029     if (!pipe_ef) {
4030         _ckvmssts(sys$setast(0));
4031         if (!pipe_ef) {
4032             unsigned long int pidcode = JPI$_PID;
4033             $DESCRIPTOR(d_delay, RETRY_DELAY);
4034             _ckvmssts(lib$get_ef(&pipe_ef));
4035             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4036             _ckvmssts(sys$bintim(&d_delay, delaytime));
4037         }
4038         if (!handler_set_up) {
4039           _ckvmssts(sys$dclexh(&pipe_exitblock));
4040           handler_set_up = TRUE;
4041         }
4042         _ckvmssts(sys$setast(1));
4043     }
4044
4045     /* see if we can find a VMSPIPE.COM */
4046
4047     tfilebuf[0] = '@';
4048     vmspipe = find_vmspipe(aTHX);
4049     if (vmspipe) {
4050         strcpy(tfilebuf+1,vmspipe);
4051     } else {        /* uh, oh...we're in tempfile hell */
4052         tpipe = vmspipe_tempfile(aTHX);
4053         if (!tpipe) {       /* a fish popular in Boston */
4054             if (ckWARN(WARN_PIPE)) {
4055                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4056             }
4057         return Nullfp;
4058         }
4059         fgetname(tpipe,tfilebuf+1,1);
4060     }
4061     vmspipedsc.dsc$a_pointer = tfilebuf;
4062     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4063
4064     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4065     if (!(sts & 1)) {
4066       switch (sts) {
4067         case RMS$_FNF:  case RMS$_DNF:
4068           set_errno(ENOENT); break;
4069         case RMS$_DIR:
4070           set_errno(ENOTDIR); break;
4071         case RMS$_DEV:
4072           set_errno(ENODEV); break;
4073         case RMS$_PRV:
4074           set_errno(EACCES); break;
4075         case RMS$_SYN:
4076           set_errno(EINVAL); break;
4077         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4078           set_errno(E2BIG); break;
4079         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4080           _ckvmssts(sts); /* fall through */
4081         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4082           set_errno(EVMSERR);
4083       }
4084       set_vaxc_errno(sts);
4085       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4086         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4087       }
4088       *psts = sts;
4089       return Nullfp;
4090     }
4091     n = sizeof(Info);
4092     _ckvmssts(lib$get_vm(&n, &info));
4093
4094     strcpy(mode,in_mode);
4095     info->mode = *mode;
4096     info->done = FALSE;
4097     info->completion = 0;
4098     info->closing    = FALSE;
4099     info->in         = 0;
4100     info->out        = 0;
4101     info->err        = 0;
4102     info->fp         = Nullfp;
4103     info->useFILE    = 0;
4104     info->waiting    = 0;
4105     info->in_done    = TRUE;
4106     info->out_done   = TRUE;
4107     info->err_done   = TRUE;
4108     info->xchan      = 0;
4109     info->xchan_valid = 0;
4110
4111     in = PerlMem_malloc(VMS_MAXRSS);
4112     if (in == NULL) _ckvmssts(SS$_INSFMEM);
4113     out = PerlMem_malloc(VMS_MAXRSS);
4114     if (out == NULL) _ckvmssts(SS$_INSFMEM);
4115     err = PerlMem_malloc(VMS_MAXRSS);
4116     if (err == NULL) _ckvmssts(SS$_INSFMEM);
4117
4118     in[0] = out[0] = err[0] = '\0';
4119
4120     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4121         info->useFILE = 1;
4122         strcpy(p,p+1);
4123     }
4124     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4125         wait = 1;
4126         strcpy(p,p+1);
4127     }
4128
4129     if (*mode == 'r') {             /* piping from subroutine */
4130
4131         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4132         if (info->out) {
4133             info->out->pipe_done = &info->out_done;
4134             info->out_done = FALSE;
4135             info->out->info = info;
4136         }
4137         if (!info->useFILE) {
4138             info->fp  = PerlIO_open(mbx, mode);
4139         } else {
4140             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4141             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4142         }
4143
4144         if (!info->fp && info->out) {
4145             sys$cancel(info->out->chan_out);
4146
4147             while (!info->out_done) {
4148                 int done;
4149                 _ckvmssts(sys$setast(0));
4150                 done = info->out_done;
4151                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4152                 _ckvmssts(sys$setast(1));
4153                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4154             }
4155
4156             if (info->out->buf) {
4157                 n = info->out->bufsize * sizeof(char);
4158                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4159             }
4160             n = sizeof(Pipe);
4161             _ckvmssts(lib$free_vm(&n, &info->out));
4162             n = sizeof(Info);
4163             _ckvmssts(lib$free_vm(&n, &info));
4164             *psts = RMS$_FNF;
4165             return Nullfp;
4166         }
4167
4168         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4169         if (info->err) {
4170             info->err->pipe_done = &info->err_done;
4171             info->err_done = FALSE;
4172             info->err->info = info;
4173         }
4174
4175     } else if (*mode == 'w') {      /* piping to subroutine */
4176
4177         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4178         if (info->out) {
4179             info->out->pipe_done = &info->out_done;
4180             info->out_done = FALSE;
4181             info->out->info = info;
4182         }
4183
4184         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4185         if (info->err) {
4186             info->err->pipe_done = &info->err_done;
4187             info->err_done = FALSE;
4188             info->err->info = info;
4189         }
4190
4191         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4192         if (!info->useFILE) {
4193             info->fp  = PerlIO_open(mbx, mode);
4194         } else {
4195             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4196             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4197         }
4198
4199         if (info->in) {
4200             info->in->pipe_done = &info->in_done;
4201             info->in_done = FALSE;
4202             info->in->info = info;
4203         }
4204
4205         /* error cleanup */
4206         if (!info->fp && info->in) {
4207             info->done = TRUE;
4208             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4209                               0, 0, 0, 0, 0, 0, 0, 0));
4210
4211             while (!info->in_done) {
4212                 int done;
4213                 _ckvmssts(sys$setast(0));
4214                 done = info->in_done;
4215                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4216                 _ckvmssts(sys$setast(1));
4217                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4218             }
4219
4220             if (info->in->buf) {
4221                 n = info->in->bufsize * sizeof(char);
4222                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4223             }
4224             n = sizeof(Pipe);
4225             _ckvmssts(lib$free_vm(&n, &info->in));
4226             n = sizeof(Info);
4227             _ckvmssts(lib$free_vm(&n, &info));
4228             *psts = RMS$_FNF;
4229             return Nullfp;
4230         }
4231
4232
4233     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4234         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4235         if (info->out) {
4236             info->out->pipe_done = &info->out_done;
4237             info->out_done = FALSE;
4238             info->out->info = info;
4239         }
4240
4241         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4242         if (info->err) {
4243             info->err->pipe_done = &info->err_done;
4244             info->err_done = FALSE;
4245             info->err->info = info;
4246         }
4247     }
4248
4249     symbol[MAX_DCL_SYMBOL] = '\0';
4250
4251     strncpy(symbol, in, MAX_DCL_SYMBOL);
4252     d_symbol.dsc$w_length = strlen(symbol);
4253     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4254
4255     strncpy(symbol, err, MAX_DCL_SYMBOL);
4256     d_symbol.dsc$w_length = strlen(symbol);
4257     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4258
4259     strncpy(symbol, out, MAX_DCL_SYMBOL);
4260     d_symbol.dsc$w_length = strlen(symbol);
4261     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4262
4263     /* Done with the names for the pipes */
4264     PerlMem_free(err);
4265     PerlMem_free(out);
4266     PerlMem_free(in);
4267
4268     p = vmscmd->dsc$a_pointer;
4269     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4270     if (*p == '$') p++;                         /* remove leading $ */
4271     while (*p == ' ' || *p == '\t') p++;
4272
4273     for (j = 0; j < 4; j++) {
4274         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4275         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4276
4277     strncpy(symbol, p, MAX_DCL_SYMBOL);
4278     d_symbol.dsc$w_length = strlen(symbol);
4279     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4280
4281         if (strlen(p) > MAX_DCL_SYMBOL) {
4282             p += MAX_DCL_SYMBOL;
4283         } else {
4284             p += strlen(p);
4285         }
4286     }
4287     _ckvmssts(sys$setast(0));
4288     info->next=open_pipes;  /* prepend to list */
4289     open_pipes=info;
4290     _ckvmssts(sys$setast(1));
4291     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4292      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4293      * have SYS$COMMAND if we need it.
4294      */
4295     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4296                       0, &info->pid, &info->completion,
4297                       0, popen_completion_ast,info,0,0,0));
4298
4299     /* if we were using a tempfile, close it now */
4300
4301     if (tpipe) fclose(tpipe);
4302
4303     /* once the subprocess is spawned, it has copied the symbols and
4304        we can get rid of ours */
4305
4306     for (j = 0; j < 4; j++) {
4307         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4308         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4309     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4310     }
4311     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4312     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4313     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4314     vms_execfree(vmscmd);
4315
4316 #ifdef PERL_IMPLICIT_CONTEXT
4317     if (aTHX)
4318 #endif
4319     PL_forkprocess = info->pid;
4320
4321     if (wait) {
4322          int done = 0;
4323          while (!done) {
4324              _ckvmssts(sys$setast(0));
4325              done = info->done;
4326              if (!done) _ckvmssts(sys$clref(pipe_ef));
4327              _ckvmssts(sys$setast(1));
4328              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4329          }
4330         *psts = info->completion;
4331 /* Caller thinks it is open and tries to close it. */
4332 /* This causes some problems, as it changes the error status */
4333 /*        my_pclose(info->fp); */
4334     } else {
4335         *psts = SS$_NORMAL;
4336     }
4337     return info->fp;
4338 }  /* end of safe_popen */
4339
4340
4341 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4342 PerlIO *
4343 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4344 {
4345     int sts;
4346     TAINT_ENV();
4347     TAINT_PROPER("popen");
4348     PERL_FLUSHALL_FOR_CHILD;
4349     return safe_popen(aTHX_ cmd,mode,&sts);
4350 }
4351
4352 /*}}}*/
4353
4354 /*{{{  I32 my_pclose(PerlIO *fp)*/
4355 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4356 {
4357     pInfo info, last = NULL;
4358     unsigned long int retsts;
4359     int done, iss, n;
4360     int status;
4361
4362     for (info = open_pipes; info != NULL; last = info, info = info->next)
4363         if (info->fp == fp) break;
4364
4365     if (info == NULL) {  /* no such pipe open */
4366       set_errno(ECHILD); /* quoth POSIX */
4367       set_vaxc_errno(SS$_NONEXPR);
4368       return -1;
4369     }
4370
4371     /* If we were writing to a subprocess, insure that someone reading from
4372      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4373      * produce an EOF record in the mailbox.
4374      *
4375      *  well, at least sometimes it *does*, so we have to watch out for
4376      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4377      */
4378      if (info->fp) {
4379         if (!info->useFILE)
4380             PerlIO_flush(info->fp);   /* first, flush data */
4381         else
4382             fflush((FILE *)info->fp);
4383     }
4384
4385     _ckvmssts(sys$setast(0));
4386      info->closing = TRUE;
4387      done = info->done && info->in_done && info->out_done && info->err_done;
4388      /* hanging on write to Perl's input? cancel it */
4389      if (info->mode == 'r' && info->out && !info->out_done) {
4390         if (info->out->chan_out) {
4391             _ckvmssts(sys$cancel(info->out->chan_out));
4392             if (!info->out->chan_in) {   /* EOF generation, need AST */
4393                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4394             }
4395         }
4396      }
4397      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4398          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4399                            0, 0, 0, 0, 0, 0));
4400     _ckvmssts(sys$setast(1));
4401     if (info->fp) {
4402      if (!info->useFILE)
4403         PerlIO_close(info->fp);
4404      else
4405         fclose((FILE *)info->fp);
4406     }
4407      /*
4408         we have to wait until subprocess completes, but ALSO wait until all
4409         the i/o completes...otherwise we'll be freeing the "info" structure
4410         that the i/o ASTs could still be using...
4411      */
4412
4413      while (!done) {
4414          _ckvmssts(sys$setast(0));
4415          done = info->done && info->in_done && info->out_done && info->err_done;
4416          if (!done) _ckvmssts(sys$clref(pipe_ef));
4417          _ckvmssts(sys$setast(1));
4418          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4419      }
4420      retsts = info->completion;
4421
4422     /* remove from list of open pipes */
4423     _ckvmssts(sys$setast(0));
4424     if (last) last->next = info->next;
4425     else open_pipes = info->next;
4426     _ckvmssts(sys$setast(1));
4427
4428     /* free buffers and structures */
4429
4430     if (info->in) {
4431         if (info->in->buf) {
4432             n = info->in->bufsize * sizeof(char);
4433             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4434         }
4435         n = sizeof(Pipe);
4436         _ckvmssts(lib$free_vm(&n, &info->in));
4437     }
4438     if (info->out) {
4439         if (info->out->buf) {
4440             n = info->out->bufsize * sizeof(char);
4441             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4442         }
4443         n = sizeof(Pipe);
4444         _ckvmssts(lib$free_vm(&n, &info->out));
4445     }
4446     if (info->err) {
4447         if (info->err->buf) {
4448             n = info->err->bufsize * sizeof(char);
4449             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4450         }
4451         n = sizeof(Pipe);
4452         _ckvmssts(lib$free_vm(&n, &info->err));
4453     }
4454     n = sizeof(Info);
4455     _ckvmssts(lib$free_vm(&n, &info));
4456
4457     return retsts;
4458
4459 }  /* end of my_pclose() */
4460
4461 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4462   /* Roll our own prototype because we want this regardless of whether
4463    * _VMS_WAIT is defined.
4464    */
4465   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4466 #endif
4467 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4468    created with popen(); otherwise partially emulate waitpid() unless
4469    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4470    Also check processes not considered by the CRTL waitpid().
4471  */
4472 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4473 Pid_t
4474 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4475 {
4476     pInfo info;
4477     int done;
4478     int sts;
4479     int j;
4480
4481     if (statusp) *statusp = 0;
4482
4483     for (info = open_pipes; info != NULL; info = info->next)
4484         if (info->pid == pid) break;
4485
4486     if (info != NULL) {  /* we know about this child */
4487       while (!info->done) {
4488           _ckvmssts(sys$setast(0));
4489           done = info->done;
4490           if (!done) _ckvmssts(sys$clref(pipe_ef));
4491           _ckvmssts(sys$setast(1));
4492           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4493       }
4494
4495       if (statusp) *statusp = info->completion;
4496       return pid;
4497     }
4498
4499     /* child that already terminated? */
4500
4501     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4502         if (closed_list[j].pid == pid) {
4503             if (statusp) *statusp = closed_list[j].completion;
4504             return pid;
4505         }
4506     }
4507
4508     /* fall through if this child is not one of our own pipe children */
4509
4510 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4511
4512       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4513        * in 7.2 did we get a version that fills in the VMS completion
4514        * status as Perl has always tried to do.
4515        */
4516
4517       sts = __vms_waitpid( pid, statusp, flags );
4518
4519       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4520          return sts;
4521
4522       /* If the real waitpid tells us the child does not exist, we
4523        * fall through here to implement waiting for a child that
4524        * was created by some means other than exec() (say, spawned
4525        * from DCL) or to wait for a process that is not a subprocess
4526        * of the current process.
4527        */
4528
4529 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4530
4531     {
4532       $DESCRIPTOR(intdsc,"0 00:00:01");
4533       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4534       unsigned long int pidcode = JPI$_PID, mypid;
4535       unsigned long int interval[2];
4536       unsigned int jpi_iosb[2];
4537       struct itmlst_3 jpilist[2] = {
4538           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4539           {                      0,         0,                 0, 0}
4540       };
4541
4542       if (pid <= 0) {
4543         /* Sorry folks, we don't presently implement rooting around for
4544            the first child we can find, and we definitely don't want to
4545            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4546          */
4547         set_errno(ENOTSUP);
4548         return -1;
4549       }
4550
4551       /* Get the owner of the child so I can warn if it's not mine. If the
4552        * process doesn't exist or I don't have the privs to look at it,
4553        * I can go home early.
4554        */
4555       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4556       if (sts & 1) sts = jpi_iosb[0];
4557       if (!(sts & 1)) {
4558         switch (sts) {
4559             case SS$_NONEXPR:
4560                 set_errno(ECHILD);
4561                 break;
4562             case SS$_NOPRIV:
4563                 set_errno(EACCES);
4564                 break;
4565             default:
4566                 _ckvmssts(sts);
4567         }
4568         set_vaxc_errno(sts);
4569         return -1;
4570       }
4571
4572       if (ckWARN(WARN_EXEC)) {
4573         /* remind folks they are asking for non-standard waitpid behavior */
4574         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4575         if (ownerpid != mypid)
4576           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4577                       "waitpid: process %x is not a child of process %x",
4578                       pid,mypid);
4579       }
4580
4581       /* simply check on it once a second until it's not there anymore. */
4582
4583       _ckvmssts(sys$bintim(&intdsc,interval));
4584       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4585             _ckvmssts(sys$schdwk(0,0,interval,0));
4586             _ckvmssts(sys$hiber());
4587       }
4588       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4589
4590       _ckvmssts(sts);
4591       return pid;
4592     }
4593 }  /* end of waitpid() */
4594 /*}}}*/
4595 /*}}}*/
4596 /*}}}*/
4597
4598 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4599 char *
4600 my_gconvert(double val, int ndig, int trail, char *buf)
4601 {
4602   static char __gcvtbuf[DBL_DIG+1];
4603   char *loc;
4604
4605   loc = buf ? buf : __gcvtbuf;
4606
4607 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4608   if (val < 1) {
4609     sprintf(loc,"%.*g",ndig,val);
4610     return loc;
4611   }
4612 #endif
4613
4614   if (val) {
4615     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4616     return gcvt(val,ndig,loc);
4617   }
4618   else {
4619     loc[0] = '0'; loc[1] = '\0';
4620     return loc;
4621   }
4622
4623 }
4624 /*}}}*/
4625
4626 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4627 static int rms_free_search_context(struct FAB * fab)
4628 {
4629 struct NAM * nam;
4630
4631     nam = fab->fab$l_nam;
4632     nam->nam$b_nop |= NAM$M_SYNCHK;
4633     nam->nam$l_rlf = NULL;
4634     fab->fab$b_dns = 0;
4635     return sys$parse(fab, NULL, NULL);
4636 }
4637
4638 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4639 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4640 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4641 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4642 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4643 #define rms_nam_esll(nam) nam.nam$b_esl
4644 #define rms_nam_esl(nam) nam.nam$b_esl
4645 #define rms_nam_name(nam) nam.nam$l_name
4646 #define rms_nam_namel(nam) nam.nam$l_name
4647 #define rms_nam_type(nam) nam.nam$l_type
4648 #define rms_nam_typel(nam) nam.nam$l_type
4649 #define rms_nam_ver(nam) nam.nam$l_ver
4650 #define rms_nam_verl(nam) nam.nam$l_ver
4651 #define rms_nam_rsll(nam) nam.nam$b_rsl
4652 #define rms_nam_rsl(nam) nam.nam$b_rsl
4653 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4654 #define rms_set_fna(fab, nam, name, size) \
4655         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4656 #define rms_get_fna(fab, nam) fab.fab$l_fna
4657 #define rms_set_dna(fab, nam, name, size) \
4658         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4659 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4660 #define rms_set_esa(fab, nam, name, size) \
4661         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4662 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4663         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4664 #define rms_set_rsa(nam, name, size) \
4665         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4666 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4667         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4668 #define rms_nam_name_type_l_size(nam) \
4669         (nam.nam$b_name + nam.nam$b_type)
4670 #else
4671 static int rms_free_search_context(struct FAB * fab)
4672 {
4673 struct NAML * nam;
4674
4675     nam = fab->fab$l_naml;
4676     nam->naml$b_nop |= NAM$M_SYNCHK;
4677     nam->naml$l_rlf = NULL;
4678     nam->naml$l_long_defname_size = 0;
4679
4680     fab->fab$b_dns = 0;
4681     return sys$parse(fab, NULL, NULL);
4682 }
4683
4684 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4685 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4686 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4687 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4688 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4689 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4690 #define rms_nam_esl(nam) nam.naml$b_esl
4691 #define rms_nam_name(nam) nam.naml$l_name
4692 #define rms_nam_namel(nam) nam.naml$l_long_name
4693 #define rms_nam_type(nam) nam.naml$l_type
4694 #define rms_nam_typel(nam) nam.naml$l_long_type
4695 #define rms_nam_ver(nam) nam.naml$l_ver
4696 #define rms_nam_verl(nam) nam.naml$l_long_ver
4697 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4698 #define rms_nam_rsl(nam) nam.naml$b_rsl
4699 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4700 #define rms_set_fna(fab, nam, name, size) \
4701         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4702         nam.naml$l_long_filename_size = size; \
4703         nam.naml$l_long_filename = name;}
4704 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4705 #define rms_set_dna(fab, nam, name, size) \
4706         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4707         nam.naml$l_long_defname_size = size; \
4708         nam.naml$l_long_defname = name; }
4709 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4710 #define rms_set_esa(fab, nam, name, size) \
4711         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4712         nam.naml$l_long_expand_alloc = size; \
4713         nam.naml$l_long_expand = name; }
4714 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4715         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4716         nam.naml$l_long_expand = l_name; \
4717         nam.naml$l_long_expand_alloc = l_size; }
4718 #define rms_set_rsa(nam, name, size) \
4719         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4720         nam.naml$l_long_result = name; \
4721         nam.naml$l_long_result_alloc = size; }
4722 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4723         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4724         nam.naml$l_long_result = l_name; \
4725         nam.naml$l_long_result_alloc = l_size; }
4726 #define rms_nam_name_type_l_size(nam) \
4727         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4728 #endif
4729
4730
4731 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4732 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4733  * to expand file specification.  Allows for a single default file
4734  * specification and a simple mask of options.  If outbuf is non-NULL,
4735  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4736  * the resultant file specification is placed.  If outbuf is NULL, the
4737  * resultant file specification is placed into a static buffer.
4738  * The third argument, if non-NULL, is taken to be a default file
4739  * specification string.  The fourth argument is unused at present.
4740  * rmesexpand() returns the address of the resultant string if
4741  * successful, and NULL on error.
4742  *
4743  * New functionality for previously unused opts value:
4744  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4745  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
4746  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4747  */
4748 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4749
4750 static char *
4751 mp_do_rmsexpand
4752    (pTHX_ const char *filespec,
4753     char *outbuf,
4754     int ts,
4755     const char *defspec,
4756     unsigned opts,
4757     int * fs_utf8,
4758     int * dfs_utf8)
4759 {
4760   static char __rmsexpand_retbuf[VMS_MAXRSS];
4761   char * vmsfspec, *tmpfspec;
4762   char * esa, *cp, *out = NULL;
4763   char * tbuf;
4764   char * esal;
4765   char * outbufl;
4766   struct FAB myfab = cc$rms_fab;
4767   rms_setup_nam(mynam);
4768   STRLEN speclen;
4769   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4770   int sts;
4771
4772   /* temp hack until UTF8 is actually implemented */
4773   if (fs_utf8 != NULL)
4774     *fs_utf8 = 0;
4775
4776   if (!filespec || !*filespec) {
4777     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4778     return NULL;
4779   }
4780   if (!outbuf) {
4781     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4782     else    outbuf = __rmsexpand_retbuf;
4783   }
4784
4785   vmsfspec = NULL;
4786   tmpfspec = NULL;
4787   outbufl = NULL;
4788
4789   isunix = 0;
4790   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4791     isunix = is_unix_filespec(filespec);
4792     if (isunix) {
4793       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4794       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4795       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4796         PerlMem_free(vmsfspec);
4797         if (out)
4798            Safefree(out);
4799         return NULL;
4800       }
4801       filespec = vmsfspec;
4802
4803       /* Unless we are forcing to VMS format, a UNIX input means
4804        * UNIX output, and that requires long names to be used
4805        */
4806       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4807         opts |= PERL_RMSEXPAND_M_LONG;
4808       else {
4809         isunix = 0;
4810       }
4811     }
4812   }
4813
4814   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4815   rms_bind_fab_nam(myfab, mynam);
4816
4817   if (defspec && *defspec) {
4818     int t_isunix;
4819     t_isunix = is_unix_filespec(defspec);
4820     if (t_isunix) {
4821       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4822       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4823       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4824         PerlMem_free(tmpfspec);
4825         if (vmsfspec != NULL)
4826             PerlMem_free(vmsfspec);
4827         if (out)
4828            Safefree(out);
4829         return NULL;
4830       }
4831       defspec = tmpfspec;
4832     }
4833     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4834   }
4835
4836   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4837   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4838 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4839   esal = PerlMem_malloc(VMS_MAXRSS);
4840   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4841 #endif
4842   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4843
4844   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4845     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4846   }
4847   else {
4848 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4849     outbufl = PerlMem_malloc(VMS_MAXRSS);
4850     if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4851     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4852 #else
4853     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4854 #endif
4855   }
4856
4857 #ifdef NAM$M_NO_SHORT_UPCASE
4858   if (decc_efs_case_preserve)
4859     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4860 #endif
4861
4862   /* First attempt to parse as an existing file */
4863   retsts = sys$parse(&myfab,0,0);
4864   if (!(retsts & STS$K_SUCCESS)) {
4865
4866     /* Could not find the file, try as syntax only if error is not fatal */
4867     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4868     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4869       retsts = sys$parse(&myfab,0,0);
4870       if (retsts & STS$K_SUCCESS) goto expanded;
4871     }
4872
4873      /* Still could not parse the file specification */
4874     /*----------------------------------------------*/
4875     sts = rms_free_search_context(&myfab); /* Free search context */
4876     if (out) Safefree(out);
4877     if (tmpfspec != NULL)
4878         PerlMem_free(tmpfspec);
4879     if (vmsfspec != NULL)
4880         PerlMem_free(vmsfspec);
4881     if (outbufl != NULL)
4882         PerlMem_free(outbufl);
4883     PerlMem_free(esa);
4884     PerlMem_free(esal);
4885     set_vaxc_errno(retsts);
4886     if      (retsts == RMS$_PRV) set_errno(EACCES);
4887     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4888     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4889     else                         set_errno(EVMSERR);
4890     return NULL;
4891   }
4892   retsts = sys$search(&myfab,0,0);
4893   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4894     sts = rms_free_search_context(&myfab); /* Free search context */
4895     if (out) Safefree(out);
4896     if (tmpfspec != NULL)
4897         PerlMem_free(tmpfspec);
4898     if (vmsfspec != NULL)
4899         PerlMem_free(vmsfspec);
4900     if (outbufl != NULL)
4901         PerlMem_free(outbufl);
4902     PerlMem_free(esa);
4903     PerlMem_free(esal);
4904     set_vaxc_errno(retsts);
4905     if      (retsts == RMS$_PRV) set_errno(EACCES);
4906     else                         set_errno(EVMSERR);
4907     return NULL;
4908   }
4909
4910   /* If the input filespec contained any lowercase characters,
4911    * downcase the result for compatibility with Unix-minded code. */
4912   expanded:
4913   if (!decc_efs_case_preserve) {
4914     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4915       if (islower(*tbuf)) { haslower = 1; break; }
4916   }
4917
4918    /* Is a long or a short name expected */
4919   /*------------------------------------*/
4920   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4921     if (rms_nam_rsll(mynam)) {
4922         tbuf = outbuf;
4923         speclen = rms_nam_rsll(mynam);
4924     }
4925     else {
4926         tbuf = esal; /* Not esa */
4927         speclen = rms_nam_esll(mynam);
4928     }
4929   }
4930   else {
4931     if (rms_nam_rsl(mynam)) {
4932         tbuf = outbuf;
4933         speclen = rms_nam_rsl(mynam);
4934     }
4935     else {
4936         tbuf = esa; /* Not esal */
4937         speclen = rms_nam_esl(mynam);
4938     }
4939   }
4940   tbuf[speclen] = '\0';
4941
4942   /* Trim off null fields added by $PARSE
4943    * If type > 1 char, must have been specified in original or default spec
4944    * (not true for version; $SEARCH may have added version of existing file).
4945    */
4946   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4947   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4948     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4949              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4950   }
4951   else {
4952     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4953              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4954   }
4955   if (trimver || trimtype) {
4956     if (defspec && *defspec) {
4957       char *defesal = NULL;
4958       defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4959       if (defesal != NULL) {
4960         struct FAB deffab = cc$rms_fab;
4961         rms_setup_nam(defnam);
4962
4963         rms_bind_fab_nam(deffab, defnam);
4964
4965         /* Cast ok */
4966         rms_set_fna
4967             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4968
4969         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4970
4971         rms_clear_nam_nop(defnam);
4972         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4973 #ifdef NAM$M_NO_SHORT_UPCASE
4974         if (decc_efs_case_preserve)
4975           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4976 #endif
4977         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4978           if (trimver) {
4979              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4980           }
4981           if (trimtype) {
4982             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4983           }
4984         }
4985         PerlMem_free(defesal);
4986       }
4987     }
4988     if (trimver) {
4989       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4990         if (*(rms_nam_verl(mynam)) != '\"')
4991           speclen = rms_nam_verl(mynam) - tbuf;
4992       }
4993       else {
4994         if (*(rms_nam_ver(mynam)) != '\"')
4995           speclen = rms_nam_ver(mynam) - tbuf;
4996       }
4997     }
4998     if (trimtype) {
4999       /* If we didn't already trim version, copy down */
5000       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5001         if (speclen > rms_nam_verl(mynam) - tbuf)
5002           memmove
5003            (rms_nam_typel(mynam),
5004             rms_nam_verl(mynam),
5005             speclen - (rms_nam_verl(mynam) - tbuf));
5006           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5007       }
5008       else {
5009         if (speclen > rms_nam_ver(mynam) - tbuf)
5010           memmove
5011            (rms_nam_type(mynam),
5012             rms_nam_ver(mynam),
5013             speclen - (rms_nam_ver(mynam) - tbuf));
5014           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5015       }
5016     }
5017   }
5018
5019    /* Done with these copies of the input files */
5020   /*-------------------------------------------*/
5021   if (vmsfspec != NULL)
5022         PerlMem_free(vmsfspec);
5023   if (tmpfspec != NULL)
5024         PerlMem_free(tmpfspec);
5025
5026   /* If we just had a directory spec on input, $PARSE "helpfully"
5027    * adds an empty name and type for us */
5028   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5029     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5030         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5031         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5032       speclen = rms_nam_namel(mynam) - tbuf;
5033   }
5034   else {
5035     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5036         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5037         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5038       speclen = rms_nam_name(mynam) - tbuf;
5039   }
5040
5041   /* Posix format specifications must have matching quotes */
5042   if (speclen < (VMS_MAXRSS - 1)) {
5043     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5044       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5045         tbuf[speclen] = '\"';
5046         speclen++;
5047       }
5048     }
5049   }
5050   tbuf[speclen] = '\0';
5051   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5052
5053   /* Have we been working with an expanded, but not resultant, spec? */
5054   /* Also, convert back to Unix syntax if necessary. */
5055
5056   if (!rms_nam_rsll(mynam)) {
5057     if (isunix) {
5058       if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
5059         if (out) Safefree(out);
5060         PerlMem_free(esal);
5061         PerlMem_free(esa);
5062         if (outbufl != NULL)
5063             PerlMem_free(outbufl);
5064         return NULL;
5065       }
5066     }
5067     else strcpy(outbuf,esa);
5068   }
5069   else if (isunix) {
5070     tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5071     if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5072     if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
5073         if (out) Safefree(out);
5074         PerlMem_free(esa);
5075         PerlMem_free(esal);
5076         PerlMem_free(tmpfspec);
5077         if (outbufl != NULL)
5078             PerlMem_free(outbufl);
5079         return NULL;
5080     }
5081     strcpy(outbuf,tmpfspec);
5082     PerlMem_free(tmpfspec);
5083   }
5084
5085   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5086   sts = rms_free_search_context(&myfab); /* Free search context */
5087   PerlMem_free(esa);
5088   PerlMem_free(esal);
5089   if (outbufl != NULL)
5090      PerlMem_free(outbufl);
5091   return outbuf;
5092 }
5093 /*}}}*/
5094 /* External entry points */
5095 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5096 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5097 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5098 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5099 char *Perl_rmsexpand_utf8
5100   (pTHX_ const char *spec, char *buf, const char *def,
5101    unsigned opt, int * fs_utf8, int * dfs_utf8)
5102 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5103 char *Perl_rmsexpand_utf8_ts
5104   (pTHX_ const char *spec, char *buf, const char *def,
5105    unsigned opt, int * fs_utf8, int * dfs_utf8)
5106 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5107
5108
5109 /*
5110 ** The following routines are provided to make life easier when
5111 ** converting among VMS-style and Unix-style directory specifications.
5112 ** All will take input specifications in either VMS or Unix syntax. On
5113 ** failure, all return NULL.  If successful, the routines listed below
5114 ** return a pointer to a buffer containing the appropriately
5115 ** reformatted spec (and, therefore, subsequent calls to that routine
5116 ** will clobber the result), while the routines of the same names with
5117 ** a _ts suffix appended will return a pointer to a mallocd string
5118 ** containing the appropriately reformatted spec.
5119 ** In all cases, only explicit syntax is altered; no check is made that
5120 ** the resulting string is valid or that the directory in question
5121 ** actually exists.
5122 **
5123 **   fileify_dirspec() - convert a directory spec into the name of the
5124 **     directory file (i.e. what you can stat() to see if it's a dir).
5125 **     The style (VMS or Unix) of the result is the same as the style
5126 **     of the parameter passed in.
5127 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5128 **     what you prepend to a filename to indicate what directory it's in).
5129 **     The style (VMS or Unix) of the result is the same as the style
5130 **     of the parameter passed in.
5131 **   tounixpath() - convert a directory spec into a Unix-style path.
5132 **   tovmspath() - convert a directory spec into a VMS-style path.
5133 **   tounixspec() - convert any file spec into a Unix-style file spec.
5134 **   tovmsspec() - convert any file spec into a VMS-style spec.
5135 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5136 **
5137 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5138 ** Permission is given to distribute this code as part of the Perl
5139 ** standard distribution under the terms of the GNU General Public
5140 ** License or the Perl Artistic License.  Copies of each may be
5141 ** found in the Perl standard distribution.
5142  */
5143
5144 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5145 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5146 {
5147     static char __fileify_retbuf[VMS_MAXRSS];
5148     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5149     char *retspec, *cp1, *cp2, *lastdir;
5150     char *trndir, *vmsdir;
5151     unsigned short int trnlnm_iter_count;
5152     int sts;
5153     if (utf8_fl != NULL)
5154         *utf8_fl = 0;
5155
5156     if (!dir || !*dir) {
5157       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5158     }
5159     dirlen = strlen(dir);
5160     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5161     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5162       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5163         dir = "/sys$disk";
5164         dirlen = 9;
5165       }
5166       else
5167         dirlen = 1;
5168     }
5169     if (dirlen > (VMS_MAXRSS - 1)) {
5170       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5171       return NULL;
5172     }
5173     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5174     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5175     if (!strpbrk(dir+1,"/]>:")  &&
5176         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5177       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5178       trnlnm_iter_count = 0;
5179       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
5180         trnlnm_iter_count++;
5181         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5182       }
5183       dirlen = strlen(trndir);
5184     }
5185     else {
5186       strncpy(trndir,dir,dirlen);
5187       trndir[dirlen] = '\0';
5188     }
5189
5190     /* At this point we are done with *dir and use *trndir which is a
5191      * copy that can be modified.  *dir must not be modified.
5192      */
5193
5194     /* If we were handed a rooted logical name or spec, treat it like a
5195      * simple directory, so that
5196      *    $ Define myroot dev:[dir.]
5197      *    ... do_fileify_dirspec("myroot",buf,1) ...
5198      * does something useful.
5199      */
5200     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5201       trndir[--dirlen] = '\0';
5202       trndir[dirlen-1] = ']';
5203     }
5204     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5205       trndir[--dirlen] = '\0';
5206       trndir[dirlen-1] = '>';
5207     }
5208
5209     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5210       /* If we've got an explicit filename, we can just shuffle the string. */
5211       if (*(cp1+1)) hasfilename = 1;
5212       /* Similarly, we can just back up a level if we've got multiple levels
5213          of explicit directories in a VMS spec which ends with directories. */
5214       else {
5215         for (cp2 = cp1; cp2 > trndir; cp2--) {
5216           if (*cp2 == '.') {
5217             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5218 /* fix-me, can not scan EFS file specs backward like this */
5219               *cp2 = *cp1; *cp1 = '\0';
5220               hasfilename = 1;
5221               break;
5222             }
5223           }
5224           if (*cp2 == '[' || *cp2 == '<') break;
5225         }
5226       }
5227     }
5228
5229     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5230     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5231     cp1 = strpbrk(trndir,"]:>");
5232     if (hasfilename || !cp1) { /* Unix-style path or filename */
5233       if (trndir[0] == '.') {
5234         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5235           PerlMem_free(trndir);
5236           PerlMem_free(vmsdir);
5237           return do_fileify_dirspec("[]",buf,ts,NULL);
5238         }
5239         else if (trndir[1] == '.' &&
5240                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5241           PerlMem_free(trndir);
5242           PerlMem_free(vmsdir);
5243           return do_fileify_dirspec("[-]",buf,ts,NULL);
5244         }
5245       }
5246       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5247         dirlen -= 1;                 /* to last element */
5248         lastdir = strrchr(trndir,'/');
5249       }
5250       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5251         /* If we have "/." or "/..", VMSify it and let the VMS code
5252          * below expand it, rather than repeating the code to handle
5253          * relative components of a filespec here */
5254         do {
5255           if (*(cp1+2) == '.') cp1++;
5256           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5257             char * ret_chr;
5258             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5259                 PerlMem_free(trndir);
5260                 PerlMem_free(vmsdir);
5261                 return NULL;
5262             }
5263             if (strchr(vmsdir,'/') != NULL) {
5264               /* If do_tovmsspec() returned it, it must have VMS syntax
5265                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5266                * the time to check this here only so we avoid a recursion
5267                * loop; otherwise, gigo.
5268                */
5269               PerlMem_free(trndir);
5270               PerlMem_free(vmsdir);
5271               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5272               return NULL;
5273             }
5274             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5275                 PerlMem_free(trndir);
5276                 PerlMem_free(vmsdir);
5277                 return NULL;
5278             }
5279             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5280             PerlMem_free(trndir);
5281             PerlMem_free(vmsdir);
5282             return ret_chr;
5283           }
5284           cp1++;
5285         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5286         lastdir = strrchr(trndir,'/');
5287       }
5288       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5289         char * ret_chr;
5290         /* Ditto for specs that end in an MFD -- let the VMS code
5291          * figure out whether it's a real device or a rooted logical. */
5292
5293         /* This should not happen any more.  Allowing the fake /000000
5294          * in a UNIX pathname causes all sorts of problems when trying
5295          * to run in UNIX emulation.  So the VMS to UNIX conversions
5296          * now remove the fake /000000 directories.
5297          */
5298
5299         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5300         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5301             PerlMem_free(trndir);
5302             PerlMem_free(vmsdir);
5303             return NULL;
5304         }
5305         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5306             PerlMem_free(trndir);
5307             PerlMem_free(vmsdir);
5308             return NULL;
5309         }
5310         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5311         PerlMem_free(trndir);
5312         PerlMem_free(vmsdir);
5313         return ret_chr;
5314       }
5315       else {
5316
5317         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5318              !(lastdir = cp1 = strrchr(trndir,']')) &&
5319              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5320         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5321           int ver; char *cp3;
5322
5323           /* For EFS or ODS-5 look for the last dot */
5324           if (decc_efs_charset) {
5325               cp2 = strrchr(cp1,'.');
5326           }
5327           if (vms_process_case_tolerant) {
5328               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5329                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5330                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5331                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5332                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5333                             (ver || *cp3)))))) {
5334                   PerlMem_free(trndir);
5335                   PerlMem_free(vmsdir);
5336                   set_errno(ENOTDIR);
5337                   set_vaxc_errno(RMS$_DIR);
5338                   return NULL;
5339               }
5340           }
5341           else {
5342               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5343                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5344                   !*(cp2+3) || *(cp2+3) != 'R' ||
5345                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5346                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5347                             (ver || *cp3)))))) {
5348                  PerlMem_free(trndir);
5349                  PerlMem_free(vmsdir);
5350                  set_errno(ENOTDIR);
5351                  set_vaxc_errno(RMS$_DIR);
5352                  return NULL;
5353               }
5354           }
5355           dirlen = cp2 - trndir;
5356         }
5357       }
5358
5359       retlen = dirlen + 6;
5360       if (buf) retspec = buf;
5361       else if (ts) Newx(retspec,retlen+1,char);
5362       else retspec = __fileify_retbuf;
5363       memcpy(retspec,trndir,dirlen);
5364       retspec[dirlen] = '\0';
5365
5366       /* We've picked up everything up to the directory file name.
5367          Now just add the type and version, and we're set. */
5368       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5369         strcat(retspec,".dir;1");
5370       else
5371         strcat(retspec,".DIR;1");
5372       PerlMem_free(trndir);
5373       PerlMem_free(vmsdir);
5374       return retspec;
5375     }
5376     else {  /* VMS-style directory spec */
5377
5378       char *esa, term, *cp;
5379       unsigned long int sts, cmplen, haslower = 0;
5380       unsigned int nam_fnb;
5381       char * nam_type;
5382       struct FAB dirfab = cc$rms_fab;
5383       rms_setup_nam(savnam);
5384       rms_setup_nam(dirnam);
5385
5386       esa = PerlMem_malloc(VMS_MAXRSS + 1);
5387       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5388       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5389       rms_bind_fab_nam(dirfab, dirnam);
5390       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5391       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5392 #ifdef NAM$M_NO_SHORT_UPCASE
5393       if (decc_efs_case_preserve)
5394         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5395 #endif
5396
5397       for (cp = trndir; *cp; cp++)
5398         if (islower(*cp)) { haslower = 1; break; }
5399       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5400         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5401           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5402           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5403         }
5404         if (!sts) {
5405           PerlMem_free(esa);
5406           PerlMem_free(trndir);
5407           PerlMem_free(vmsdir);
5408           set_errno(EVMSERR);
5409           set_vaxc_errno(dirfab.fab$l_sts);
5410           return NULL;
5411         }
5412       }
5413       else {
5414         savnam = dirnam;
5415         /* Does the file really exist? */
5416         if (sys$search(&dirfab)& STS$K_SUCCESS) {
5417           /* Yes; fake the fnb bits so we'll check type below */
5418         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5419         }
5420         else { /* No; just work with potential name */
5421           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5422           else {
5423             int fab_sts;
5424             fab_sts = dirfab.fab$l_sts;
5425             sts = rms_free_search_context(&dirfab);
5426             PerlMem_free(esa);
5427             PerlMem_free(trndir);
5428             PerlMem_free(vmsdir);
5429             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
5430             return NULL;
5431           }
5432         }
5433       }
5434       esa[rms_nam_esll(dirnam)] = '\0';
5435       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5436         cp1 = strchr(esa,']');
5437         if (!cp1) cp1 = strchr(esa,'>');
5438         if (cp1) {  /* Should always be true */
5439           rms_nam_esll(dirnam) -= cp1 - esa - 1;
5440           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5441         }
5442       }
5443       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5444         /* Yep; check version while we're at it, if it's there. */
5445         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5446         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5447           /* Something other than .DIR[;1].  Bzzt. */
5448           sts = rms_free_search_context(&dirfab);
5449           PerlMem_free(esa);
5450           PerlMem_free(trndir);
5451           PerlMem_free(vmsdir);
5452           set_errno(ENOTDIR);
5453           set_vaxc_errno(RMS$_DIR);
5454           return NULL;
5455         }
5456       }
5457
5458       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5459         /* They provided at least the name; we added the type, if necessary, */
5460         if (buf) retspec = buf;                            /* in sys$parse() */
5461         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5462         else retspec = __fileify_retbuf;
5463         strcpy(retspec,esa);
5464         sts = rms_free_search_context(&dirfab);
5465         PerlMem_free(trndir);
5466         PerlMem_free(esa);
5467         PerlMem_free(vmsdir);
5468         return retspec;
5469       }
5470       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5471         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5472         *cp1 = '\0';
5473         rms_nam_esll(dirnam) -= 9;
5474       }
5475       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5476       if (cp1 == NULL) { /* should never happen */
5477         sts = rms_free_search_context(&dirfab);
5478         PerlMem_free(trndir);
5479         PerlMem_free(esa);
5480         PerlMem_free(vmsdir);
5481         return NULL;
5482       }
5483       term = *cp1;
5484       *cp1 = '\0';
5485       retlen = strlen(esa);
5486       cp1 = strrchr(esa,'.');
5487       /* ODS-5 directory specifications can have extra "." in them. */
5488       /* Fix-me, can not scan EFS file specifications backwards */
5489       while (cp1 != NULL) {
5490         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5491           break;
5492         else {
5493            cp1--;
5494            while ((cp1 > esa) && (*cp1 != '.'))
5495              cp1--;
5496         }
5497         if (cp1 == esa)
5498           cp1 = NULL;
5499       }
5500
5501       if ((cp1) != NULL) {
5502         /* There's more than one directory in the path.  Just roll back. */
5503         *cp1 = term;
5504         if (buf) retspec = buf;
5505         else if (ts) Newx(retspec,retlen+7,char);
5506         else retspec = __fileify_retbuf;
5507         strcpy(retspec,esa);
5508       }
5509       else {
5510         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5511           /* Go back and expand rooted logical name */
5512           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5513 #ifdef NAM$M_NO_SHORT_UPCASE
5514           if (decc_efs_case_preserve)
5515             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5516 #endif
5517           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5518             sts = rms_free_search_context(&dirfab);
5519             PerlMem_free(esa);
5520             PerlMem_free(trndir);
5521             PerlMem_free(vmsdir);
5522             set_errno(EVMSERR);
5523             set_vaxc_errno(dirfab.fab$l_sts);
5524             return NULL;
5525           }
5526           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5527           if (buf) retspec = buf;
5528           else if (ts) Newx(retspec,retlen+16,char);
5529           else retspec = __fileify_retbuf;
5530           cp1 = strstr(esa,"][");
5531           if (!cp1) cp1 = strstr(esa,"]<");
5532           dirlen = cp1 - esa;
5533           memcpy(retspec,esa,dirlen);
5534           if (!strncmp(cp1+2,"000000]",7)) {
5535             retspec[dirlen-1] = '\0';
5536             /* fix-me Not full ODS-5, just extra dots in directories for now */
5537             cp1 = retspec + dirlen - 1;
5538             while (cp1 > retspec)
5539             {
5540               if (*cp1 == '[')
5541                 break;
5542               if (*cp1 == '.') {
5543                 if (*(cp1-1) != '^')
5544                   break;
5545               }
5546               cp1--;
5547             }
5548             if (*cp1 == '.') *cp1 = ']';
5549             else {
5550               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5551               memmove(cp1+1,"000000]",7);
5552             }
5553           }
5554           else {
5555             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5556             retspec[retlen] = '\0';
5557             /* Convert last '.' to ']' */
5558             cp1 = retspec+retlen-1;
5559             while (*cp != '[') {
5560               cp1--;
5561               if (*cp1 == '.') {
5562                 /* Do not trip on extra dots in ODS-5 directories */
5563                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5564                 break;
5565               }
5566             }
5567             if (*cp1 == '.') *cp1 = ']';
5568             else {
5569               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5570               memmove(cp1+1,"000000]",7);
5571             }
5572           }
5573         }
5574         else {  /* This is a top-level dir.  Add the MFD to the path. */
5575           if (buf) retspec = buf;
5576           else if (ts) Newx(retspec,retlen+16,char);
5577           else retspec = __fileify_retbuf;
5578           cp1 = esa;
5579           cp2 = retspec;
5580           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5581           strcpy(cp2,":[000000]");
5582           cp1 += 2;
5583           strcpy(cp2+9,cp1);
5584         }
5585       }
5586       sts = rms_free_search_context(&dirfab);
5587       /* We've set up the string up through the filename.  Add the
5588          type and version, and we're done. */
5589       strcat(retspec,".DIR;1");
5590
5591       /* $PARSE may have upcased filespec, so convert output to lower
5592        * case if input contained any lowercase characters. */
5593       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5594       PerlMem_free(trndir);
5595       PerlMem_free(esa);
5596       PerlMem_free(vmsdir);
5597       return retspec;
5598     }
5599 }  /* end of do_fileify_dirspec() */
5600 /*}}}*/
5601 /* External entry points */
5602 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5603 { return do_fileify_dirspec(dir,buf,0,NULL); }
5604 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5605 { return do_fileify_dirspec(dir,buf,1,NULL); }
5606 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5607 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5608 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5609 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5610
5611 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5612 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5613 {
5614     static char __pathify_retbuf[VMS_MAXRSS];
5615     unsigned long int retlen;
5616     char *retpath, *cp1, *cp2, *trndir;
5617     unsigned short int trnlnm_iter_count;
5618     STRLEN trnlen;
5619     int sts;
5620     if (utf8_fl != NULL)
5621         *utf8_fl = 0;
5622
5623     if (!dir || !*dir) {
5624       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5625     }
5626
5627     trndir = PerlMem_malloc(VMS_MAXRSS);
5628     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5629     if (*dir) strcpy(trndir,dir);
5630     else getcwd(trndir,VMS_MAXRSS - 1);
5631
5632     trnlnm_iter_count = 0;
5633     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5634            && my_trnlnm(trndir,trndir,0)) {
5635       trnlnm_iter_count++;
5636       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5637       trnlen = strlen(trndir);
5638
5639       /* Trap simple rooted lnms, and return lnm:[000000] */
5640       if (!strcmp(trndir+trnlen-2,".]")) {
5641         if (buf) retpath = buf;
5642         else if (ts) Newx(retpath,strlen(dir)+10,char);
5643         else retpath = __pathify_retbuf;
5644         strcpy(retpath,dir);
5645         strcat(retpath,":[000000]");
5646         PerlMem_free(trndir);
5647         return retpath;
5648       }
5649     }
5650
5651     /* At this point we do not work with *dir, but the copy in
5652      * *trndir that is modifiable.
5653      */
5654
5655     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5656       if (*trndir == '.' && (*(trndir+1) == '\0' ||
5657                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5658         retlen = 2 + (*(trndir+1) != '\0');
5659       else {
5660         if ( !(cp1 = strrchr(trndir,'/')) &&
5661              !(cp1 = strrchr(trndir,']')) &&
5662              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5663         if ((cp2 = strchr(cp1,'.')) != NULL &&
5664             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
5665              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
5666               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5667               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5668           int ver; char *cp3;
5669
5670           /* For EFS or ODS-5 look for the last dot */
5671           if (decc_efs_charset) {
5672             cp2 = strrchr(cp1,'.');
5673           }
5674           if (vms_process_case_tolerant) {
5675               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5676                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5677                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5678                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5679                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5680                             (ver || *cp3)))))) {
5681                 PerlMem_free(trndir);
5682                 set_errno(ENOTDIR);
5683                 set_vaxc_errno(RMS$_DIR);
5684                 return NULL;
5685               }
5686           }
5687           else {
5688               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5689                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5690                   !*(cp2+3) || *(cp2+3) != 'R' ||
5691                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5692                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5693                             (ver || *cp3)))))) {
5694                 PerlMem_free(trndir);
5695                 set_errno(ENOTDIR);
5696                 set_vaxc_errno(RMS$_DIR);
5697                 return NULL;
5698               }
5699           }
5700           retlen = cp2 - trndir + 1;
5701         }
5702         else {  /* No file type present.  Treat the filename as a directory. */
5703           retlen = strlen(trndir) + 1;
5704         }
5705       }
5706       if (buf) retpath = buf;
5707       else if (ts) Newx(retpath,retlen+1,char);
5708       else retpath = __pathify_retbuf;
5709       strncpy(retpath, trndir, retlen-1);
5710       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5711         retpath[retlen-1] = '/';      /* with '/', add it. */
5712         retpath[retlen] = '\0';
5713       }
5714       else retpath[retlen-1] = '\0';
5715     }
5716     else {  /* VMS-style directory spec */
5717       char *esa, *cp;
5718       unsigned long int sts, cmplen, haslower;
5719       struct FAB dirfab = cc$rms_fab;
5720       int dirlen;
5721       rms_setup_nam(savnam);
5722       rms_setup_nam(dirnam);
5723
5724       /* If we've got an explicit filename, we can just shuffle the string. */
5725       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5726              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
5727         if ((cp2 = strchr(cp1,'.')) != NULL) {
5728           int ver; char *cp3;
5729           if (vms_process_case_tolerant) {
5730               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5731                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5732                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5733                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5734                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5735                             (ver || *cp3)))))) {
5736                PerlMem_free(trndir);
5737                set_errno(ENOTDIR);
5738                set_vaxc_errno(RMS$_DIR);
5739                return NULL;
5740              }
5741           }
5742           else {
5743               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5744                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5745                   !*(cp2+3) || *(cp2+3) != 'R' ||
5746                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5747                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5748                             (ver || *cp3)))))) {
5749                PerlMem_free(trndir);
5750                set_errno(ENOTDIR);
5751                set_vaxc_errno(RMS$_DIR);
5752                return NULL;
5753              }
5754           }
5755         }
5756         else {  /* No file type, so just draw name into directory part */
5757           for (cp2 = cp1; *cp2; cp2++) ;
5758         }
5759         *cp2 = *cp1;
5760         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5761         *cp1 = '.';
5762         /* We've now got a VMS 'path'; fall through */
5763       }
5764
5765       dirlen = strlen(trndir);
5766       if (trndir[dirlen-1] == ']' ||
5767           trndir[dirlen-1] == '>' ||
5768           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5769         if (buf) retpath = buf;
5770         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5771         else retpath = __pathify_retbuf;
5772         strcpy(retpath,trndir);
5773         PerlMem_free(trndir);
5774         return retpath;
5775       }
5776       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5777       esa = PerlMem_malloc(VMS_MAXRSS);
5778       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5779       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5780       rms_bind_fab_nam(dirfab, dirnam);
5781       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5782 #ifdef NAM$M_NO_SHORT_UPCASE
5783       if (decc_efs_case_preserve)
5784           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5785 #endif
5786
5787       for (cp = trndir; *cp; cp++)
5788         if (islower(*cp)) { haslower = 1; break; }
5789
5790       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5791         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5792           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5793           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5794         }
5795         if (!sts) {
5796           PerlMem_free(trndir);
5797           PerlMem_free(esa);
5798           set_errno(EVMSERR);
5799           set_vaxc_errno(dirfab.fab$l_sts);
5800           return NULL;
5801         }
5802       }
5803       else {
5804         savnam = dirnam;
5805         /* Does the file really exist? */
5806         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5807           if (dirfab.fab$l_sts != RMS$_FNF) {
5808             int sts1;
5809             sts1 = rms_free_search_context(&dirfab);
5810             PerlMem_free(trndir);
5811             PerlMem_free(esa);
5812             set_errno(EVMSERR);
5813             set_vaxc_errno(dirfab.fab$l_sts);
5814             return NULL;
5815           }
5816           dirnam = savnam; /* No; just work with potential name */
5817         }
5818       }
5819       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5820         /* Yep; check version while we're at it, if it's there. */
5821         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5822         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5823           int sts2;
5824           /* Something other than .DIR[;1].  Bzzt. */
5825           sts2 = rms_free_search_context(&dirfab);
5826           PerlMem_free(trndir);
5827           PerlMem_free(esa);
5828           set_errno(ENOTDIR);
5829           set_vaxc_errno(RMS$_DIR);
5830           return NULL;
5831         }
5832       }
5833       /* OK, the type was fine.  Now pull any file name into the
5834          directory path. */
5835       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5836       else {
5837         cp1 = strrchr(esa,'>');
5838         *(rms_nam_typel(dirnam)) = '>';
5839       }
5840       *cp1 = '.';
5841       *(rms_nam_typel(dirnam) + 1) = '\0';
5842       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5843       if (buf) retpath = buf;
5844       else if (ts) Newx(retpath,retlen,char);
5845       else retpath = __pathify_retbuf;
5846       strcpy(retpath,esa);
5847       PerlMem_free(esa);
5848       sts = rms_free_search_context(&dirfab);
5849       /* $PARSE may have upcased filespec, so convert output to lower
5850        * case if input contained any lowercase characters. */
5851       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5852     }
5853
5854     PerlMem_free(trndir);
5855     return retpath;
5856 }  /* end of do_pathify_dirspec() */
5857 /*}}}*/
5858 /* External entry points */
5859 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5860 { return do_pathify_dirspec(dir,buf,0,NULL); }
5861 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5862 { return do_pathify_dirspec(dir,buf,1,NULL); }
5863 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5864 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5865 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5866 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5867
5868 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5869 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5870 {
5871   static char __tounixspec_retbuf[VMS_MAXRSS];
5872   char *dirend, *rslt, *cp1, *cp3, *tmp;
5873   const char *cp2;
5874   int devlen, dirlen, retlen = VMS_MAXRSS;
5875   int expand = 1; /* guarantee room for leading and trailing slashes */
5876   unsigned short int trnlnm_iter_count;
5877   int cmp_rslt;
5878   if (utf8_fl != NULL)
5879     *utf8_fl = 0;
5880
5881   if (spec == NULL) return NULL;
5882   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5883   if (buf) rslt = buf;
5884   else if (ts) {
5885     Newx(rslt, VMS_MAXRSS, char);
5886   }
5887   else rslt = __tounixspec_retbuf;
5888
5889   /* New VMS specific format needs translation
5890    * glob passes filenames with trailing '\n' and expects this preserved.
5891    */
5892   if (decc_posix_compliant_pathnames) {
5893     if (strncmp(spec, "\"^UP^", 5) == 0) {
5894       char * uspec;
5895       char *tunix;
5896       int tunix_len;
5897       int nl_flag;
5898
5899       tunix = PerlMem_malloc(VMS_MAXRSS);
5900       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5901       strcpy(tunix, spec);
5902       tunix_len = strlen(tunix);
5903       nl_flag = 0;
5904       if (tunix[tunix_len - 1] == '\n') {
5905         tunix[tunix_len - 1] = '\"';
5906         tunix[tunix_len] = '\0';
5907         tunix_len--;
5908         nl_flag = 1;
5909       }
5910       uspec = decc$translate_vms(tunix);
5911       PerlMem_free(tunix);
5912       if ((int)uspec > 0) {
5913         strcpy(rslt,uspec);
5914         if (nl_flag) {
5915           strcat(rslt,"\n");
5916         }
5917         else {
5918           /* If we can not translate it, makemaker wants as-is */
5919           strcpy(rslt, spec);
5920         }
5921         return rslt;
5922       }
5923     }
5924   }
5925
5926   cmp_rslt = 0; /* Presume VMS */
5927   cp1 = strchr(spec, '/');
5928   if (cp1 == NULL)
5929     cmp_rslt = 0;
5930
5931     /* Look for EFS ^/ */
5932     if (decc_efs_charset) {
5933       while (cp1 != NULL) {
5934         cp2 = cp1 - 1;
5935         if (*cp2 != '^') {
5936           /* Found illegal VMS, assume UNIX */
5937           cmp_rslt = 1;
5938           break;
5939         }
5940       cp1++;
5941       cp1 = strchr(cp1, '/');
5942     }
5943   }
5944
5945   /* Look for "." and ".." */
5946   if (decc_filename_unix_report) {
5947     if (spec[0] == '.') {
5948       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5949         cmp_rslt = 1;
5950       }
5951       else {
5952         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5953           cmp_rslt = 1;
5954         }
5955       }
5956     }
5957   }
5958   /* This is already UNIX or at least nothing VMS understands */
5959   if (cmp_rslt) {
5960     strcpy(rslt,spec);
5961     return rslt;
5962   }
5963
5964   cp1 = rslt;
5965   cp2 = spec;
5966   dirend = strrchr(spec,']');
5967   if (dirend == NULL) dirend = strrchr(spec,'>');
5968   if (dirend == NULL) dirend = strchr(spec,':');
5969   if (dirend == NULL) {
5970     strcpy(rslt,spec);
5971     return rslt;
5972   }
5973
5974   /* Special case 1 - sys$posix_root = / */
5975 #if __CRTL_VER >= 70000000
5976   if (!decc_disable_posix_root) {
5977     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5978       *cp1 = '/';
5979       cp1++;
5980       cp2 = cp2 + 15;
5981       }
5982   }
5983 #endif
5984
5985   /* Special case 2 - Convert NLA0: to /dev/null */
5986 #if __CRTL_VER < 70000000
5987   cmp_rslt = strncmp(spec,"NLA0:", 5);
5988   if (cmp_rslt != 0)
5989      cmp_rslt = strncmp(spec,"nla0:", 5);
5990 #else
5991   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5992 #endif
5993   if (cmp_rslt == 0) {
5994     strcpy(rslt, "/dev/null");
5995     cp1 = cp1 + 9;
5996     cp2 = cp2 + 5;
5997     if (spec[6] != '\0') {
5998       cp1[9] == '/';
5999       cp1++;
6000       cp2++;
6001     }
6002   }
6003
6004    /* Also handle special case "SYS$SCRATCH:" */
6005 #if __CRTL_VER < 70000000
6006   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6007   if (cmp_rslt != 0)
6008      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6009 #else
6010   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6011 #endif
6012   tmp = PerlMem_malloc(VMS_MAXRSS);
6013   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6014   if (cmp_rslt == 0) {
6015   int islnm;
6016
6017     islnm = my_trnlnm(tmp, "TMP", 0);
6018     if (!islnm) {
6019       strcpy(rslt, "/tmp");
6020       cp1 = cp1 + 4;
6021       cp2 = cp2 + 12;
6022       if (spec[12] != '\0') {
6023         cp1[4] == '/';
6024         cp1++;
6025         cp2++;
6026       }
6027     }
6028   }
6029
6030   if (*cp2 != '[' && *cp2 != '<') {
6031     *(cp1++) = '/';
6032   }
6033   else {  /* the VMS spec begins with directories */
6034     cp2++;
6035     if (*cp2 == ']' || *cp2 == '>') {
6036       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6037       PerlMem_free(tmp);
6038       return rslt;
6039     }
6040     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6041       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6042         if (ts) Safefree(rslt);
6043         PerlMem_free(tmp);
6044         return NULL;
6045       }
6046       trnlnm_iter_count = 0;
6047       do {
6048         cp3 = tmp;
6049         while (*cp3 != ':' && *cp3) cp3++;
6050         *(cp3++) = '\0';
6051         if (strchr(cp3,']') != NULL) break;
6052         trnlnm_iter_count++;
6053         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6054       } while (vmstrnenv(tmp,tmp,0,fildev,0));
6055       if (ts && !buf &&
6056           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6057         retlen = devlen + dirlen;
6058         Renew(rslt,retlen+1+2*expand,char);
6059         cp1 = rslt;
6060       }
6061       cp3 = tmp;
6062       *(cp1++) = '/';
6063       while (*cp3) {
6064         *(cp1++) = *(cp3++);
6065         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6066             PerlMem_free(tmp);
6067             return NULL; /* No room */
6068         }
6069       }
6070       *(cp1++) = '/';
6071     }
6072     if ((*cp2 == '^')) {
6073         /* EFS file escape, pass the next character as is */
6074         /* Fix me: HEX encoding for UNICODE not implemented */
6075         cp2++;
6076     }
6077     else if ( *cp2 == '.') {
6078       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6079         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6080         cp2 += 3;
6081       }
6082       else cp2++;
6083     }
6084   }
6085   PerlMem_free(tmp);
6086   for (; cp2 <= dirend; cp2++) {
6087     if ((*cp2 == '^')) {
6088         /* EFS file escape, pass the next character as is */
6089         /* Fix me: HEX encoding for UNICODE not implemented */
6090         cp2++;
6091         *(cp1++) = *cp2;
6092     }
6093     if (*cp2 == ':') {
6094       *(cp1++) = '/';
6095       if (*(cp2+1) == '[') cp2++;
6096     }
6097     else if (*cp2 == ']' || *cp2 == '>') {
6098       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6099     }
6100     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6101       *(cp1++) = '/';
6102       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6103         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6104                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6105         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6106             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6107       }
6108       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6109         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6110         cp2 += 2;
6111       }
6112     }
6113     else if (*cp2 == '-') {
6114       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6115         while (*cp2 == '-') {
6116           cp2++;
6117           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6118         }
6119         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6120           if (ts) Safefree(rslt);                        /* filespecs like */
6121           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
6122           return NULL;
6123         }
6124       }
6125       else *(cp1++) = *cp2;
6126     }
6127     else *(cp1++) = *cp2;
6128   }
6129   while (*cp2) *(cp1++) = *(cp2++);
6130   *cp1 = '\0';
6131
6132   /* This still leaves /000000/ when working with a
6133    * VMS device root or concealed root.
6134    */
6135   {
6136   int ulen;
6137   char * zeros;
6138
6139       ulen = strlen(rslt);
6140
6141       /* Get rid of "000000/ in rooted filespecs */
6142       if (ulen > 7) {
6143         zeros = strstr(rslt, "/000000/");
6144         if (zeros != NULL) {
6145           int mlen;
6146           mlen = ulen - (zeros - rslt) - 7;
6147           memmove(zeros, &zeros[7], mlen);
6148           ulen = ulen - 7;
6149           rslt[ulen] = '\0';
6150         }
6151       }
6152   }
6153
6154   return rslt;
6155
6156 }  /* end of do_tounixspec() */
6157 /*}}}*/
6158 /* External entry points */
6159 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6160   { return do_tounixspec(spec,buf,0, NULL); }
6161 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6162   { return do_tounixspec(spec,buf,1, NULL); }
6163 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6164   { return do_tounixspec(spec,buf,0, utf8_fl); }
6165 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6166   { return do_tounixspec(spec,buf,1, utf8_fl); }
6167
6168 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6169
6170 /*
6171  This procedure is used to identify if a path is based in either
6172  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6173  it returns the OpenVMS format directory for it.
6174
6175  It is expecting specifications of only '/' or '/xxxx/'
6176
6177  If a posix root does not exist, or 'xxxx' is not a directory
6178  in the posix root, it returns a failure.
6179
6180  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6181
6182  It is used only internally by posix_to_vmsspec_hardway().
6183  */
6184
6185 static int posix_root_to_vms
6186   (char *vmspath, int vmspath_len,
6187    const char *unixpath,
6188    const int * utf8_fl) {
6189 int sts;
6190 struct FAB myfab = cc$rms_fab;
6191 struct NAML mynam = cc$rms_naml;
6192 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6193  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6194 char *esa;
6195 char *vms_delim;
6196 int dir_flag;
6197 int unixlen;
6198
6199     dir_flag = 0;
6200     unixlen = strlen(unixpath);
6201     if (unixlen == 0) {
6202       vmspath[0] = '\0';
6203       return RMS$_FNF;
6204     }
6205
6206 #if __CRTL_VER >= 80200000
6207   /* If not a posix spec already, convert it */
6208   if (decc_posix_compliant_pathnames) {
6209     if (strncmp(unixpath,"\"^UP^",5) != 0) {
6210       sprintf(vmspath,"\"^UP^%s\"",unixpath);
6211     }
6212     else {
6213       /* This is already a VMS specification, no conversion */
6214       unixlen--;
6215       strncpy(vmspath,unixpath, vmspath_len);
6216     }
6217   }
6218   else
6219 #endif
6220   {
6221   int path_len;
6222   int i,j;
6223
6224      /* Check to see if this is under the POSIX root */
6225      if (decc_disable_posix_root) {
6226         return RMS$_FNF;
6227      }
6228
6229      /* Skip leading / */
6230      if (unixpath[0] == '/') {
6231         unixpath++;
6232         unixlen--;
6233      }
6234
6235
6236      strcpy(vmspath,"SYS$POSIX_ROOT:");
6237
6238      /* If this is only the / , or blank, then... */
6239      if (unixpath[0] == '\0') {
6240         /* by definition, this is the answer */
6241         return SS$_NORMAL;
6242      }
6243
6244      /* Need to look up a directory */
6245      vmspath[15] = '[';
6246      vmspath[16] = '\0';
6247
6248      /* Copy and add '^' escape characters as needed */
6249      j = 16;
6250      i = 0;
6251      while (unixpath[i] != 0) {
6252      int k;
6253
6254         j += copy_expand_unix_filename_escape
6255             (&vmspath[j], &unixpath[i], &k, utf8_fl);
6256         i += k;
6257      }
6258
6259      path_len = strlen(vmspath);
6260      if (vmspath[path_len - 1] == '/')
6261         path_len--;
6262      vmspath[path_len] = ']';
6263      path_len++;
6264      vmspath[path_len] = '\0';
6265
6266   }
6267   vmspath[vmspath_len] = 0;
6268   if (unixpath[unixlen - 1] == '/')
6269   dir_flag = 1;
6270   esa = PerlMem_malloc(VMS_MAXRSS);
6271   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6272   myfab.fab$l_fna = vmspath;
6273   myfab.fab$b_fns = strlen(vmspath);
6274   myfab.fab$l_naml = &mynam;
6275   mynam.naml$l_esa = NULL;
6276   mynam.naml$b_ess = 0;
6277   mynam.naml$l_long_expand = esa;
6278   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6279   mynam.naml$l_rsa = NULL;
6280   mynam.naml$b_rss = 0;
6281   if (decc_efs_case_preserve)
6282     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6283 #ifdef NAML$M_OPEN_SPECIAL
6284   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6285 #endif
6286
6287   /* Set up the remaining naml fields */
6288   sts = sys$parse(&myfab);
6289
6290   /* It failed! Try again as a UNIX filespec */
6291   if (!(sts & 1)) {
6292     PerlMem_free(esa);
6293     return sts;
6294   }
6295
6296    /* get the Device ID and the FID */
6297    sts = sys$search(&myfab);
6298    /* on any failure, returned the POSIX ^UP^ filespec */
6299    if (!(sts & 1)) {
6300       PerlMem_free(esa);
6301       return sts;
6302    }
6303    specdsc.dsc$a_pointer = vmspath;
6304    specdsc.dsc$w_length = vmspath_len;
6305
6306    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6307    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6308    sts = lib$fid_to_name
6309       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6310
6311   /* on any failure, returned the POSIX ^UP^ filespec */
6312   if (!(sts & 1)) {
6313      /* This can happen if user does not have permission to read directories */
6314      if (strncmp(unixpath,"\"^UP^",5) != 0)
6315        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6316      else
6317        strcpy(vmspath, unixpath);
6318   }
6319   else {
6320     vmspath[specdsc.dsc$w_length] = 0;
6321
6322     /* Are we expecting a directory? */
6323     if (dir_flag != 0) {
6324     int i;
6325     char *eptr;
6326
6327       eptr = NULL;
6328
6329       i = specdsc.dsc$w_length - 1;
6330       while (i > 0) {
6331       int zercnt;
6332         zercnt = 0;
6333         /* Version must be '1' */
6334         if (vmspath[i--] != '1')
6335           break;
6336         /* Version delimiter is one of ".;" */
6337         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6338           break;
6339         i--;
6340         if (vmspath[i--] != 'R')
6341           break;
6342         if (vmspath[i--] != 'I')
6343           break;
6344         if (vmspath[i--] != 'D')
6345           break;
6346         if (vmspath[i--] != '.')
6347           break;
6348         eptr = &vmspath[i+1];
6349         while (i > 0) {
6350           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6351             if (vmspath[i-1] != '^') {
6352               if (zercnt != 6) {
6353                 *eptr = vmspath[i];
6354                 eptr[1] = '\0';
6355                 vmspath[i] = '.';
6356                 break;
6357               }
6358               else {
6359                 /* Get rid of 6 imaginary zero directory filename */
6360                 vmspath[i+1] = '\0';
6361               }
6362             }
6363           }
6364           if (vmspath[i] == '0')
6365             zercnt++;
6366           else
6367             zercnt = 10;
6368           i--;
6369         }
6370         break;
6371       }
6372     }
6373   }
6374   PerlMem_free(esa);
6375   return sts;
6376 }
6377
6378 /* /dev/mumble needs to be handled special.
6379    /dev/null becomes NLA0:, And there is the potential for other stuff
6380    like /dev/tty which may need to be mapped to something.
6381 */
6382
6383 static int
6384 slash_dev_special_to_vms
6385    (const char * unixptr,
6386     char * vmspath,
6387     int vmspath_len)
6388 {
6389 char * nextslash;
6390 int len;
6391 int cmp;
6392 int islnm;
6393
6394     unixptr += 4;
6395     nextslash = strchr(unixptr, '/');
6396     len = strlen(unixptr);
6397     if (nextslash != NULL)
6398         len = nextslash - unixptr;
6399     cmp = strncmp("null", unixptr, 5);
6400     if (cmp == 0) {
6401         if (vmspath_len >= 6) {
6402             strcpy(vmspath, "_NLA0:");
6403             return SS$_NORMAL;
6404         }
6405     }
6406 }
6407
6408
6409 /* The built in routines do not understand perl's special needs, so
6410     doing a manual conversion from UNIX to VMS
6411
6412     If the utf8_fl is not null and points to a non-zero value, then
6413     treat 8 bit characters as UTF-8.
6414
6415     The sequence starting with '$(' and ending with ')' will be passed
6416     through with out interpretation instead of being escaped.
6417
6418   */
6419 static int posix_to_vmsspec_hardway
6420   (char *vmspath, int vmspath_len,
6421    const char *unixpath,
6422    int dir_flag,
6423    int * utf8_fl) {
6424
6425 char *esa;
6426 const char *unixptr;
6427 const char *unixend;
6428 char *vmsptr;
6429 const char *lastslash;
6430 const char *lastdot;
6431 int unixlen;
6432 int vmslen;
6433 int dir_start;
6434 int dir_dot;
6435 int quoted;
6436 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6437 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6438
6439   if (utf8_fl != NULL)
6440     *utf8_fl = 0;
6441
6442   unixptr = unixpath;
6443   dir_dot = 0;
6444
6445   /* Ignore leading "/" characters */
6446   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6447     unixptr++;
6448   }
6449   unixlen = strlen(unixptr);
6450
6451   /* Do nothing with blank paths */
6452   if (unixlen == 0) {
6453     vmspath[0] = '\0';
6454     return SS$_NORMAL;
6455   }
6456
6457   quoted = 0;
6458   /* This could have a "^UP^ on the front */
6459   if (strncmp(unixptr,"\"^UP^",5) == 0) {
6460     quoted = 1;
6461     unixptr+= 5;
6462     unixlen-= 5;
6463   }
6464
6465   lastslash = strrchr(unixptr,'/');
6466   lastdot = strrchr(unixptr,'.');
6467   unixend = strrchr(unixptr,'\"');
6468   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6469     unixend = unixptr + unixlen;
6470   }
6471
6472   /* last dot is last dot or past end of string */
6473   if (lastdot == NULL)
6474     lastdot = unixptr + unixlen;
6475
6476   /* if no directories, set last slash to beginning of string */
6477   if (lastslash == NULL) {
6478     lastslash = unixptr;
6479   }
6480   else {
6481     /* Watch out for trailing "." after last slash, still a directory */
6482     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6483       lastslash = unixptr + unixlen;
6484     }
6485
6486     /* Watch out for traiing ".." after last slash, still a directory */
6487     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6488       lastslash = unixptr + unixlen;
6489     }
6490
6491     /* dots in directories are aways escaped */
6492     if (lastdot < lastslash)
6493       lastdot = unixptr + unixlen;
6494   }
6495
6496   /* if (unixptr < lastslash) then we are in a directory */
6497
6498   dir_start = 0;
6499
6500   vmsptr = vmspath;
6501   vmslen = 0;
6502
6503   /* Start with the UNIX path */
6504   if (*unixptr != '/') {
6505     /* relative paths */
6506
6507     /* If allowing logical names on relative pathnames, then handle here */
6508     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6509         !decc_posix_compliant_pathnames) {
6510     char * nextslash;
6511     int seg_len;
6512     char * trn;
6513     int islnm;
6514
6515         /* Find the next slash */
6516         nextslash = strchr(unixptr,'/');
6517
6518         esa = PerlMem_malloc(vmspath_len);
6519         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6520
6521         trn = PerlMem_malloc(VMS_MAXRSS);
6522         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6523
6524         if (nextslash != NULL) {
6525
6526             seg_len = nextslash - unixptr;
6527             strncpy(esa, unixptr, seg_len);
6528             esa[seg_len] = 0;
6529         }
6530         else {
6531             strcpy(esa, unixptr);
6532             seg_len = strlen(unixptr);
6533         }
6534         /* trnlnm(section) */
6535         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6536
6537         if (islnm) {
6538             /* Now fix up the directory */
6539
6540             /* Split up the path to find the components */
6541             sts = vms_split_path
6542                   (trn,
6543                    &v_spec,
6544                    &v_len,
6545                    &r_spec,
6546                    &r_len,
6547                    &d_spec,
6548                    &d_len,
6549                    &n_spec,
6550                    &n_len,
6551                    &e_spec,
6552                    &e_len,
6553                    &vs_spec,
6554                    &vs_len);
6555
6556             while (sts == 0) {
6557             char * strt;
6558             int cmp;
6559
6560                 /* A logical name must be a directory  or the full
6561                    specification.  It is only a full specification if
6562                    it is the only component */
6563                 if ((unixptr[seg_len] == '\0') ||
6564                     (unixptr[seg_len+1] == '\0')) {
6565
6566                     /* Is a directory being required? */
6567                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6568                         /* Not a logical name */
6569                         break;
6570                     }
6571
6572
6573                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6574                         /* This must be a directory */
6575                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6576                             strcpy(vmsptr, esa);
6577                             vmslen=strlen(vmsptr);
6578                             vmsptr[vmslen] = ':';
6579                             vmslen++;
6580                             vmsptr[vmslen] = '\0';
6581                             return SS$_NORMAL;
6582                         }
6583                     }
6584
6585                 }
6586
6587
6588                 /* must be dev/directory - ignore version */
6589                 if ((n_len + e_len) != 0)
6590                     break;
6591
6592                 /* transfer the volume */
6593                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6594                     strncpy(vmsptr, v_spec, v_len);
6595                     vmsptr += v_len;
6596                     vmsptr[0] = '\0';
6597                     vmslen += v_len;
6598                 }
6599
6600                 /* unroot the rooted directory */
6601                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6602                     r_spec[0] = '[';
6603                     r_spec[r_len - 1] = ']';
6604
6605                     /* This should not be there, but nothing is perfect */
6606                     if (r_len > 9) {
6607                         cmp = strcmp(&r_spec[1], "000000.");
6608                         if (cmp == 0) {
6609                             r_spec += 7;
6610                             r_spec[7] = '[';
6611                             r_len -= 7;
6612                             if (r_len == 2)
6613                                 r_len = 0;
6614                         }
6615                     }
6616                     if (r_len > 0) {
6617                         strncpy(vmsptr, r_spec, r_len);
6618                         vmsptr += r_len;
6619                         vmslen += r_len;
6620                         vmsptr[0] = '\0';
6621                     }
6622                 }
6623                 /* Bring over the directory. */
6624                 if ((d_len > 0) &&
6625                     ((d_len + vmslen) < vmspath_len)) {
6626                     d_spec[0] = '[';
6627                     d_spec[d_len - 1] = ']';
6628                     if (d_len > 9) {
6629                         cmp = strcmp(&d_spec[1], "000000.");
6630                         if (cmp == 0) {
6631                             d_spec += 7;
6632                             d_spec[7] = '[';
6633                             d_len -= 7;
6634                             if (d_len == 2)
6635                                 d_len = 0;
6636                         }
6637                     }
6638
6639                     if (r_len > 0) {
6640                         /* Remove the redundant root */
6641                         if (r_len > 0) {
6642                             /* remove the ][ */
6643                             vmsptr--;
6644                             vmslen--;
6645                             d_spec++;
6646                             d_len--;
6647                         }
6648                         strncpy(vmsptr, d_spec, d_len);
6649                             vmsptr += d_len;
6650                             vmslen += d_len;
6651                             vmsptr[0] = '\0';
6652                     }
6653                 }
6654                 break;
6655             }
6656         }
6657
6658         PerlMem_free(esa);
6659         PerlMem_free(trn);
6660     }
6661
6662     if (lastslash > unixptr) {
6663     int dotdir_seen;
6664
6665       /* skip leading ./ */
6666       dotdir_seen = 0;
6667       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6668         dotdir_seen = 1;
6669         unixptr++;
6670         unixptr++;
6671       }
6672
6673       /* Are we still in a directory? */
6674       if (unixptr <= lastslash) {
6675         *vmsptr++ = '[';
6676         vmslen = 1;
6677         dir_start = 1;
6678
6679         /* if not backing up, then it is relative forward. */
6680         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6681               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6682           *vmsptr++ = '.';
6683           vmslen++;
6684           dir_dot = 1;
6685           }
6686        }
6687        else {
6688          if (dotdir_seen) {
6689            /* Perl wants an empty directory here to tell the difference
6690             * between a DCL commmand and a filename
6691             */
6692           *vmsptr++ = '[';
6693           *vmsptr++ = ']';
6694           vmslen = 2;
6695         }
6696       }
6697     }
6698     else {
6699       /* Handle two special files . and .. */
6700       if (unixptr[0] == '.') {
6701         if (&unixptr[1] == unixend) {
6702           *vmsptr++ = '[';
6703           *vmsptr++ = ']';
6704           vmslen += 2;
6705           *vmsptr++ = '\0';
6706           return SS$_NORMAL;
6707         }
6708         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6709           *vmsptr++ = '[';
6710           *vmsptr++ = '-';
6711           *vmsptr++ = ']';
6712           vmslen += 3;
6713           *vmsptr++ = '\0';
6714           return SS$_NORMAL;
6715         }
6716       }
6717     }
6718   }
6719   else {        /* Absolute PATH handling */
6720   int sts;
6721   char * nextslash;
6722   int seg_len;
6723     /* Need to find out where root is */
6724
6725     /* In theory, this procedure should never get an absolute POSIX pathname
6726      * that can not be found on the POSIX root.
6727      * In practice, that can not be relied on, and things will show up
6728      * here that are a VMS device name or concealed logical name instead.
6729      * So to make things work, this procedure must be tolerant.
6730      */
6731     esa = PerlMem_malloc(vmspath_len);
6732     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6733
6734     sts = SS$_NORMAL;
6735     nextslash = strchr(&unixptr[1],'/');
6736     seg_len = 0;
6737     if (nextslash != NULL) {
6738     int cmp;
6739       seg_len = nextslash - &unixptr[1];
6740       strncpy(vmspath, unixptr, seg_len + 1);
6741       vmspath[seg_len+1] = 0;
6742       cmp = 1;
6743       if (seg_len == 3) {
6744         cmp = strncmp(vmspath, "dev", 4);
6745         if (cmp == 0) {
6746             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6747             if (sts = SS$_NORMAL)
6748                 return SS$_NORMAL;
6749         }
6750       }
6751       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6752     }
6753
6754     if ($VMS_STATUS_SUCCESS(sts)) {
6755       /* This is verified to be a real path */
6756
6757       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6758       if ($VMS_STATUS_SUCCESS(sts)) {
6759         strcpy(vmspath, esa);
6760         vmslen = strlen(vmspath);
6761         vmsptr = vmspath + vmslen;
6762         unixptr++;
6763         if (unixptr < lastslash) {
6764         char * rptr;
6765           vmsptr--;
6766           *vmsptr++ = '.';
6767           dir_start = 1;
6768           dir_dot = 1;
6769           if (vmslen > 7) {
6770           int cmp;
6771             rptr = vmsptr - 7;
6772             cmp = strcmp(rptr,"000000.");
6773             if (cmp == 0) {
6774               vmslen -= 7;
6775               vmsptr -= 7;
6776               vmsptr[1] = '\0';
6777             } /* removing 6 zeros */
6778           } /* vmslen < 7, no 6 zeros possible */
6779         } /* Not in a directory */
6780       } /* Posix root found */
6781       else {
6782         /* No posix root, fall back to default directory */
6783         strcpy(vmspath, "SYS$DISK:[");
6784         vmsptr = &vmspath[10];
6785         vmslen = 10;
6786         if (unixptr > lastslash) {
6787            *vmsptr = ']';
6788            vmsptr++;
6789            vmslen++;
6790         }
6791         else {
6792            dir_start = 1;
6793         }
6794       }
6795     } /* end of verified real path handling */
6796     else {
6797     int add_6zero;
6798     int islnm;
6799
6800       /* Ok, we have a device or a concealed root that is not in POSIX
6801        * or we have garbage.  Make the best of it.
6802        */
6803
6804       /* Posix to VMS destroyed this, so copy it again */
6805       strncpy(vmspath, &unixptr[1], seg_len);
6806       vmspath[seg_len] = 0;
6807       vmslen = seg_len;
6808       vmsptr = &vmsptr[vmslen];
6809       islnm = 0;
6810
6811       /* Now do we need to add the fake 6 zero directory to it? */
6812       add_6zero = 1;
6813       if ((*lastslash == '/') && (nextslash < lastslash)) {
6814         /* No there is another directory */
6815         add_6zero = 0;
6816       }
6817       else {
6818       int trnend;
6819       int cmp;
6820
6821         /* now we have foo:bar or foo:[000000]bar to decide from */
6822         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6823
6824         if (!islnm && !decc_posix_compliant_pathnames) {
6825
6826             cmp = strncmp("bin", vmspath, 4);
6827             if (cmp == 0) {
6828                 /* bin => SYS$SYSTEM: */
6829                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6830             }
6831             else {
6832                 /* tmp => SYS$SCRATCH: */
6833                 cmp = strncmp("tmp", vmspath, 4);
6834                 if (cmp == 0) {
6835                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6836                 }
6837             }
6838         }
6839
6840         trnend = islnm ? islnm - 1 : 0;
6841
6842         /* if this was a logical name, ']' or '>' must be present */
6843         /* if not a logical name, then assume a device and hope. */
6844         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6845
6846         /* if log name and trailing '.' then rooted - treat as device */
6847         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6848
6849         /* Fix me, if not a logical name, a device lookup should be
6850          * done to see if the device is file structured.  If the device
6851          * is not file structured, the 6 zeros should not be put on.
6852          *
6853          * As it is, perl is occasionally looking for dev:[000000]tty.
6854          * which looks a little strange.
6855          *
6856          * Not that easy to detect as "/dev" may be file structured with
6857          * special device files.
6858          */
6859
6860         if ((add_6zero == 0) && (*nextslash == '/') &&
6861             (&nextslash[1] == unixend)) {
6862           /* No real directory present */
6863           add_6zero = 1;
6864         }
6865       }
6866
6867       /* Put the device delimiter on */
6868       *vmsptr++ = ':';
6869       vmslen++;
6870       unixptr = nextslash;
6871       unixptr++;
6872
6873       /* Start directory if needed */
6874       if (!islnm || add_6zero) {
6875         *vmsptr++ = '[';
6876         vmslen++;
6877         dir_start = 1;
6878       }
6879
6880       /* add fake 000000] if needed */
6881       if (add_6zero) {
6882         *vmsptr++ = '0';
6883         *vmsptr++ = '0';
6884         *vmsptr++ = '0';
6885         *vmsptr++ = '0';
6886         *vmsptr++ = '0';
6887         *vmsptr++ = '0';
6888         *vmsptr++ = ']';
6889         vmslen += 7;
6890         dir_start = 0;
6891       }
6892
6893     } /* non-POSIX translation */
6894     PerlMem_free(esa);
6895   } /* End of relative/absolute path handling */
6896
6897   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6898   int dash_flag;
6899   int in_cnt;
6900   int out_cnt;
6901
6902     dash_flag = 0;
6903
6904     if (dir_start != 0) {
6905
6906       /* First characters in a directory are handled special */
6907       while ((*unixptr == '/') ||
6908              ((*unixptr == '.') &&
6909               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6910                 (&unixptr[1]==unixend)))) {
6911       int loop_flag;
6912
6913         loop_flag = 0;
6914
6915         /* Skip redundant / in specification */
6916         while ((*unixptr == '/') && (dir_start != 0)) {
6917           loop_flag = 1;
6918           unixptr++;
6919           if (unixptr == lastslash)
6920             break;
6921         }
6922         if (unixptr == lastslash)
6923           break;
6924
6925         /* Skip redundant ./ characters */
6926         while ((*unixptr == '.') &&
6927                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6928           loop_flag = 1;
6929           unixptr++;
6930           if (unixptr == lastslash)
6931             break;
6932           if (*unixptr == '/')
6933             unixptr++;
6934         }
6935         if (unixptr == lastslash)
6936           break;
6937
6938         /* Skip redundant ../ characters */
6939         while ((*unixptr == '.') && (unixptr[1] == '.') &&
6940              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6941           /* Set the backing up flag */
6942           loop_flag = 1;
6943           dir_dot = 0;
6944           dash_flag = 1;
6945           *vmsptr++ = '-';
6946           vmslen++;
6947           unixptr++; /* first . */
6948           unixptr++; /* second . */
6949           if (unixptr == lastslash)
6950             break;
6951           if (*unixptr == '/') /* The slash */
6952             unixptr++;
6953         }
6954         if (unixptr == lastslash)
6955           break;
6956
6957         /* To do: Perl expects /.../ to be translated to [...] on VMS */
6958         /* Not needed when VMS is pretending to be UNIX. */
6959
6960         /* Is this loop stuck because of too many dots? */
6961         if (loop_flag == 0) {
6962           /* Exit the loop and pass the rest through */
6963           break;
6964         }
6965       }
6966
6967       /* Are we done with directories yet? */
6968       if (unixptr >= lastslash) {
6969
6970         /* Watch out for trailing dots */
6971         if (dir_dot != 0) {
6972             vmslen --;
6973             vmsptr--;
6974         }
6975         *vmsptr++ = ']';
6976         vmslen++;
6977         dash_flag = 0;
6978         dir_start = 0;
6979         if (*unixptr == '/')
6980           unixptr++;
6981       }
6982       else {
6983         /* Have we stopped backing up? */
6984         if (dash_flag) {
6985           *vmsptr++ = '.';
6986           vmslen++;
6987           dash_flag = 0;
6988           /* dir_start continues to be = 1 */
6989         }
6990         if (*unixptr == '-') {
6991           *vmsptr++ = '^';
6992           *vmsptr++ = *unixptr++;
6993           vmslen += 2;
6994           dir_start = 0;
6995
6996           /* Now are we done with directories yet? */
6997           if (unixptr >= lastslash) {
6998
6999             /* Watch out for trailing dots */
7000             if (dir_dot != 0) {
7001               vmslen --;
7002               vmsptr--;
7003             }
7004
7005             *vmsptr++ = ']';
7006             vmslen++;
7007             dash_flag = 0;
7008             dir_start = 0;
7009           }
7010         }
7011       }
7012     }
7013
7014     /* All done? */
7015     if (unixptr >= unixend)
7016       break;
7017
7018     /* Normal characters - More EFS work probably needed */
7019     dir_start = 0;
7020     dir_dot = 0;
7021
7022     switch(*unixptr) {
7023     case '/':
7024         /* remove multiple / */
7025         while (unixptr[1] == '/') {
7026            unixptr++;
7027         }
7028         if (unixptr == lastslash) {
7029           /* Watch out for trailing dots */
7030           if (dir_dot != 0) {
7031             vmslen --;
7032             vmsptr--;
7033           }
7034           *vmsptr++ = ']';
7035         }
7036         else {
7037           dir_start = 1;
7038           *vmsptr++ = '.';
7039           dir_dot = 1;
7040
7041           /* To do: Perl expects /.../ to be translated to [...] on VMS */
7042           /* Not needed when VMS is pretending to be UNIX. */
7043
7044         }
7045         dash_flag = 0;
7046         if (unixptr != unixend)
7047           unixptr++;
7048         vmslen++;
7049         break;
7050     case '.':
7051         if ((unixptr < lastdot) || (unixptr < lastslash) ||
7052             (&unixptr[1] == unixend)) {
7053           *vmsptr++ = '^';
7054           *vmsptr++ = '.';
7055           vmslen += 2;
7056           unixptr++;
7057
7058           /* trailing dot ==> '^..' on VMS */
7059           if (unixptr == unixend) {
7060             *vmsptr++ = '.';
7061             vmslen++;
7062             unixptr++;
7063           }
7064           break;
7065         }
7066
7067         *vmsptr++ = *unixptr++;
7068         vmslen ++;
7069         break;
7070     case '"':
7071         if (quoted && (&unixptr[1] == unixend)) {
7072             unixptr++;
7073             break;
7074         }
7075         in_cnt = copy_expand_unix_filename_escape
7076                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7077         vmsptr += out_cnt;
7078         unixptr += in_cnt;
7079         break;
7080     case '~':
7081     case ';':
7082     case '\\':
7083     case '?':
7084     case ' ':
7085     default:
7086         in_cnt = copy_expand_unix_filename_escape
7087                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7088         vmsptr += out_cnt;
7089         unixptr += in_cnt;
7090         break;
7091     }
7092   }
7093
7094   /* Make sure directory is closed */
7095   if (unixptr == lastslash) {
7096     char *vmsptr2;
7097     vmsptr2 = vmsptr - 1;
7098
7099     if (*vmsptr2 != ']') {
7100       *vmsptr2--;
7101
7102       /* directories do not end in a dot bracket */
7103       if (*vmsptr2 == '.') {
7104         vmsptr2--;
7105
7106         /* ^. is allowed */
7107         if (*vmsptr2 != '^') {
7108           vmsptr--; /* back up over the dot */
7109         }
7110       }
7111       *vmsptr++ = ']';
7112     }
7113   }
7114   else {
7115     char *vmsptr2;
7116     /* Add a trailing dot if a file with no extension */
7117     vmsptr2 = vmsptr - 1;
7118     if ((vmslen > 1) &&
7119         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7120         (*vmsptr2 != ')') && (*lastdot != '.')) {
7121         *vmsptr++ = '.';
7122         vmslen++;
7123     }
7124   }
7125
7126   *vmsptr = '\0';
7127   return SS$_NORMAL;
7128 }
7129 #endif
7130
7131  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7132 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7133 {
7134 char * result;
7135 int utf8_flag;
7136
7137    /* If a UTF8 flag is being passed, honor it */
7138    utf8_flag = 0;
7139    if (utf8_fl != NULL) {
7140      utf8_flag = *utf8_fl;
7141     *utf8_fl = 0;
7142    }
7143
7144    if (utf8_flag) {
7145      /* If there is a possibility of UTF8, then if any UTF8 characters
7146         are present, then they must be converted to VTF-7
7147       */
7148      result = strcpy(rslt, path); /* FIX-ME */
7149    }
7150    else
7151      result = strcpy(rslt, path);
7152
7153    return result;
7154 }
7155
7156
7157 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7158 static char *mp_do_tovmsspec
7159    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7160   static char __tovmsspec_retbuf[VMS_MAXRSS];
7161   char *rslt, *dirend;
7162   char *lastdot;
7163   char *vms_delim;
7164   register char *cp1;
7165   const char *cp2;
7166   unsigned long int infront = 0, hasdir = 1;
7167   int rslt_len;
7168   int no_type_seen;
7169   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7170   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7171
7172   if (path == NULL) return NULL;
7173   rslt_len = VMS_MAXRSS-1;
7174   if (buf) rslt = buf;
7175   else if (ts) Newx(rslt, VMS_MAXRSS, char);
7176   else rslt = __tovmsspec_retbuf;
7177
7178   /* '.' and '..' are "[]" and "[-]" for a quick check */
7179   if (path[0] == '.') {
7180     if (path[1] == '\0') {
7181       strcpy(rslt,"[]");
7182       if (utf8_flag != NULL)
7183         *utf8_flag = 0;
7184       return rslt;
7185     }
7186     else {
7187       if (path[1] == '.' && path[2] == '\0') {
7188         strcpy(rslt,"[-]");
7189         if (utf8_flag != NULL)
7190            *utf8_flag = 0;
7191         return rslt;
7192       }
7193     }
7194   }
7195
7196    /* Posix specifications are now a native VMS format */
7197   /*--------------------------------------------------*/
7198 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7199   if (decc_posix_compliant_pathnames) {
7200     if (strncmp(path,"\"^UP^",5) == 0) {
7201       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7202       return rslt;
7203     }
7204   }
7205 #endif
7206
7207   /* This is really the only way to see if this is already in VMS format */
7208   sts = vms_split_path
7209        (path,
7210         &v_spec,
7211         &v_len,
7212         &r_spec,
7213         &r_len,
7214         &d_spec,
7215         &d_len,
7216         &n_spec,
7217         &n_len,
7218         &e_spec,
7219         &e_len,
7220         &vs_spec,
7221         &vs_len);
7222   if (sts == 0) {
7223     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7224        replacement, because the above parse just took care of most of
7225        what is needed to do vmspath when the specification is already
7226        in VMS format.
7227
7228        And if it is not already, it is easier to do the conversion as
7229        part of this routine than to call this routine and then work on
7230        the result.
7231      */
7232
7233     /* If VMS punctuation was found, it is already VMS format */
7234     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7235       if (utf8_flag != NULL)
7236         *utf8_flag = 0;
7237       strcpy(rslt, path);
7238       return rslt;
7239     }
7240     /* Now, what to do with trailing "." cases where there is no
7241        extension?  If this is a UNIX specification, and EFS characters
7242        are enabled, then the trailing "." should be converted to a "^.".
7243        But if this was already a VMS specification, then it should be
7244        left alone.
7245
7246        So in the case of ambiguity, leave the specification alone.
7247      */
7248
7249
7250     /* If there is a possibility of UTF8, then if any UTF8 characters
7251         are present, then they must be converted to VTF-7
7252      */
7253     if (utf8_flag != NULL)
7254       *utf8_flag = 0;
7255     strcpy(rslt, path);
7256     return rslt;
7257   }
7258
7259   dirend = strrchr(path,'/');
7260
7261   if (dirend == NULL) {
7262      /* If we get here with no UNIX directory delimiters, then this is
7263         not a complete file specification, either garbage a UNIX glob
7264         specification that can not be converted to a VMS wildcard, or
7265         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7266         so apparently other programs expect this also.
7267
7268         utf8 flag setting needs to be preserved.
7269       */
7270       strcpy(rslt, path);
7271       return rslt;
7272   }
7273
7274 /* If POSIX mode active, handle the conversion */
7275 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7276   if (decc_efs_charset) {
7277     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7278     return rslt;
7279   }
7280 #endif
7281
7282   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7283     if (!*(dirend+2)) dirend +=2;
7284     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7285     if (decc_efs_charset == 0) {
7286       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7287     }
7288   }
7289
7290   cp1 = rslt;
7291   cp2 = path;
7292   lastdot = strrchr(cp2,'.');
7293   if (*cp2 == '/') {
7294     char *trndev;
7295     int islnm, rooted;
7296     STRLEN trnend;
7297
7298     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7299     if (!*(cp2+1)) {
7300       if (decc_disable_posix_root) {
7301         strcpy(rslt,"sys$disk:[000000]");
7302       }
7303       else {
7304         strcpy(rslt,"sys$posix_root:[000000]");
7305       }
7306       if (utf8_flag != NULL)
7307         *utf8_flag = 0;
7308       return rslt;
7309     }
7310     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7311     *cp1 = '\0';
7312     trndev = PerlMem_malloc(VMS_MAXRSS);
7313     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7314     islnm =  my_trnlnm(rslt,trndev,0);
7315
7316      /* DECC special handling */
7317     if (!islnm) {
7318       if (strcmp(rslt,"bin") == 0) {
7319         strcpy(rslt,"sys$system");
7320         cp1 = rslt + 10;
7321         *cp1 = 0;
7322         islnm =  my_trnlnm(rslt,trndev,0);
7323       }
7324       else if (strcmp(rslt,"tmp") == 0) {
7325         strcpy(rslt,"sys$scratch");
7326         cp1 = rslt + 11;
7327         *cp1 = 0;
7328         islnm =  my_trnlnm(rslt,trndev,0);
7329       }
7330       else if (!decc_disable_posix_root) {
7331         strcpy(rslt, "sys$posix_root");
7332         cp1 = rslt + 13;
7333         *cp1 = 0;
7334         cp2 = path;
7335         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7336         islnm =  my_trnlnm(rslt,trndev,0);
7337       }
7338       else if (strcmp(rslt,"dev") == 0) {
7339         if (strncmp(cp2,"/null", 5) == 0) {
7340           if ((cp2[5] == 0) || (cp2[5] == '/')) {
7341             strcpy(rslt,"NLA0");
7342             cp1 = rslt + 4;
7343             *cp1 = 0;
7344             cp2 = cp2 + 5;
7345             islnm =  my_trnlnm(rslt,trndev,0);
7346           }
7347         }
7348       }
7349     }
7350
7351     trnend = islnm ? strlen(trndev) - 1 : 0;
7352     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7353     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7354     /* If the first element of the path is a logical name, determine
7355      * whether it has to be translated so we can add more directories. */
7356     if (!islnm || rooted) {
7357       *(cp1++) = ':';
7358       *(cp1++) = '[';
7359       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7360       else cp2++;
7361     }
7362     else {
7363       if (cp2 != dirend) {
7364         strcpy(rslt,trndev);
7365         cp1 = rslt + trnend;
7366         if (*cp2 != 0) {
7367           *(cp1++) = '.';
7368           cp2++;
7369         }
7370       }
7371       else {
7372         if (decc_disable_posix_root) {
7373           *(cp1++) = ':';
7374           hasdir = 0;
7375         }
7376       }
7377     }
7378     PerlMem_free(trndev);
7379   }
7380   else {
7381     *(cp1++) = '[';
7382     if (*cp2 == '.') {
7383       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7384         cp2 += 2;         /* skip over "./" - it's redundant */
7385         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
7386       }
7387       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7388         *(cp1++) = '-';                                 /* "../" --> "-" */
7389         cp2 += 3;
7390       }
7391       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7392                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7393         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7394         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7395         cp2 += 4;
7396       }
7397       else if ((cp2 != lastdot) || (lastdot < dirend)) {
7398         /* Escape the extra dots in EFS file specifications */
7399         *(cp1++) = '^';
7400       }
7401       if (cp2 > dirend) cp2 = dirend;
7402     }
7403     else *(cp1++) = '.';
7404   }
7405   for (; cp2 < dirend; cp2++) {
7406     if (*cp2 == '/') {
7407       if (*(cp2-1) == '/') continue;
7408       if (*(cp1-1) != '.') *(cp1++) = '.';
7409       infront = 0;
7410     }
7411     else if (!infront && *cp2 == '.') {
7412       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7413       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
7414       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7415         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7416         else if (*(cp1-2) == '[') *(cp1-1) = '-';
7417         else {  /* back up over previous directory name */
7418           cp1--;
7419           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7420           if (*(cp1-1) == '[') {
7421             memcpy(cp1,"000000.",7);
7422             cp1 += 7;
7423           }
7424         }
7425         cp2 += 2;
7426         if (cp2 == dirend) break;
7427       }
7428       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7429                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7430         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7431         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7432         if (!*(cp2+3)) {
7433           *(cp1++) = '.';  /* Simulate trailing '/' */
7434           cp2 += 2;  /* for loop will incr this to == dirend */
7435         }
7436         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
7437       }
7438       else {
7439         if (decc_efs_charset == 0)
7440           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
7441         else {
7442           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
7443           *(cp1++) = '.';
7444         }
7445       }
7446     }
7447     else {
7448       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
7449       if (*cp2 == '.') {
7450         if (decc_efs_charset == 0)
7451           *(cp1++) = '_';
7452         else {
7453           *(cp1++) = '^';
7454           *(cp1++) = '.';
7455         }
7456       }
7457       else                  *(cp1++) =  *cp2;
7458       infront = 1;
7459     }
7460   }
7461   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7462   if (hasdir) *(cp1++) = ']';
7463   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
7464   /* fixme for ODS5 */
7465   no_type_seen = 0;
7466   if (cp2 > lastdot)
7467     no_type_seen = 1;
7468   while (*cp2) {
7469     switch(*cp2) {
7470     case '?':
7471         if (decc_efs_charset == 0)
7472           *(cp1++) = '%';
7473         else
7474           *(cp1++) = '?';
7475         cp2++;
7476     case ' ':
7477         *(cp1)++ = '^';
7478         *(cp1)++ = '_';
7479         cp2++;
7480         break;
7481     case '.':
7482         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7483             decc_readdir_dropdotnotype) {
7484           *(cp1)++ = '^';
7485           *(cp1)++ = '.';
7486           cp2++;
7487
7488           /* trailing dot ==> '^..' on VMS */
7489           if (*cp2 == '\0') {
7490             *(cp1++) = '.';
7491             no_type_seen = 0;
7492           }
7493         }
7494         else {
7495           *(cp1++) = *(cp2++);
7496           no_type_seen = 0;
7497         }
7498         break;
7499     case '$':
7500          /* This could be a macro to be passed through */
7501         *(cp1++) = *(cp2++);
7502         if (*cp2 == '(') {
7503         const char * save_cp2;
7504         char * save_cp1;
7505         int is_macro;
7506
7507             /* paranoid check */
7508             save_cp2 = cp2;
7509             save_cp1 = cp1;
7510             is_macro = 0;
7511
7512             /* Test through */
7513             *(cp1++) = *(cp2++);
7514             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7515                 *(cp1++) = *(cp2++);
7516                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7517                     *(cp1++) = *(cp2++);
7518                 }
7519                 if (*cp2 == ')') {
7520                     *(cp1++) = *(cp2++);
7521                     is_macro = 1;
7522                 }
7523             }
7524             if (is_macro == 0) {
7525                 /* Not really a macro - never mind */
7526                 cp2 = save_cp2;
7527                 cp1 = save_cp1;
7528             }
7529         }
7530         break;
7531     case '\"':
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         *(cp1++) = '^';
7555         *(cp1++) = *(cp2++);
7556         break;
7557     case ';':
7558         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7559          * which is wrong.  UNIX notation should be ".dir." unless
7560          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7561          * changing this behavior could break more things at this time.
7562          * efs character set effectively does not allow "." to be a version
7563          * delimiter as a further complication about changing this.
7564          */
7565         if (decc_filename_unix_report != 0) {
7566           *(cp1++) = '^';
7567         }
7568         *(cp1++) = *(cp2++);
7569         break;
7570     default:
7571         *(cp1++) = *(cp2++);
7572     }
7573   }
7574   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7575   char *lcp1;
7576     lcp1 = cp1;
7577     lcp1--;
7578      /* Fix me for "^]", but that requires making sure that you do
7579       * not back up past the start of the filename
7580       */
7581     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7582       *cp1++ = '.';
7583   }
7584   *cp1 = '\0';
7585
7586   if (utf8_flag != NULL)
7587     *utf8_flag = 0;
7588   return rslt;
7589
7590 }  /* end of do_tovmsspec() */
7591 /*}}}*/
7592 /* External entry points */
7593 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7594   { return do_tovmsspec(path,buf,0,NULL); }
7595 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7596   { return do_tovmsspec(path,buf,1,NULL); }
7597 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7598   { return do_tovmsspec(path,buf,0,utf8_fl); }
7599 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7600   { return do_tovmsspec(path,buf,1,utf8_fl); }
7601
7602 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7603 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7604   static char __tovmspath_retbuf[VMS_MAXRSS];
7605   int vmslen;
7606   char *pathified, *vmsified, *cp;
7607
7608   if (path == NULL) return NULL;
7609   pathified = PerlMem_malloc(VMS_MAXRSS);
7610   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7611   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7612     PerlMem_free(pathified);
7613     return NULL;
7614   }
7615
7616   vmsified = NULL;
7617   if (buf == NULL)
7618      Newx(vmsified, VMS_MAXRSS, char);
7619   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7620     PerlMem_free(pathified);
7621     if (vmsified) Safefree(vmsified);
7622     return NULL;
7623   }
7624   PerlMem_free(pathified);
7625   if (buf) {
7626     return buf;
7627   }
7628   else if (ts) {
7629     vmslen = strlen(vmsified);
7630     Newx(cp,vmslen+1,char);
7631     memcpy(cp,vmsified,vmslen);
7632     cp[vmslen] = '\0';
7633     Safefree(vmsified);
7634     return cp;
7635   }
7636   else {
7637     strcpy(__tovmspath_retbuf,vmsified);
7638     Safefree(vmsified);
7639     return __tovmspath_retbuf;
7640   }
7641
7642 }  /* end of do_tovmspath() */
7643 /*}}}*/
7644 /* External entry points */
7645 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7646   { return do_tovmspath(path,buf,0, NULL); }
7647 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7648   { return do_tovmspath(path,buf,1, NULL); }
7649 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7650   { return do_tovmspath(path,buf,0,utf8_fl); }
7651 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7652   { return do_tovmspath(path,buf,1,utf8_fl); }
7653
7654
7655 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7656 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7657   static char __tounixpath_retbuf[VMS_MAXRSS];
7658   int unixlen;
7659   char *pathified, *unixified, *cp;
7660
7661   if (path == NULL) return NULL;
7662   pathified = PerlMem_malloc(VMS_MAXRSS);
7663   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7664   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7665     PerlMem_free(pathified);
7666     return NULL;
7667   }
7668
7669   unixified = NULL;
7670   if (buf == NULL) {
7671       Newx(unixified, VMS_MAXRSS, char);
7672   }
7673   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7674     PerlMem_free(pathified);
7675     if (unixified) Safefree(unixified);
7676     return NULL;
7677   }
7678   PerlMem_free(pathified);
7679   if (buf) {
7680     return buf;
7681   }
7682   else if (ts) {
7683     unixlen = strlen(unixified);
7684     Newx(cp,unixlen+1,char);
7685     memcpy(cp,unixified,unixlen);
7686     cp[unixlen] = '\0';
7687     Safefree(unixified);
7688     return cp;
7689   }
7690   else {
7691     strcpy(__tounixpath_retbuf,unixified);
7692     Safefree(unixified);
7693     return __tounixpath_retbuf;
7694   }
7695
7696 }  /* end of do_tounixpath() */
7697 /*}}}*/
7698 /* External entry points */
7699 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7700   { return do_tounixpath(path,buf,0,NULL); }
7701 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7702   { return do_tounixpath(path,buf,1,NULL); }
7703 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7704   { return do_tounixpath(path,buf,0,utf8_fl); }
7705 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7706   { return do_tounixpath(path,buf,1,utf8_fl); }
7707
7708 /*
7709  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
7710  *
7711  *****************************************************************************
7712  *                                                                           *
7713  *  Copyright (C) 1989-1994 by                                               *
7714  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
7715  *                                                                           *
7716  *  Permission is hereby  granted for the reproduction of this software,     *
7717  *  on condition that this copyright notice is included in the reproduction, *
7718  *  and that such reproduction is not for purposes of profit or material     *
7719  *  gain.                                                                    *
7720  *                                                                           *
7721  *  27-Aug-1994 Modified for inclusion in perl5                              *
7722  *              by Charles Bailey  bailey@newman.upenn.edu                   *
7723  *****************************************************************************
7724  */
7725
7726 /*
7727  * getredirection() is intended to aid in porting C programs
7728  * to VMS (Vax-11 C).  The native VMS environment does not support
7729  * '>' and '<' I/O redirection, or command line wild card expansion,
7730  * or a command line pipe mechanism using the '|' AND background
7731  * command execution '&'.  All of these capabilities are provided to any
7732  * C program which calls this procedure as the first thing in the
7733  * main program.
7734  * The piping mechanism will probably work with almost any 'filter' type
7735  * of program.  With suitable modification, it may useful for other
7736  * portability problems as well.
7737  *
7738  * Author:  Mark Pizzolato      mark@infocomm.com
7739  */
7740 struct list_item
7741     {
7742     struct list_item *next;
7743     char *value;
7744     };
7745
7746 static void add_item(struct list_item **head,
7747                      struct list_item **tail,
7748                      char *value,
7749                      int *count);
7750
7751 static void mp_expand_wild_cards(pTHX_ char *item,
7752                                 struct list_item **head,
7753                                 struct list_item **tail,
7754                                 int *count);
7755
7756 static int background_process(pTHX_ int argc, char **argv);
7757
7758 static void pipe_and_fork(pTHX_ char **cmargv);
7759
7760 /*{{{ void getredirection(int *ac, char ***av)*/
7761 static void
7762 mp_getredirection(pTHX_ int *ac, char ***av)
7763 /*
7764  * Process vms redirection arg's.  Exit if any error is seen.
7765  * If getredirection() processes an argument, it is erased
7766  * from the vector.  getredirection() returns a new argc and argv value.
7767  * In the event that a background command is requested (by a trailing "&"),
7768  * this routine creates a background subprocess, and simply exits the program.
7769  *
7770  * Warning: do not try to simplify the code for vms.  The code
7771  * presupposes that getredirection() is called before any data is
7772  * read from stdin or written to stdout.
7773  *
7774  * Normal usage is as follows:
7775  *
7776  *      main(argc, argv)
7777  *      int             argc;
7778  *      char            *argv[];
7779  *      {
7780  *              getredirection(&argc, &argv);
7781  *      }
7782  */
7783 {
7784     int                 argc = *ac;     /* Argument Count         */
7785     char                **argv = *av;   /* Argument Vector        */
7786     char                *ap;            /* Argument pointer       */
7787     int                 j;              /* argv[] index           */
7788     int                 item_count = 0; /* Count of Items in List */
7789     struct list_item    *list_head = 0; /* First Item in List       */
7790     struct list_item    *list_tail;     /* Last Item in List        */
7791     char                *in = NULL;     /* Input File Name          */
7792     char                *out = NULL;    /* Output File Name         */
7793     char                *outmode = "w"; /* Mode to Open Output File */
7794     char                *err = NULL;    /* Error File Name          */
7795     char                *errmode = "w"; /* Mode to Open Error File  */
7796     int                 cmargc = 0;     /* Piped Command Arg Count  */
7797     char                **cmargv = NULL;/* Piped Command Arg Vector */
7798
7799     /*
7800      * First handle the case where the last thing on the line ends with
7801      * a '&'.  This indicates the desire for the command to be run in a
7802      * subprocess, so we satisfy that desire.
7803      */
7804     ap = argv[argc-1];
7805     if (0 == strcmp("&", ap))
7806        exit(background_process(aTHX_ --argc, argv));
7807     if (*ap && '&' == ap[strlen(ap)-1])
7808         {
7809         ap[strlen(ap)-1] = '\0';
7810        exit(background_process(aTHX_ argc, argv));
7811         }
7812     /*
7813      * Now we handle the general redirection cases that involve '>', '>>',
7814      * '<', and pipes '|'.
7815      */
7816     for (j = 0; j < argc; ++j)
7817         {
7818         if (0 == strcmp("<", argv[j]))
7819             {
7820             if (j+1 >= argc)
7821                 {
7822                 fprintf(stderr,"No input file after < on command line");
7823                 exit(LIB$_WRONUMARG);
7824                 }
7825             in = argv[++j];
7826             continue;
7827             }
7828         if ('<' == *(ap = argv[j]))
7829             {
7830             in = 1 + ap;
7831             continue;
7832             }
7833         if (0 == strcmp(">", ap))
7834             {
7835             if (j+1 >= argc)
7836                 {
7837                 fprintf(stderr,"No output file after > on command line");
7838                 exit(LIB$_WRONUMARG);
7839                 }
7840             out = argv[++j];
7841             continue;
7842             }
7843         if ('>' == *ap)
7844             {
7845             if ('>' == ap[1])
7846                 {
7847                 outmode = "a";
7848                 if ('\0' == ap[2])
7849                     out = argv[++j];
7850                 else
7851                     out = 2 + ap;
7852                 }
7853             else
7854                 out = 1 + ap;
7855             if (j >= argc)
7856                 {
7857                 fprintf(stderr,"No output file after > or >> on command line");
7858                 exit(LIB$_WRONUMARG);
7859                 }
7860             continue;
7861             }
7862         if (('2' == *ap) && ('>' == ap[1]))
7863             {
7864             if ('>' == ap[2])
7865                 {
7866                 errmode = "a";
7867                 if ('\0' == ap[3])
7868                     err = argv[++j];
7869                 else
7870                     err = 3 + ap;
7871                 }
7872             else
7873                 if ('\0' == ap[2])
7874                     err = argv[++j];
7875                 else
7876                     err = 2 + ap;
7877             if (j >= argc)
7878                 {
7879                 fprintf(stderr,"No output file after 2> or 2>> on command line");
7880                 exit(LIB$_WRONUMARG);
7881                 }
7882             continue;
7883             }
7884         if (0 == strcmp("|", argv[j]))
7885             {
7886             if (j+1 >= argc)
7887                 {
7888                 fprintf(stderr,"No command into which to pipe on command line");
7889                 exit(LIB$_WRONUMARG);
7890                 }
7891             cmargc = argc-(j+1);
7892             cmargv = &argv[j+1];
7893             argc = j;
7894             continue;
7895             }
7896         if ('|' == *(ap = argv[j]))
7897             {
7898             ++argv[j];
7899             cmargc = argc-j;
7900             cmargv = &argv[j];
7901             argc = j;
7902             continue;
7903             }
7904         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7905         }
7906     /*
7907      * Allocate and fill in the new argument vector, Some Unix's terminate
7908      * the list with an extra null pointer.
7909      */
7910     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7911     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7912     *av = argv;
7913     for (j = 0; j < item_count; ++j, list_head = list_head->next)
7914         argv[j] = list_head->value;
7915     *ac = item_count;
7916     if (cmargv != NULL)
7917         {
7918         if (out != NULL)
7919             {
7920             fprintf(stderr,"'|' and '>' may not both be specified on command line");
7921             exit(LIB$_INVARGORD);
7922             }
7923         pipe_and_fork(aTHX_ cmargv);
7924         }
7925
7926     /* Check for input from a pipe (mailbox) */
7927
7928     if (in == NULL && 1 == isapipe(0))
7929         {
7930         char mbxname[L_tmpnam];
7931         long int bufsize;
7932         long int dvi_item = DVI$_DEVBUFSIZ;
7933         $DESCRIPTOR(mbxnam, "");
7934         $DESCRIPTOR(mbxdevnam, "");
7935
7936         /* Input from a pipe, reopen it in binary mode to disable       */
7937         /* carriage control processing.                                 */
7938
7939         fgetname(stdin, mbxname);
7940         mbxnam.dsc$a_pointer = mbxname;
7941         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7942         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7943         mbxdevnam.dsc$a_pointer = mbxname;
7944         mbxdevnam.dsc$w_length = sizeof(mbxname);
7945         dvi_item = DVI$_DEVNAM;
7946         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7947         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7948         set_errno(0);
7949         set_vaxc_errno(1);
7950         freopen(mbxname, "rb", stdin);
7951         if (errno != 0)
7952             {
7953             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7954             exit(vaxc$errno);
7955             }
7956         }
7957     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7958         {
7959         fprintf(stderr,"Can't open input file %s as stdin",in);
7960         exit(vaxc$errno);
7961         }
7962     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7963         {
7964         fprintf(stderr,"Can't open output file %s as stdout",out);
7965         exit(vaxc$errno);
7966         }
7967         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7968
7969     if (err != NULL) {
7970         if (strcmp(err,"&1") == 0) {
7971             dup2(fileno(stdout), fileno(stderr));
7972             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7973         } else {
7974         FILE *tmperr;
7975         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7976             {
7977             fprintf(stderr,"Can't open error file %s as stderr",err);
7978             exit(vaxc$errno);
7979             }
7980             fclose(tmperr);
7981            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7982                 {
7983                 exit(vaxc$errno);
7984                 }
7985             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7986         }
7987         }
7988 #ifdef ARGPROC_DEBUG
7989     PerlIO_printf(Perl_debug_log, "Arglist:\n");
7990     for (j = 0; j < *ac;  ++j)
7991         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7992 #endif
7993    /* Clear errors we may have hit expanding wildcards, so they don't
7994       show up in Perl's $! later */
7995    set_errno(0); set_vaxc_errno(1);
7996 }  /* end of getredirection() */
7997 /*}}}*/
7998
7999 static void add_item(struct list_item **head,
8000                      struct list_item **tail,
8001                      char *value,
8002                      int *count)
8003 {
8004     if (*head == 0)
8005         {
8006         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8007         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8008         *tail = *head;
8009         }
8010     else {
8011         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8012         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8013         *tail = (*tail)->next;
8014         }
8015     (*tail)->value = value;
8016     ++(*count);
8017 }
8018
8019 static void mp_expand_wild_cards(pTHX_ char *item,
8020                               struct list_item **head,
8021                               struct list_item **tail,
8022                               int *count)
8023 {
8024 int expcount = 0;
8025 unsigned long int context = 0;
8026 int isunix = 0;
8027 int item_len = 0;
8028 char *had_version;
8029 char *had_device;
8030 int had_directory;
8031 char *devdir,*cp;
8032 char *vmsspec;
8033 $DESCRIPTOR(filespec, "");
8034 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8035 $DESCRIPTOR(resultspec, "");
8036 unsigned long int lff_flags = 0;
8037 int sts;
8038 int rms_sts;
8039
8040 #ifdef VMS_LONGNAME_SUPPORT
8041     lff_flags = LIB$M_FIL_LONG_NAMES;
8042 #endif
8043
8044     for (cp = item; *cp; cp++) {
8045         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8046         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8047     }
8048     if (!*cp || isspace(*cp))
8049         {
8050         add_item(head, tail, item, count);
8051         return;
8052         }
8053     else
8054         {
8055      /* "double quoted" wild card expressions pass as is */
8056      /* From DCL that means using e.g.:                  */
8057      /* perl program """perl.*"""                        */
8058      item_len = strlen(item);
8059      if ( '"' == *item && '"' == item[item_len-1] )
8060        {
8061        item++;
8062        item[item_len-2] = '\0';
8063        add_item(head, tail, item, count);
8064        return;
8065        }
8066      }
8067     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8068     resultspec.dsc$b_class = DSC$K_CLASS_D;
8069     resultspec.dsc$a_pointer = NULL;
8070     vmsspec = PerlMem_malloc(VMS_MAXRSS);
8071     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8072     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8073       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8074     if (!isunix || !filespec.dsc$a_pointer)
8075       filespec.dsc$a_pointer = item;
8076     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8077     /*
8078      * Only return version specs, if the caller specified a version
8079      */
8080     had_version = strchr(item, ';');
8081     /*
8082      * Only return device and directory specs, if the caller specifed either.
8083      */
8084     had_device = strchr(item, ':');
8085     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8086
8087     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8088                                  (&filespec, &resultspec, &context,
8089                                   &defaultspec, 0, &rms_sts, &lff_flags)))
8090         {
8091         char *string;
8092         char *c;
8093
8094         string = PerlMem_malloc(resultspec.dsc$w_length+1);
8095         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8096         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8097         string[resultspec.dsc$w_length] = '\0';
8098         if (NULL == had_version)
8099             *(strrchr(string, ';')) = '\0';
8100         if ((!had_directory) && (had_device == NULL))
8101             {
8102             if (NULL == (devdir = strrchr(string, ']')))
8103                 devdir = strrchr(string, '>');
8104             strcpy(string, devdir + 1);
8105             }
8106         /*
8107          * Be consistent with what the C RTL has already done to the rest of
8108          * the argv items and lowercase all of these names.
8109          */
8110         if (!decc_efs_case_preserve) {
8111             for (c = string; *c; ++c)
8112             if (isupper(*c))
8113                 *c = tolower(*c);
8114         }
8115         if (isunix) trim_unixpath(string,item,1);
8116         add_item(head, tail, string, count);
8117         ++expcount;
8118     }
8119     PerlMem_free(vmsspec);
8120     if (sts != RMS$_NMF)
8121         {
8122         set_vaxc_errno(sts);
8123         switch (sts)
8124             {
8125             case RMS$_FNF: case RMS$_DNF:
8126                 set_errno(ENOENT); break;
8127             case RMS$_DIR:
8128                 set_errno(ENOTDIR); break;
8129             case RMS$_DEV:
8130                 set_errno(ENODEV); break;
8131             case RMS$_FNM: case RMS$_SYN:
8132                 set_errno(EINVAL); break;
8133             case RMS$_PRV:
8134                 set_errno(EACCES); break;
8135             default:
8136                 _ckvmssts_noperl(sts);
8137             }
8138         }
8139     if (expcount == 0)
8140         add_item(head, tail, item, count);
8141     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8142     _ckvmssts_noperl(lib$find_file_end(&context));
8143 }
8144
8145 static int child_st[2];/* Event Flag set when child process completes   */
8146
8147 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
8148
8149 static unsigned long int exit_handler(int *status)
8150 {
8151 short iosb[4];
8152
8153     if (0 == child_st[0])
8154         {
8155 #ifdef ARGPROC_DEBUG
8156         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8157 #endif
8158         fflush(stdout);     /* Have to flush pipe for binary data to    */
8159                             /* terminate properly -- <tp@mccall.com>    */
8160         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8161         sys$dassgn(child_chan);
8162         fclose(stdout);
8163         sys$synch(0, child_st);
8164         }
8165     return(1);
8166 }
8167
8168 static void sig_child(int chan)
8169 {
8170 #ifdef ARGPROC_DEBUG
8171     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8172 #endif
8173     if (child_st[0] == 0)
8174         child_st[0] = 1;
8175 }
8176
8177 static struct exit_control_block exit_block =
8178     {
8179     0,
8180     exit_handler,
8181     1,
8182     &exit_block.exit_status,
8183     0
8184     };
8185
8186 static void
8187 pipe_and_fork(pTHX_ char **cmargv)
8188 {
8189     PerlIO *fp;
8190     struct dsc$descriptor_s *vmscmd;
8191     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8192     int sts, j, l, ismcr, quote, tquote = 0;
8193
8194     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8195     vms_execfree(vmscmd);
8196
8197     j = l = 0;
8198     p = subcmd;
8199     q = cmargv[0];
8200     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
8201               && toupper(*(q+2)) == 'R' && !*(q+3);
8202
8203     while (q && l < MAX_DCL_LINE_LENGTH) {
8204         if (!*q) {
8205             if (j > 0 && quote) {
8206                 *p++ = '"';
8207                 l++;
8208             }
8209             q = cmargv[++j];
8210             if (q) {
8211                 if (ismcr && j > 1) quote = 1;
8212                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
8213                 *p++ = ' ';
8214                 l++;
8215                 if (quote || tquote) {
8216                     *p++ = '"';
8217                     l++;
8218                 }
8219             }
8220         } else {
8221             if ((quote||tquote) && *q == '"') {
8222                 *p++ = '"';
8223                 l++;
8224             }
8225             *p++ = *q++;
8226             l++;
8227         }
8228     }
8229     *p = '\0';
8230
8231     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8232     if (fp == Nullfp) {
8233         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8234     }
8235 }
8236
8237 static int background_process(pTHX_ int argc, char **argv)
8238 {
8239 char command[MAX_DCL_SYMBOL + 1] = "$";
8240 $DESCRIPTOR(value, "");
8241 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8242 static $DESCRIPTOR(null, "NLA0:");
8243 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8244 char pidstring[80];
8245 $DESCRIPTOR(pidstr, "");
8246 int pid;
8247 unsigned long int flags = 17, one = 1, retsts;
8248 int len;
8249
8250     strcat(command, argv[0]);
8251     len = strlen(command);
8252     while (--argc && (len < MAX_DCL_SYMBOL))
8253         {
8254         strcat(command, " \"");
8255         strcat(command, *(++argv));
8256         strcat(command, "\"");
8257         len = strlen(command);
8258         }
8259     value.dsc$a_pointer = command;
8260     value.dsc$w_length = strlen(value.dsc$a_pointer);
8261     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8262     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8263     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8264         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8265     }
8266     else {
8267         _ckvmssts_noperl(retsts);
8268     }
8269 #ifdef ARGPROC_DEBUG
8270     PerlIO_printf(Perl_debug_log, "%s\n", command);
8271 #endif
8272     sprintf(pidstring, "%08X", pid);
8273     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8274     pidstr.dsc$a_pointer = pidstring;
8275     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8276     lib$set_symbol(&pidsymbol, &pidstr);
8277     return(SS$_NORMAL);
8278 }
8279 /*}}}*/
8280 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8281
8282
8283 /* OS-specific initialization at image activation (not thread startup) */
8284 /* Older VAXC header files lack these constants */
8285 #ifndef JPI$_RIGHTS_SIZE
8286 #  define JPI$_RIGHTS_SIZE 817
8287 #endif
8288 #ifndef KGB$M_SUBSYSTEM
8289 #  define KGB$M_SUBSYSTEM 0x8
8290 #endif
8291
8292 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8293
8294 /*{{{void vms_image_init(int *, char ***)*/
8295 void
8296 vms_image_init(int *argcp, char ***argvp)
8297 {
8298   char eqv[LNM$C_NAMLENGTH+1] = "";
8299   unsigned int len, tabct = 8, tabidx = 0;
8300   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8301   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8302   unsigned short int dummy, rlen;
8303   struct dsc$descriptor_s **tabvec;
8304 #if defined(PERL_IMPLICIT_CONTEXT)
8305   pTHX = NULL;
8306 #endif
8307   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8308                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8309                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8310                                  {          0,                0,    0,      0} };
8311
8312 #ifdef KILL_BY_SIGPRC
8313     Perl_csighandler_init();
8314 #endif
8315
8316   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8317   _ckvmssts_noperl(iosb[0]);
8318   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8319     if (iprv[i]) {           /* Running image installed with privs? */
8320       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8321       will_taint = TRUE;
8322       break;
8323     }
8324   }
8325   /* Rights identifiers might trigger tainting as well. */
8326   if (!will_taint && (rlen || rsz)) {
8327     while (rlen < rsz) {
8328       /* We didn't get all the identifiers on the first pass.  Allocate a
8329        * buffer much larger than $GETJPI wants (rsz is size in bytes that
8330        * were needed to hold all identifiers at time of last call; we'll
8331        * allocate that many unsigned long ints), and go back and get 'em.
8332        * If it gave us less than it wanted to despite ample buffer space,
8333        * something's broken.  Is your system missing a system identifier?
8334        */
8335       if (rsz <= jpilist[1].buflen) {
8336          /* Perl_croak accvios when used this early in startup. */
8337          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8338                          rsz, (unsigned long) jpilist[1].buflen,
8339                          "Check your rights database for corruption.\n");
8340          exit(SS$_ABORT);
8341       }
8342       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8343       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8344       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8345       jpilist[1].buflen = rsz * sizeof(unsigned long int);
8346       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8347       _ckvmssts_noperl(iosb[0]);
8348     }
8349     mask = jpilist[1].bufadr;
8350     /* Check attribute flags for each identifier (2nd longword); protected
8351      * subsystem identifiers trigger tainting.
8352      */
8353     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8354       if (mask[i] & KGB$M_SUBSYSTEM) {
8355         will_taint = TRUE;
8356         break;
8357       }
8358     }
8359     if (mask != rlst) PerlMem_free(mask);
8360   }
8361
8362   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8363    * logical, some versions of the CRTL will add a phanthom /000000/
8364    * directory.  This needs to be removed.
8365    */
8366   if (decc_filename_unix_report) {
8367   char * zeros;
8368   int ulen;
8369     ulen = strlen(argvp[0][0]);
8370     if (ulen > 7) {
8371       zeros = strstr(argvp[0][0], "/000000/");
8372       if (zeros != NULL) {
8373         int mlen;
8374         mlen = ulen - (zeros - argvp[0][0]) - 7;
8375         memmove(zeros, &zeros[7], mlen);
8376         ulen = ulen - 7;
8377         argvp[0][0][ulen] = '\0';
8378       }
8379     }
8380     /* It also may have a trailing dot that needs to be removed otherwise
8381      * it will be converted to VMS mode incorrectly.
8382      */
8383     ulen--;
8384     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8385       argvp[0][0][ulen] = '\0';
8386   }
8387
8388   /* We need to use this hack to tell Perl it should run with tainting,
8389    * since its tainting flag may be part of the PL_curinterp struct, which
8390    * hasn't been allocated when vms_image_init() is called.
8391    */
8392   if (will_taint) {
8393     char **newargv, **oldargv;
8394     oldargv = *argvp;
8395     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8396     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8397     newargv[0] = oldargv[0];
8398     newargv[1] = PerlMem_malloc(3 * sizeof(char));
8399     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8400     strcpy(newargv[1], "-T");
8401     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8402     (*argcp)++;
8403     newargv[*argcp] = NULL;
8404     /* We orphan the old argv, since we don't know where it's come from,
8405      * so we don't know how to free it.
8406      */
8407     *argvp = newargv;
8408   }
8409   else {  /* Did user explicitly request tainting? */
8410     int i;
8411     char *cp, **av = *argvp;
8412     for (i = 1; i < *argcp; i++) {
8413       if (*av[i] != '-') break;
8414       for (cp = av[i]+1; *cp; cp++) {
8415         if (*cp == 'T') { will_taint = 1; break; }
8416         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8417                   strchr("DFIiMmx",*cp)) break;
8418       }
8419       if (will_taint) break;
8420     }
8421   }
8422
8423   for (tabidx = 0;
8424        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8425        tabidx++) {
8426     if (!tabidx) {
8427       tabvec = (struct dsc$descriptor_s **)
8428             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8429       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8430     }
8431     else if (tabidx >= tabct) {
8432       tabct += 8;
8433       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8434       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8435     }
8436     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8437     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8438     tabvec[tabidx]->dsc$w_length  = 0;
8439     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
8440     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
8441     tabvec[tabidx]->dsc$a_pointer = NULL;
8442     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8443   }
8444   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8445
8446   getredirection(argcp,argvp);
8447 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8448   {
8449 # include <reentrancy.h>
8450   decc$set_reentrancy(C$C_MULTITHREAD);
8451   }
8452 #endif
8453   return;
8454 }
8455 /*}}}*/
8456
8457
8458 /* trim_unixpath()
8459  * Trim Unix-style prefix off filespec, so it looks like what a shell
8460  * glob expansion would return (i.e. from specified prefix on, not
8461  * full path).  Note that returned filespec is Unix-style, regardless
8462  * of whether input filespec was VMS-style or Unix-style.
8463  *
8464  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8465  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
8466  * vector of options; at present, only bit 0 is used, and if set tells
8467  * trim unixpath to try the current default directory as a prefix when
8468  * presented with a possibly ambiguous ... wildcard.
8469  *
8470  * Returns !=0 on success, with trimmed filespec replacing contents of
8471  * fspec, and 0 on failure, with contents of fpsec unchanged.
8472  */
8473 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8474 int
8475 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8476 {
8477   char *unixified, *unixwild,
8478        *template, *base, *end, *cp1, *cp2;
8479   register int tmplen, reslen = 0, dirs = 0;
8480
8481   unixwild = PerlMem_malloc(VMS_MAXRSS);
8482   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8483   if (!wildspec || !fspec) return 0;
8484   template = unixwild;
8485   if (strpbrk(wildspec,"]>:") != NULL) {
8486     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8487         PerlMem_free(unixwild);
8488         return 0;
8489     }
8490   }
8491   else {
8492     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8493     unixwild[VMS_MAXRSS-1] = 0;
8494   }
8495   unixified = PerlMem_malloc(VMS_MAXRSS);
8496   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8497   if (strpbrk(fspec,"]>:") != NULL) {
8498     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8499         PerlMem_free(unixwild);
8500         PerlMem_free(unixified);
8501         return 0;
8502     }
8503     else base = unixified;
8504     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8505      * check to see that final result fits into (isn't longer than) fspec */
8506     reslen = strlen(fspec);
8507   }
8508   else base = fspec;
8509
8510   /* No prefix or absolute path on wildcard, so nothing to remove */
8511   if (!*template || *template == '/') {
8512     PerlMem_free(unixwild);
8513     if (base == fspec) {
8514         PerlMem_free(unixified);
8515         return 1;
8516     }
8517     tmplen = strlen(unixified);
8518     if (tmplen > reslen) {
8519         PerlMem_free(unixified);
8520         return 0;  /* not enough space */
8521     }
8522     /* Copy unixified resultant, including trailing NUL */
8523     memmove(fspec,unixified,tmplen+1);
8524     PerlMem_free(unixified);
8525     return 1;
8526   }
8527
8528   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
8529   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8530     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8531     for (cp1 = end ;cp1 >= base; cp1--)
8532       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8533         { cp1++; break; }
8534     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8535     PerlMem_free(unixified);
8536     PerlMem_free(unixwild);
8537     return 1;
8538   }
8539   else {
8540     char *tpl, *lcres;
8541     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8542     int ells = 1, totells, segdirs, match;
8543     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8544                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8545
8546     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8547     totells = ells;
8548     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8549     tpl = PerlMem_malloc(VMS_MAXRSS);
8550     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8551     if (ellipsis == template && opts & 1) {
8552       /* Template begins with an ellipsis.  Since we can't tell how many
8553        * directory names at the front of the resultant to keep for an
8554        * arbitrary starting point, we arbitrarily choose the current
8555        * default directory as a starting point.  If it's there as a prefix,
8556        * clip it off.  If not, fall through and act as if the leading
8557        * ellipsis weren't there (i.e. return shortest possible path that
8558        * could match template).
8559        */
8560       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8561           PerlMem_free(tpl);
8562           PerlMem_free(unixified);
8563           PerlMem_free(unixwild);
8564           return 0;
8565       }
8566       if (!decc_efs_case_preserve) {
8567         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8568           if (_tolower(*cp1) != _tolower(*cp2)) break;
8569       }
8570       segdirs = dirs - totells;  /* Min # of dirs we must have left */
8571       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8572       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8573         memmove(fspec,cp2+1,end - cp2);
8574         PerlMem_free(tpl);
8575         PerlMem_free(unixified);
8576         PerlMem_free(unixwild);
8577         return 1;
8578       }
8579     }
8580     /* First off, back up over constant elements at end of path */
8581     if (dirs) {
8582       for (front = end ; front >= base; front--)
8583          if (*front == '/' && !dirs--) { front++; break; }
8584     }
8585     lcres = PerlMem_malloc(VMS_MAXRSS);
8586     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8587     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8588          cp1++,cp2++) {
8589             if (!decc_efs_case_preserve) {
8590                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
8591             }
8592             else {
8593                 *cp2 = *cp1;
8594             }
8595     }
8596     if (cp1 != '\0') {
8597         PerlMem_free(tpl);
8598         PerlMem_free(unixified);
8599         PerlMem_free(unixwild);
8600         PerlMem_free(lcres);
8601         return 0;  /* Path too long. */
8602     }
8603     lcend = cp2;
8604     *cp2 = '\0';  /* Pick up with memcpy later */
8605     lcfront = lcres + (front - base);
8606     /* Now skip over each ellipsis and try to match the path in front of it. */
8607     while (ells--) {
8608       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8609         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
8610             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
8611       if (cp1 < template) break; /* template started with an ellipsis */
8612       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8613         ellipsis = cp1; continue;
8614       }
8615       wilddsc.dsc$a_pointer = tpl;
8616       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8617       nextell = cp1;
8618       for (segdirs = 0, cp2 = tpl;
8619            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8620            cp1++, cp2++) {
8621          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8622          else {
8623             if (!decc_efs_case_preserve) {
8624               *cp2 = _tolower(*cp1);  /* else lowercase for match */
8625             }
8626             else {
8627               *cp2 = *cp1;  /* else preserve case for match */
8628             }
8629          }
8630          if (*cp2 == '/') segdirs++;
8631       }
8632       if (cp1 != ellipsis - 1) {
8633           PerlMem_free(tpl);
8634           PerlMem_free(unixified);
8635           PerlMem_free(unixwild);
8636           PerlMem_free(lcres);
8637           return 0; /* Path too long */
8638       }
8639       /* Back up at least as many dirs as in template before matching */
8640       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8641         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8642       for (match = 0; cp1 > lcres;) {
8643         resdsc.dsc$a_pointer = cp1;
8644         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8645           match++;
8646           if (match == 1) lcfront = cp1;
8647         }
8648         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8649       }
8650       if (!match) {
8651         PerlMem_free(tpl);
8652         PerlMem_free(unixified);
8653         PerlMem_free(unixwild);
8654         PerlMem_free(lcres);
8655         return 0;  /* Can't find prefix ??? */
8656       }
8657       if (match > 1 && opts & 1) {
8658         /* This ... wildcard could cover more than one set of dirs (i.e.
8659          * a set of similar dir names is repeated).  If the template
8660          * contains more than 1 ..., upstream elements could resolve the
8661          * ambiguity, but it's not worth a full backtracking setup here.
8662          * As a quick heuristic, clip off the current default directory
8663          * if it's present to find the trimmed spec, else use the
8664          * shortest string that this ... could cover.
8665          */
8666         char def[NAM$C_MAXRSS+1], *st;
8667
8668         if (getcwd(def, sizeof def,0) == NULL) {
8669             Safefree(unixified);
8670             Safefree(unixwild);
8671             Safefree(lcres);
8672             Safefree(tpl);
8673             return 0;
8674         }
8675         if (!decc_efs_case_preserve) {
8676           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8677             if (_tolower(*cp1) != _tolower(*cp2)) break;
8678         }
8679         segdirs = dirs - totells;  /* Min # of dirs we must have left */
8680         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8681         if (*cp1 == '\0' && *cp2 == '/') {
8682           memmove(fspec,cp2+1,end - cp2);
8683           PerlMem_free(tpl);
8684           PerlMem_free(unixified);
8685           PerlMem_free(unixwild);
8686           PerlMem_free(lcres);
8687           return 1;
8688         }
8689         /* Nope -- stick with lcfront from above and keep going. */
8690       }
8691     }
8692     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8693     PerlMem_free(tpl);
8694     PerlMem_free(unixified);
8695     PerlMem_free(unixwild);
8696     PerlMem_free(lcres);
8697     return 1;
8698     ellipsis = nextell;
8699   }
8700
8701 }  /* end of trim_unixpath() */
8702 /*}}}*/
8703
8704
8705 /*
8706  *  VMS readdir() routines.
8707  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8708  *
8709  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
8710  *  Minor modifications to original routines.
8711  */
8712
8713 /* readdir may have been redefined by reentr.h, so make sure we get
8714  * the local version for what we do here.
8715  */
8716 #ifdef readdir
8717 # undef readdir
8718 #endif
8719 #if !defined(PERL_IMPLICIT_CONTEXT)
8720 # define readdir Perl_readdir
8721 #else
8722 # define readdir(a) Perl_readdir(aTHX_ a)
8723 #endif
8724
8725     /* Number of elements in vms_versions array */
8726 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
8727
8728 /*
8729  *  Open a directory, return a handle for later use.
8730  */
8731 /*{{{ DIR *opendir(char*name) */
8732 DIR *
8733 Perl_opendir(pTHX_ const char *name)
8734 {
8735     DIR *dd;
8736     char *dir;
8737     Stat_t sb;
8738     int unix_flag;
8739
8740     unix_flag = 0;
8741     if (decc_efs_charset) {
8742         unix_flag = is_unix_filespec(name);
8743     }
8744
8745     Newx(dir, VMS_MAXRSS, char);
8746     if (do_tovmspath(name,dir,0,NULL) == NULL) {
8747       Safefree(dir);
8748       return NULL;
8749     }
8750     /* Check access before stat; otherwise stat does not
8751      * accurately report whether it's a directory.
8752      */
8753     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8754       /* cando_by_name has already set errno */
8755       Safefree(dir);
8756       return NULL;
8757     }
8758     if (flex_stat(dir,&sb) == -1) return NULL;
8759     if (!S_ISDIR(sb.st_mode)) {
8760       Safefree(dir);
8761       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
8762       return NULL;
8763     }
8764     /* Get memory for the handle, and the pattern. */
8765     Newx(dd,1,DIR);
8766     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8767
8768     /* Fill in the fields; mainly playing with the descriptor. */
8769     sprintf(dd->pattern, "%s*.*",dir);
8770     Safefree(dir);
8771     dd->context = 0;
8772     dd->count = 0;
8773     dd->flags = 0;
8774     if (unix_flag)
8775         dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8776     dd->pat.dsc$a_pointer = dd->pattern;
8777     dd->pat.dsc$w_length = strlen(dd->pattern);
8778     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8779     dd->pat.dsc$b_class = DSC$K_CLASS_S;
8780 #if defined(USE_ITHREADS)
8781     Newx(dd->mutex,1,perl_mutex);
8782     MUTEX_INIT( (perl_mutex *) dd->mutex );
8783 #else
8784     dd->mutex = NULL;
8785 #endif
8786
8787     return dd;
8788 }  /* end of opendir() */
8789 /*}}}*/
8790
8791 /*
8792  *  Set the flag to indicate we want versions or not.
8793  */
8794 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8795 void
8796 vmsreaddirversions(DIR *dd, int flag)
8797 {
8798     if (flag)
8799         dd->flags |= PERL_VMSDIR_M_VERSIONS;
8800     else
8801         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8802 }
8803 /*}}}*/
8804
8805 /*
8806  *  Free up an opened directory.
8807  */
8808 /*{{{ void closedir(DIR *dd)*/
8809 void
8810 Perl_closedir(DIR *dd)
8811 {
8812     int sts;
8813
8814     sts = lib$find_file_end(&dd->context);
8815     Safefree(dd->pattern);
8816 #if defined(USE_ITHREADS)
8817     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8818     Safefree(dd->mutex);
8819 #endif
8820     Safefree(dd);
8821 }
8822 /*}}}*/
8823
8824 /*
8825  *  Collect all the version numbers for the current file.
8826  */
8827 static void
8828 collectversions(pTHX_ DIR *dd)
8829 {
8830     struct dsc$descriptor_s     pat;
8831     struct dsc$descriptor_s     res;
8832     struct dirent *e;
8833     char *p, *text, *buff;
8834     int i;
8835     unsigned long context, tmpsts;
8836
8837     /* Convenient shorthand. */
8838     e = &dd->entry;
8839
8840     /* Add the version wildcard, ignoring the "*.*" put on before */
8841     i = strlen(dd->pattern);
8842     Newx(text,i + e->d_namlen + 3,char);
8843     strcpy(text, dd->pattern);
8844     sprintf(&text[i - 3], "%s;*", e->d_name);
8845
8846     /* Set up the pattern descriptor. */
8847     pat.dsc$a_pointer = text;
8848     pat.dsc$w_length = i + e->d_namlen - 1;
8849     pat.dsc$b_dtype = DSC$K_DTYPE_T;
8850     pat.dsc$b_class = DSC$K_CLASS_S;
8851
8852     /* Set up result descriptor. */
8853     Newx(buff, VMS_MAXRSS, char);
8854     res.dsc$a_pointer = buff;
8855     res.dsc$w_length = VMS_MAXRSS - 1;
8856     res.dsc$b_dtype = DSC$K_DTYPE_T;
8857     res.dsc$b_class = DSC$K_CLASS_S;
8858
8859     /* Read files, collecting versions. */
8860     for (context = 0, e->vms_verscount = 0;
8861          e->vms_verscount < VERSIZE(e);
8862          e->vms_verscount++) {
8863         unsigned long rsts;
8864         unsigned long flags = 0;
8865
8866 #ifdef VMS_LONGNAME_SUPPORT
8867         flags = LIB$M_FIL_LONG_NAMES;
8868 #endif
8869         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8870         if (tmpsts == RMS$_NMF || context == 0) break;
8871         _ckvmssts(tmpsts);
8872         buff[VMS_MAXRSS - 1] = '\0';
8873         if ((p = strchr(buff, ';')))
8874             e->vms_versions[e->vms_verscount] = atoi(p + 1);
8875         else
8876             e->vms_versions[e->vms_verscount] = -1;
8877     }
8878
8879     _ckvmssts(lib$find_file_end(&context));
8880     Safefree(text);
8881     Safefree(buff);
8882
8883 }  /* end of collectversions() */
8884
8885 /*
8886  *  Read the next entry from the directory.
8887  */
8888 /*{{{ struct dirent *readdir(DIR *dd)*/
8889 struct dirent *
8890 Perl_readdir(pTHX_ DIR *dd)
8891 {
8892     struct dsc$descriptor_s     res;
8893     char *p, *buff;
8894     unsigned long int tmpsts;
8895     unsigned long rsts;
8896     unsigned long flags = 0;
8897     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8898     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8899
8900     /* Set up result descriptor, and get next file. */
8901     Newx(buff, VMS_MAXRSS, char);
8902     res.dsc$a_pointer = buff;
8903     res.dsc$w_length = VMS_MAXRSS - 1;
8904     res.dsc$b_dtype = DSC$K_DTYPE_T;
8905     res.dsc$b_class = DSC$K_CLASS_S;
8906
8907 #ifdef VMS_LONGNAME_SUPPORT
8908     flags = LIB$M_FIL_LONG_NAMES;
8909 #endif
8910
8911     tmpsts = lib$find_file
8912         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8913     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
8914     if (!(tmpsts & 1)) {
8915       set_vaxc_errno(tmpsts);
8916       switch (tmpsts) {
8917         case RMS$_PRV:
8918           set_errno(EACCES); break;
8919         case RMS$_DEV:
8920           set_errno(ENODEV); break;
8921         case RMS$_DIR:
8922           set_errno(ENOTDIR); break;
8923         case RMS$_FNF: case RMS$_DNF:
8924           set_errno(ENOENT); break;
8925         default:
8926           set_errno(EVMSERR);
8927       }
8928       Safefree(buff);
8929       return NULL;
8930     }
8931     dd->count++;
8932     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8933     if (!decc_efs_case_preserve) {
8934       buff[VMS_MAXRSS - 1] = '\0';
8935       for (p = buff; *p; p++) *p = _tolower(*p);
8936     }
8937     else {
8938       /* we don't want to force to lowercase, just null terminate */
8939       buff[res.dsc$w_length] = '\0';
8940     }
8941     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
8942     *p = '\0';
8943
8944     /* Skip any directory component and just copy the name. */
8945     sts = vms_split_path
8946        (buff,
8947         &v_spec,
8948         &v_len,
8949         &r_spec,
8950         &r_len,
8951         &d_spec,
8952         &d_len,
8953         &n_spec,
8954         &n_len,
8955         &e_spec,
8956         &e_len,
8957         &vs_spec,
8958         &vs_len);
8959
8960     /* Drop NULL extensions on UNIX file specification */
8961     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8962         (e_len == 1) && decc_readdir_dropdotnotype)) {
8963         e_len = 0;
8964         e_spec[0] = '\0';
8965     }
8966
8967     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8968     dd->entry.d_name[n_len + e_len] = '\0';
8969     dd->entry.d_namlen = strlen(dd->entry.d_name);
8970
8971     /* Convert the filename to UNIX format if needed */
8972     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8973
8974         /* Translate the encoded characters. */
8975         /* Fixme: unicode handling could result in embedded 0 characters */
8976         if (strchr(dd->entry.d_name, '^') != NULL) {
8977             char new_name[256];
8978             char * q;
8979             int cnt;
8980             p = dd->entry.d_name;
8981             q = new_name;
8982             while (*p != 0) {
8983                 int x, y;
8984                 x = copy_expand_vms_filename_escape(q, p, &y);
8985                 p += x;
8986                 q += y;
8987                 /* fix-me */
8988                 /* if y > 1, then this is a wide file specification */
8989                 /* Wide file specifications need to be passed in Perl */
8990                 /* counted strings apparently with a unicode flag */
8991             }
8992             *q = 0;
8993             strcpy(dd->entry.d_name, new_name);
8994         }
8995     }
8996
8997     dd->entry.vms_verscount = 0;
8998     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8999     Safefree(buff);
9000     return &dd->entry;
9001
9002 }  /* end of readdir() */
9003 /*}}}*/
9004
9005 /*
9006  *  Read the next entry from the directory -- thread-safe version.
9007  */
9008 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9009 int
9010 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9011 {
9012     int retval;
9013
9014     MUTEX_LOCK( (perl_mutex *) dd->mutex );
9015
9016     entry = readdir(dd);
9017     *result = entry;
9018     retval = ( *result == NULL ? errno : 0 );
9019
9020     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9021
9022     return retval;
9023
9024 }  /* end of readdir_r() */
9025 /*}}}*/
9026
9027 /*
9028  *  Return something that can be used in a seekdir later.
9029  */
9030 /*{{{ long telldir(DIR *dd)*/
9031 long
9032 Perl_telldir(DIR *dd)
9033 {
9034     return dd->count;
9035 }
9036 /*}}}*/
9037
9038 /*
9039  *  Return to a spot where we used to be.  Brute force.
9040  */
9041 /*{{{ void seekdir(DIR *dd,long count)*/
9042 void
9043 Perl_seekdir(pTHX_ DIR *dd, long count)
9044 {
9045     int old_flags;
9046
9047     /* If we haven't done anything yet... */
9048     if (dd->count == 0)
9049         return;
9050
9051     /* Remember some state, and clear it. */
9052     old_flags = dd->flags;
9053     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9054     _ckvmssts(lib$find_file_end(&dd->context));
9055     dd->context = 0;
9056
9057     /* The increment is in readdir(). */
9058     for (dd->count = 0; dd->count < count; )
9059         readdir(dd);
9060
9061     dd->flags = old_flags;
9062
9063 }  /* end of seekdir() */
9064 /*}}}*/
9065
9066 /* VMS subprocess management
9067  *
9068  * my_vfork() - just a vfork(), after setting a flag to record that
9069  * the current script is trying a Unix-style fork/exec.
9070  *
9071  * vms_do_aexec() and vms_do_exec() are called in response to the
9072  * perl 'exec' function.  If this follows a vfork call, then they
9073  * call out the regular perl routines in doio.c which do an
9074  * execvp (for those who really want to try this under VMS).
9075  * Otherwise, they do exactly what the perl docs say exec should
9076  * do - terminate the current script and invoke a new command
9077  * (See below for notes on command syntax.)
9078  *
9079  * do_aspawn() and do_spawn() implement the VMS side of the perl
9080  * 'system' function.
9081  *
9082  * Note on command arguments to perl 'exec' and 'system': When handled
9083  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9084  * are concatenated to form a DCL command string.  If the first arg
9085  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
9086  * the command string is handed off to DCL directly.  Otherwise,
9087  * the first token of the command is taken as the filespec of an image
9088  * to run.  The filespec is expanded using a default type of '.EXE' and
9089  * the process defaults for device, directory, etc., and if found, the resultant
9090  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9091  * the command string as parameters.  This is perhaps a bit complicated,
9092  * but I hope it will form a happy medium between what VMS folks expect
9093  * from lib$spawn and what Unix folks expect from exec.
9094  */
9095
9096 static int vfork_called;
9097
9098 /*{{{int my_vfork()*/
9099 int
9100 my_vfork()
9101 {
9102   vfork_called++;
9103   return vfork();
9104 }
9105 /*}}}*/
9106
9107
9108 static void
9109 vms_execfree(struct dsc$descriptor_s *vmscmd)
9110 {
9111   if (vmscmd) {
9112       if (vmscmd->dsc$a_pointer) {
9113           PerlMem_free(vmscmd->dsc$a_pointer);
9114       }
9115       PerlMem_free(vmscmd);
9116   }
9117 }
9118
9119 static char *
9120 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9121 {
9122   char *junk, *tmps = Nullch;
9123   register size_t cmdlen = 0;
9124   size_t rlen;
9125   register SV **idx;
9126   STRLEN n_a;
9127
9128   idx = mark;
9129   if (really) {
9130     tmps = SvPV(really,rlen);
9131     if (*tmps) {
9132       cmdlen += rlen + 1;
9133       idx++;
9134     }
9135   }
9136
9137   for (idx++; idx <= sp; idx++) {
9138     if (*idx) {
9139       junk = SvPVx(*idx,rlen);
9140       cmdlen += rlen ? rlen + 1 : 0;
9141     }
9142   }
9143   Newx(PL_Cmd, cmdlen+1, char);
9144
9145   if (tmps && *tmps) {
9146     strcpy(PL_Cmd,tmps);
9147     mark++;
9148   }
9149   else *PL_Cmd = '\0';
9150   while (++mark <= sp) {
9151     if (*mark) {
9152       char *s = SvPVx(*mark,n_a);
9153       if (!*s) continue;
9154       if (*PL_Cmd) strcat(PL_Cmd," ");
9155       strcat(PL_Cmd,s);
9156     }
9157   }
9158   return PL_Cmd;
9159
9160 }  /* end of setup_argstr() */
9161
9162
9163 static unsigned long int
9164 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9165                    struct dsc$descriptor_s **pvmscmd)
9166 {
9167   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9168   char image_name[NAM$C_MAXRSS+1];
9169   char image_argv[NAM$C_MAXRSS+1];
9170   $DESCRIPTOR(defdsc,".EXE");
9171   $DESCRIPTOR(defdsc2,".");
9172   $DESCRIPTOR(resdsc,resspec);
9173   struct dsc$descriptor_s *vmscmd;
9174   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9175   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9176   register char *s, *rest, *cp, *wordbreak;
9177   char * cmd;
9178   int cmdlen;
9179   register int isdcl;
9180
9181   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9182   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9183
9184   /* Make a copy for modification */
9185   cmdlen = strlen(incmd);
9186   cmd = PerlMem_malloc(cmdlen+1);
9187   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9188   strncpy(cmd, incmd, cmdlen);
9189   cmd[cmdlen] = 0;
9190   image_name[0] = 0;
9191   image_argv[0] = 0;
9192
9193   vmscmd->dsc$a_pointer = NULL;
9194   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
9195   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
9196   vmscmd->dsc$w_length = 0;
9197   if (pvmscmd) *pvmscmd = vmscmd;
9198
9199   if (suggest_quote) *suggest_quote = 0;
9200
9201   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9202     PerlMem_free(cmd);
9203     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
9204   }
9205
9206   s = cmd;
9207
9208   while (*s && isspace(*s)) s++;
9209
9210   if (*s == '@' || *s == '$') {
9211     vmsspec[0] = *s;  rest = s + 1;
9212     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9213   }
9214   else { cp = vmsspec; rest = s; }
9215   if (*rest == '.' || *rest == '/') {
9216     char *cp2;
9217     for (cp2 = resspec;
9218          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9219          rest++, cp2++) *cp2 = *rest;
9220     *cp2 = '\0';
9221     if (do_tovmsspec(resspec,cp,0,NULL)) {
9222       s = vmsspec;
9223       if (*rest) {
9224         for (cp2 = vmsspec + strlen(vmsspec);
9225              *rest && cp2 - vmsspec < sizeof vmsspec;
9226              rest++, cp2++) *cp2 = *rest;
9227         *cp2 = '\0';
9228       }
9229     }
9230   }
9231   /* Intuit whether verb (first word of cmd) is a DCL command:
9232    *   - if first nonspace char is '@', it's a DCL indirection
9233    * otherwise
9234    *   - if verb contains a filespec separator, it's not a DCL command
9235    *   - if it doesn't, caller tells us whether to default to a DCL
9236    *     command, or to a local image unless told it's DCL (by leading '$')
9237    */
9238   if (*s == '@') {
9239       isdcl = 1;
9240       if (suggest_quote) *suggest_quote = 1;
9241   } else {
9242     register char *filespec = strpbrk(s,":<[.;");
9243     rest = wordbreak = strpbrk(s," \"\t/");
9244     if (!wordbreak) wordbreak = s + strlen(s);
9245     if (*s == '$') check_img = 0;
9246     if (filespec && (filespec < wordbreak)) isdcl = 0;
9247     else isdcl = !check_img;
9248   }
9249
9250   if (!isdcl) {
9251     int rsts;
9252     imgdsc.dsc$a_pointer = s;
9253     imgdsc.dsc$w_length = wordbreak - s;
9254     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9255     if (!(retsts&1)) {
9256         _ckvmssts(lib$find_file_end(&cxt));
9257         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9258       if (!(retsts & 1) && *s == '$') {
9259         _ckvmssts(lib$find_file_end(&cxt));
9260         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9261         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9262         if (!(retsts&1)) {
9263           _ckvmssts(lib$find_file_end(&cxt));
9264           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9265         }
9266       }
9267     }
9268     _ckvmssts(lib$find_file_end(&cxt));
9269
9270     if (retsts & 1) {
9271       FILE *fp;
9272       s = resspec;
9273       while (*s && !isspace(*s)) s++;
9274       *s = '\0';
9275
9276       /* check that it's really not DCL with no file extension */
9277       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9278       if (fp) {
9279         char b[256] = {0,0,0,0};
9280         read(fileno(fp), b, 256);
9281         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9282         if (isdcl) {
9283           int shebang_len;
9284
9285           /* Check for script */
9286           shebang_len = 0;
9287           if ((b[0] == '#') && (b[1] == '!'))
9288              shebang_len = 2;
9289 #ifdef ALTERNATE_SHEBANG
9290           else {
9291             shebang_len = strlen(ALTERNATE_SHEBANG);
9292             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9293               char * perlstr;
9294                 perlstr = strstr("perl",b);
9295                 if (perlstr == NULL)
9296                   shebang_len = 0;
9297             }
9298             else
9299               shebang_len = 0;
9300           }
9301 #endif
9302
9303           if (shebang_len > 0) {
9304           int i;
9305           int j;
9306           char tmpspec[NAM$C_MAXRSS + 1];
9307
9308             i = shebang_len;
9309              /* Image is following after white space */
9310             /*--------------------------------------*/
9311             while (isprint(b[i]) && isspace(b[i]))
9312                 i++;
9313
9314             j = 0;
9315             while (isprint(b[i]) && !isspace(b[i])) {
9316                 tmpspec[j++] = b[i++];
9317                 if (j >= NAM$C_MAXRSS)
9318                    break;
9319             }
9320             tmpspec[j] = '\0';
9321
9322              /* There may be some default parameters to the image */
9323             /*---------------------------------------------------*/
9324             j = 0;
9325             while (isprint(b[i])) {
9326                 image_argv[j++] = b[i++];
9327                 if (j >= NAM$C_MAXRSS)
9328                    break;
9329             }
9330             while ((j > 0) && !isprint(image_argv[j-1]))
9331                 j--;
9332             image_argv[j] = 0;
9333
9334             /* It will need to be converted to VMS format and validated */
9335             if (tmpspec[0] != '\0') {
9336               char * iname;
9337
9338                /* Try to find the exact program requested to be run */
9339               /*---------------------------------------------------*/
9340               iname = do_rmsexpand
9341                  (tmpspec, image_name, 0, ".exe",
9342                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
9343               if (iname != NULL) {
9344                 if (cando_by_name_int
9345                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9346                   /* MCR prefix needed */
9347                   isdcl = 0;
9348                 }
9349                 else {
9350                    /* Try again with a null type */
9351                   /*----------------------------*/
9352                   iname = do_rmsexpand
9353                     (tmpspec, image_name, 0, ".",
9354                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
9355                   if (iname != NULL) {
9356                     if (cando_by_name_int
9357                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9358                       /* MCR prefix needed */
9359                       isdcl = 0;
9360                     }
9361                   }
9362                 }
9363
9364                  /* Did we find the image to run the script? */
9365                 /*------------------------------------------*/
9366                 if (isdcl) {
9367                   char *tchr;
9368
9369                    /* Assume DCL or foreign command exists */
9370                   /*--------------------------------------*/
9371                   tchr = strrchr(tmpspec, '/');
9372                   if (tchr != NULL) {
9373                     tchr++;
9374                   }
9375                   else {
9376                     tchr = tmpspec;
9377                   }
9378                   strcpy(image_name, tchr);
9379                 }
9380               }
9381             }
9382           }
9383         }
9384         fclose(fp);
9385       }
9386       if (check_img && isdcl) return RMS$_FNF;
9387
9388       if (cando_by_name(S_IXUSR,0,resspec)) {
9389         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9390         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9391         if (!isdcl) {
9392             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9393             if (image_name[0] != 0) {
9394                 strcat(vmscmd->dsc$a_pointer, image_name);
9395                 strcat(vmscmd->dsc$a_pointer, " ");
9396             }
9397         } else if (image_name[0] != 0) {
9398             strcpy(vmscmd->dsc$a_pointer, image_name);
9399             strcat(vmscmd->dsc$a_pointer, " ");
9400         } else {
9401             strcpy(vmscmd->dsc$a_pointer,"@");
9402         }
9403         if (suggest_quote) *suggest_quote = 1;
9404
9405         /* If there is an image name, use original command */
9406         if (image_name[0] == 0)
9407             strcat(vmscmd->dsc$a_pointer,resspec);
9408         else {
9409             rest = cmd;
9410             while (*rest && isspace(*rest)) rest++;
9411         }
9412
9413         if (image_argv[0] != 0) {
9414           strcat(vmscmd->dsc$a_pointer,image_argv);
9415           strcat(vmscmd->dsc$a_pointer, " ");
9416         }
9417         if (rest) {
9418            int rest_len;
9419            int vmscmd_len;
9420
9421            rest_len = strlen(rest);
9422            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9423            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9424               strcat(vmscmd->dsc$a_pointer,rest);
9425            else
9426              retsts = CLI$_BUFOVF;
9427         }
9428         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9429         PerlMem_free(cmd);
9430         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9431       }
9432       else
9433         retsts = RMS$_PRV;
9434     }
9435   }
9436   /* It's either a DCL command or we couldn't find a suitable image */
9437   vmscmd->dsc$w_length = strlen(cmd);
9438
9439   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9440   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9441   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9442
9443   PerlMem_free(cmd);
9444
9445   /* check if it's a symbol (for quoting purposes) */
9446   if (suggest_quote && !*suggest_quote) {
9447     int iss;
9448     char equiv[LNM$C_NAMLENGTH];
9449     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9450     eqvdsc.dsc$a_pointer = equiv;
9451
9452     iss = lib$get_symbol(vmscmd,&eqvdsc);
9453     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9454   }
9455   if (!(retsts & 1)) {
9456     /* just hand off status values likely to be due to user error */
9457     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9458         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9459        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9460     else { _ckvmssts(retsts); }
9461   }
9462
9463   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9464
9465 }  /* end of setup_cmddsc() */
9466
9467
9468 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9469 bool
9470 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9471 {
9472 bool exec_sts;
9473 char * cmd;
9474
9475   if (sp > mark) {
9476     if (vfork_called) {           /* this follows a vfork - act Unixish */
9477       vfork_called--;
9478       if (vfork_called < 0) {
9479         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9480         vfork_called = 0;
9481       }
9482       else return do_aexec(really,mark,sp);
9483     }
9484                                            /* no vfork - act VMSish */
9485     cmd = setup_argstr(aTHX_ really,mark,sp);
9486     exec_sts = vms_do_exec(cmd);
9487     Safefree(cmd);  /* Clean up from setup_argstr() */
9488     return exec_sts;
9489   }
9490
9491   return FALSE;
9492 }  /* end of vms_do_aexec() */
9493 /*}}}*/
9494
9495 /* {{{bool vms_do_exec(char *cmd) */
9496 bool
9497 Perl_vms_do_exec(pTHX_ const char *cmd)
9498 {
9499   struct dsc$descriptor_s *vmscmd;
9500
9501   if (vfork_called) {             /* this follows a vfork - act Unixish */
9502     vfork_called--;
9503     if (vfork_called < 0) {
9504       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9505       vfork_called = 0;
9506     }
9507     else return do_exec(cmd);
9508   }
9509
9510   {                               /* no vfork - act VMSish */
9511     unsigned long int retsts;
9512
9513     TAINT_ENV();
9514     TAINT_PROPER("exec");
9515     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9516       retsts = lib$do_command(vmscmd);
9517
9518     switch (retsts) {
9519       case RMS$_FNF: case RMS$_DNF:
9520         set_errno(ENOENT); break;
9521       case RMS$_DIR:
9522         set_errno(ENOTDIR); break;
9523       case RMS$_DEV:
9524         set_errno(ENODEV); break;
9525       case RMS$_PRV:
9526         set_errno(EACCES); break;
9527       case RMS$_SYN:
9528         set_errno(EINVAL); break;
9529       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9530         set_errno(E2BIG); break;
9531       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9532         _ckvmssts(retsts); /* fall through */
9533       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9534         set_errno(EVMSERR);
9535     }
9536     set_vaxc_errno(retsts);
9537     if (ckWARN(WARN_EXEC)) {
9538       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9539              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9540     }
9541     vms_execfree(vmscmd);
9542   }
9543
9544   return FALSE;
9545
9546 }  /* end of vms_do_exec() */
9547 /*}}}*/
9548
9549 unsigned long int Perl_do_spawn(pTHX_ const char *);
9550
9551 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9552 unsigned long int
9553 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9554 {
9555 unsigned long int sts;
9556 char * cmd;
9557
9558   if (sp > mark) {
9559     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9560     sts = do_spawn(cmd);
9561     /* pp_sys will clean up cmd */
9562     return sts;
9563   }
9564   return SS$_ABORT;
9565 }  /* end of do_aspawn() */
9566 /*}}}*/
9567
9568 /* {{{unsigned long int do_spawn(char *cmd) */
9569 unsigned long int
9570 Perl_do_spawn(pTHX_ const char *cmd)
9571 {
9572   unsigned long int sts, substs;
9573
9574   /* The caller of this routine expects to Safefree(PL_Cmd) */
9575   Newx(PL_Cmd,10,char);
9576
9577   TAINT_ENV();
9578   TAINT_PROPER("spawn");
9579   if (!cmd || !*cmd) {
9580     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9581     if (!(sts & 1)) {
9582       switch (sts) {
9583         case RMS$_FNF:  case RMS$_DNF:
9584           set_errno(ENOENT); break;
9585         case RMS$_DIR:
9586           set_errno(ENOTDIR); break;
9587         case RMS$_DEV:
9588           set_errno(ENODEV); break;
9589         case RMS$_PRV:
9590           set_errno(EACCES); break;
9591         case RMS$_SYN:
9592           set_errno(EINVAL); break;
9593         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9594           set_errno(E2BIG); break;
9595         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9596           _ckvmssts(sts); /* fall through */
9597         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9598           set_errno(EVMSERR);
9599       }
9600       set_vaxc_errno(sts);
9601       if (ckWARN(WARN_EXEC)) {
9602         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9603                     Strerror(errno));
9604       }
9605     }
9606     sts = substs;
9607   }
9608   else {
9609     PerlIO * fp;
9610     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9611     if (fp != NULL)
9612       my_pclose(fp);
9613   }
9614   return sts;
9615 }  /* end of do_spawn() */
9616 /*}}}*/
9617
9618
9619 static unsigned int *sockflags, sockflagsize;
9620
9621 /*
9622  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9623  * routines found in some versions of the CRTL can't deal with sockets.
9624  * We don't shim the other file open routines since a socket isn't
9625  * likely to be opened by a name.
9626  */
9627 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9628 FILE *my_fdopen(int fd, const char *mode)
9629 {
9630   FILE *fp = fdopen(fd, mode);
9631
9632   if (fp) {
9633     unsigned int fdoff = fd / sizeof(unsigned int);
9634     Stat_t sbuf; /* native stat; we don't need flex_stat */
9635     if (!sockflagsize || fdoff > sockflagsize) {
9636       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
9637       else           Newx  (sockflags,fdoff+2,unsigned int);
9638       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9639       sockflagsize = fdoff + 2;
9640     }
9641     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9642       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9643   }
9644   return fp;
9645
9646 }
9647 /*}}}*/
9648
9649
9650 /*
9651  * Clear the corresponding bit when the (possibly) socket stream is closed.
9652  * There still a small hole: we miss an implicit close which might occur
9653  * via freopen().  >> Todo
9654  */
9655 /*{{{ int my_fclose(FILE *fp)*/
9656 int my_fclose(FILE *fp) {
9657   if (fp) {
9658     unsigned int fd = fileno(fp);
9659     unsigned int fdoff = fd / sizeof(unsigned int);
9660
9661     if (sockflagsize && fdoff <= sockflagsize)
9662       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9663   }
9664   return fclose(fp);
9665 }
9666 /*}}}*/
9667
9668
9669 /*
9670  * A simple fwrite replacement which outputs itmsz*nitm chars without
9671  * introducing record boundaries every itmsz chars.
9672  * We are using fputs, which depends on a terminating null.  We may
9673  * well be writing binary data, so we need to accommodate not only
9674  * data with nulls sprinkled in the middle but also data with no null
9675  * byte at the end.
9676  */
9677 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9678 int
9679 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9680 {
9681   register char *cp, *end, *cpd, *data;
9682   register unsigned int fd = fileno(dest);
9683   register unsigned int fdoff = fd / sizeof(unsigned int);
9684   int retval;
9685   int bufsize = itmsz * nitm + 1;
9686
9687   if (fdoff < sockflagsize &&
9688       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9689     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9690     return nitm;
9691   }
9692
9693   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9694   memcpy( data, src, itmsz*nitm );
9695   data[itmsz*nitm] = '\0';
9696
9697   end = data + itmsz * nitm;
9698   retval = (int) nitm; /* on success return # items written */
9699
9700   cpd = data;
9701   while (cpd <= end) {
9702     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9703     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9704     if (cp < end)
9705       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9706     cpd = cp + 1;
9707   }
9708
9709   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9710   return retval;
9711
9712 }  /* end of my_fwrite() */
9713 /*}}}*/
9714
9715 /*{{{ int my_flush(FILE *fp)*/
9716 int
9717 Perl_my_flush(pTHX_ FILE *fp)
9718 {
9719     int res;
9720     if ((res = fflush(fp)) == 0 && fp) {
9721 #ifdef VMS_DO_SOCKETS
9722         Stat_t s;
9723         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9724 #endif
9725             res = fsync(fileno(fp));
9726     }
9727 /*
9728  * If the flush succeeded but set end-of-file, we need to clear
9729  * the error because our caller may check ferror().  BTW, this
9730  * probably means we just flushed an empty file.
9731  */
9732     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9733
9734     return res;
9735 }
9736 /*}}}*/
9737
9738 /*
9739  * Here are replacements for the following Unix routines in the VMS environment:
9740  *      getpwuid    Get information for a particular UIC or UID
9741  *      getpwnam    Get information for a named user
9742  *      getpwent    Get information for each user in the rights database
9743  *      setpwent    Reset search to the start of the rights database
9744  *      endpwent    Finish searching for users in the rights database
9745  *
9746  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9747  * (defined in pwd.h), which contains the following fields:-
9748  *      struct passwd {
9749  *              char        *pw_name;    Username (in lower case)
9750  *              char        *pw_passwd;  Hashed password
9751  *              unsigned int pw_uid;     UIC
9752  *              unsigned int pw_gid;     UIC group  number
9753  *              char        *pw_unixdir; Default device/directory (VMS-style)
9754  *              char        *pw_gecos;   Owner name
9755  *              char        *pw_dir;     Default device/directory (Unix-style)
9756  *              char        *pw_shell;   Default CLI name (eg. DCL)
9757  *      };
9758  * If the specified user does not exist, getpwuid and getpwnam return NULL.
9759  *
9760  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9761  * not the UIC member number (eg. what's returned by getuid()),
9762  * getpwuid() can accept either as input (if uid is specified, the caller's
9763  * UIC group is used), though it won't recognise gid=0.
9764  *
9765  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9766  * information about other users in your group or in other groups, respectively.
9767  * If the required privilege is not available, then these routines fill only
9768  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9769  * string).
9770  *
9771  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9772  */
9773
9774 /* sizes of various UAF record fields */
9775 #define UAI$S_USERNAME 12
9776 #define UAI$S_IDENT    31
9777 #define UAI$S_OWNER    31
9778 #define UAI$S_DEFDEV   31
9779 #define UAI$S_DEFDIR   63
9780 #define UAI$S_DEFCLI   31
9781 #define UAI$S_PWD       8
9782
9783 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
9784                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9785                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
9786
9787 static char __empty[]= "";
9788 static struct passwd __passwd_empty=
9789     {(char *) __empty, (char *) __empty, 0, 0,
9790      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9791 static int contxt= 0;
9792 static struct passwd __pwdcache;
9793 static char __pw_namecache[UAI$S_IDENT+1];
9794
9795 /*
9796  * This routine does most of the work extracting the user information.
9797  */
9798 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9799 {
9800     static struct {
9801         unsigned char length;
9802         char pw_gecos[UAI$S_OWNER+1];
9803     } owner;
9804     static union uicdef uic;
9805     static struct {
9806         unsigned char length;
9807         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9808     } defdev;
9809     static struct {
9810         unsigned char length;
9811         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9812     } defdir;
9813     static struct {
9814         unsigned char length;
9815         char pw_shell[UAI$S_DEFCLI+1];
9816     } defcli;
9817     static char pw_passwd[UAI$S_PWD+1];
9818
9819     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9820     struct dsc$descriptor_s name_desc;
9821     unsigned long int sts;
9822
9823     static struct itmlst_3 itmlst[]= {
9824         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
9825         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
9826         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
9827         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
9828         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
9829         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
9830         {0,                0,           NULL,    NULL}};
9831
9832     name_desc.dsc$w_length=  strlen(name);
9833     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9834     name_desc.dsc$b_class=   DSC$K_CLASS_S;
9835     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9836
9837 /*  Note that sys$getuai returns many fields as counted strings. */
9838     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9839     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9840       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9841     }
9842     else { _ckvmssts(sts); }
9843     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
9844
9845     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
9846     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9847     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9848     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9849     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9850     owner.pw_gecos[lowner]=            '\0';
9851     defdev.pw_dir[ldefdev+ldefdir]= '\0';
9852     defcli.pw_shell[ldefcli]=          '\0';
9853     if (valid_uic(uic)) {
9854         pwd->pw_uid= uic.uic$l_uic;
9855         pwd->pw_gid= uic.uic$v_group;
9856     }
9857     else
9858       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9859     pwd->pw_passwd=  pw_passwd;
9860     pwd->pw_gecos=   owner.pw_gecos;
9861     pwd->pw_dir=     defdev.pw_dir;
9862     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9863     pwd->pw_shell=   defcli.pw_shell;
9864     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9865         int ldir;
9866         ldir= strlen(pwd->pw_unixdir) - 1;
9867         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9868     }
9869     else
9870         strcpy(pwd->pw_unixdir, pwd->pw_dir);
9871     if (!decc_efs_case_preserve)
9872         __mystrtolower(pwd->pw_unixdir);
9873     return 1;
9874 }
9875
9876 /*
9877  * Get information for a named user.
9878 */
9879 /*{{{struct passwd *getpwnam(char *name)*/
9880 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9881 {
9882     struct dsc$descriptor_s name_desc;
9883     union uicdef uic;
9884     unsigned long int status, sts;
9885
9886     __pwdcache = __passwd_empty;
9887     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9888       /* We still may be able to determine pw_uid and pw_gid */
9889       name_desc.dsc$w_length=  strlen(name);
9890       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9891       name_desc.dsc$b_class=   DSC$K_CLASS_S;
9892       name_desc.dsc$a_pointer= (char *) name;
9893       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9894         __pwdcache.pw_uid= uic.uic$l_uic;
9895         __pwdcache.pw_gid= uic.uic$v_group;
9896       }
9897       else {
9898         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9899           set_vaxc_errno(sts);
9900           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9901           return NULL;
9902         }
9903         else { _ckvmssts(sts); }
9904       }
9905     }
9906     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9907     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9908     __pwdcache.pw_name= __pw_namecache;
9909     return &__pwdcache;
9910 }  /* end of my_getpwnam() */
9911 /*}}}*/
9912
9913 /*
9914  * Get information for a particular UIC or UID.
9915  * Called by my_getpwent with uid=-1 to list all users.
9916 */
9917 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9918 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9919 {
9920     const $DESCRIPTOR(name_desc,__pw_namecache);
9921     unsigned short lname;
9922     union uicdef uic;
9923     unsigned long int status;
9924
9925     if (uid == (unsigned int) -1) {
9926       do {
9927         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9928         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9929           set_vaxc_errno(status);
9930           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9931           my_endpwent();
9932           return NULL;
9933         }
9934         else { _ckvmssts(status); }
9935       } while (!valid_uic (uic));
9936     }
9937     else {
9938       uic.uic$l_uic= uid;
9939       if (!uic.uic$v_group)
9940         uic.uic$v_group= PerlProc_getgid();
9941       if (valid_uic(uic))
9942         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9943       else status = SS$_IVIDENT;
9944       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9945           status == RMS$_PRV) {
9946         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9947         return NULL;
9948       }
9949       else { _ckvmssts(status); }
9950     }
9951     __pw_namecache[lname]= '\0';
9952     __mystrtolower(__pw_namecache);
9953
9954     __pwdcache = __passwd_empty;
9955     __pwdcache.pw_name = __pw_namecache;
9956
9957 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9958     The identifier's value is usually the UIC, but it doesn't have to be,
9959     so if we can, we let fillpasswd update this. */
9960     __pwdcache.pw_uid =  uic.uic$l_uic;
9961     __pwdcache.pw_gid =  uic.uic$v_group;
9962
9963     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9964     return &__pwdcache;
9965
9966 }  /* end of my_getpwuid() */
9967 /*}}}*/
9968
9969 /*
9970  * Get information for next user.
9971 */
9972 /*{{{struct passwd *my_getpwent()*/
9973 struct passwd *Perl_my_getpwent(pTHX)
9974 {
9975     return (my_getpwuid((unsigned int) -1));
9976 }
9977 /*}}}*/
9978
9979 /*
9980  * Finish searching rights database for users.
9981 */
9982 /*{{{void my_endpwent()*/
9983 void Perl_my_endpwent(pTHX)
9984 {
9985     if (contxt) {
9986       _ckvmssts(sys$finish_rdb(&contxt));
9987       contxt= 0;
9988     }
9989 }
9990 /*}}}*/
9991
9992 #ifdef HOMEGROWN_POSIX_SIGNALS
9993   /* Signal handling routines, pulled into the core from POSIX.xs.
9994    *
9995    * We need these for threads, so they've been rolled into the core,
9996    * rather than left in POSIX.xs.
9997    *
9998    * (DRS, Oct 23, 1997)
9999    */
10000
10001   /* sigset_t is atomic under VMS, so these routines are easy */
10002 /*{{{int my_sigemptyset(sigset_t *) */
10003 int my_sigemptyset(sigset_t *set) {
10004     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10005     *set = 0; return 0;
10006 }
10007 /*}}}*/
10008
10009
10010 /*{{{int my_sigfillset(sigset_t *)*/
10011 int my_sigfillset(sigset_t *set) {
10012     int i;
10013     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10014     for (i = 0; i < NSIG; i++) *set |= (1 << i);
10015     return 0;
10016 }
10017 /*}}}*/
10018
10019
10020 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10021 int my_sigaddset(sigset_t *set, int sig) {
10022     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10023     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10024     *set |= (1 << (sig - 1));
10025     return 0;
10026 }
10027 /*}}}*/
10028
10029
10030 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10031 int my_sigdelset(sigset_t *set, int sig) {
10032     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10033     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10034     *set &= ~(1 << (sig - 1));
10035     return 0;
10036 }
10037 /*}}}*/
10038
10039
10040 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10041 int my_sigismember(sigset_t *set, int sig) {
10042     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10043     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10044     return *set & (1 << (sig - 1));
10045 }
10046 /*}}}*/
10047
10048
10049 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10050 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10051     sigset_t tempmask;
10052
10053     /* If set and oset are both null, then things are badly wrong. Bail out. */
10054     if ((oset == NULL) && (set == NULL)) {
10055       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10056       return -1;
10057     }
10058
10059     /* If set's null, then we're just handling a fetch. */
10060     if (set == NULL) {
10061         tempmask = sigblock(0);
10062     }
10063     else {
10064       switch (how) {
10065       case SIG_SETMASK:
10066         tempmask = sigsetmask(*set);
10067         break;
10068       case SIG_BLOCK:
10069         tempmask = sigblock(*set);
10070         break;
10071       case SIG_UNBLOCK:
10072         tempmask = sigblock(0);
10073         sigsetmask(*oset & ~tempmask);
10074         break;
10075       default:
10076         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10077         return -1;
10078       }
10079     }
10080
10081     /* Did they pass us an oset? If so, stick our holding mask into it */
10082     if (oset)
10083       *oset = tempmask;
10084
10085     return 0;
10086 }
10087 /*}}}*/
10088 #endif  /* HOMEGROWN_POSIX_SIGNALS */
10089
10090
10091 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10092  * my_utime(), and flex_stat(), all of which operate on UTC unless
10093  * VMSISH_TIMES is true.
10094  */
10095 /* method used to handle UTC conversions:
10096  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
10097  */
10098 static int gmtime_emulation_type;
10099 /* number of secs to add to UTC POSIX-style time to get local time */
10100 static long int utc_offset_secs;
10101
10102 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10103  * in vmsish.h.  #undef them here so we can call the CRTL routines
10104  * directly.
10105  */
10106 #undef gmtime
10107 #undef localtime
10108 #undef time
10109
10110
10111 /*
10112  * DEC C previous to 6.0 corrupts the behavior of the /prefix
10113  * qualifier with the extern prefix pragma.  This provisional
10114  * hack circumvents this prefix pragma problem in previous
10115  * precompilers.
10116  */
10117 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10118 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10119 #    pragma __extern_prefix save
10120 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
10121 #    define gmtime decc$__utctz_gmtime
10122 #    define localtime decc$__utctz_localtime
10123 #    define time decc$__utc_time
10124 #    pragma __extern_prefix restore
10125
10126      struct tm *gmtime(), *localtime();
10127
10128 #  endif
10129 #endif
10130
10131
10132 static time_t toutc_dst(time_t loc) {
10133   struct tm *rsltmp;
10134
10135   if ((rsltmp = localtime(&loc)) == NULL) return -1;
10136   loc -= utc_offset_secs;
10137   if (rsltmp->tm_isdst) loc -= 3600;
10138   return loc;
10139 }
10140 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10141        ((gmtime_emulation_type || my_time(NULL)), \
10142        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10143        ((secs) - utc_offset_secs))))
10144
10145 static time_t toloc_dst(time_t utc) {
10146   struct tm *rsltmp;
10147
10148   utc += utc_offset_secs;
10149   if ((rsltmp = localtime(&utc)) == NULL) return -1;
10150   if (rsltmp->tm_isdst) utc += 3600;
10151   return utc;
10152 }
10153 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10154        ((gmtime_emulation_type || my_time(NULL)), \
10155        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10156        ((secs) + utc_offset_secs))))
10157
10158 #ifndef RTL_USES_UTC
10159 /*
10160
10161     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
10162         DST starts on 1st sun of april      at 02:00  std time
10163             ends on last sun of october     at 02:00  dst time
10164     see the UCX management command reference, SET CONFIG TIMEZONE
10165     for formatting info.
10166
10167     No, it's not as general as it should be, but then again, NOTHING
10168     will handle UK times in a sensible way.
10169 */
10170
10171
10172 /*
10173     parse the DST start/end info:
10174     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10175 */
10176
10177 static char *
10178 tz_parse_startend(char *s, struct tm *w, int *past)
10179 {
10180     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10181     int ly, dozjd, d, m, n, hour, min, sec, j, k;
10182     time_t g;
10183
10184     if (!s)    return 0;
10185     if (!w) return 0;
10186     if (!past) return 0;
10187
10188     ly = 0;
10189     if (w->tm_year % 4        == 0) ly = 1;
10190     if (w->tm_year % 100      == 0) ly = 0;
10191     if (w->tm_year+1900 % 400 == 0) ly = 1;
10192     if (ly) dinm[1]++;
10193
10194     dozjd = isdigit(*s);
10195     if (*s == 'J' || *s == 'j' || dozjd) {
10196         if (!dozjd && !isdigit(*++s)) return 0;
10197         d = *s++ - '0';
10198         if (isdigit(*s)) {
10199             d = d*10 + *s++ - '0';
10200             if (isdigit(*s)) {
10201                 d = d*10 + *s++ - '0';
10202             }
10203         }
10204         if (d == 0) return 0;
10205         if (d > 366) return 0;
10206         d--;
10207         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
10208         g = d * 86400;
10209         dozjd = 1;
10210     } else if (*s == 'M' || *s == 'm') {
10211         if (!isdigit(*++s)) return 0;
10212         m = *s++ - '0';
10213         if (isdigit(*s)) m = 10*m + *s++ - '0';
10214         if (*s != '.') return 0;
10215         if (!isdigit(*++s)) return 0;
10216         n = *s++ - '0';
10217         if (n < 1 || n > 5) return 0;
10218         if (*s != '.') return 0;
10219         if (!isdigit(*++s)) return 0;
10220         d = *s++ - '0';
10221         if (d > 6) return 0;
10222     }
10223
10224     if (*s == '/') {
10225         if (!isdigit(*++s)) return 0;
10226         hour = *s++ - '0';
10227         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10228         if (*s == ':') {
10229             if (!isdigit(*++s)) return 0;
10230             min = *s++ - '0';
10231             if (isdigit(*s)) min = 10*min + *s++ - '0';
10232             if (*s == ':') {
10233                 if (!isdigit(*++s)) return 0;
10234                 sec = *s++ - '0';
10235                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10236             }
10237         }
10238     } else {
10239         hour = 2;
10240         min = 0;
10241         sec = 0;
10242     }
10243
10244     if (dozjd) {
10245         if (w->tm_yday < d) goto before;
10246         if (w->tm_yday > d) goto after;
10247     } else {
10248         if (w->tm_mon+1 < m) goto before;
10249         if (w->tm_mon+1 > m) goto after;
10250
10251         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
10252         k = d - j; /* mday of first d */
10253         if (k <= 0) k += 7;
10254         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
10255         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10256         if (w->tm_mday < k) goto before;
10257         if (w->tm_mday > k) goto after;
10258     }
10259
10260     if (w->tm_hour < hour) goto before;
10261     if (w->tm_hour > hour) goto after;
10262     if (w->tm_min  < min)  goto before;
10263     if (w->tm_min  > min)  goto after;
10264     if (w->tm_sec  < sec)  goto before;
10265     goto after;
10266
10267 before:
10268     *past = 0;
10269     return s;
10270 after:
10271     *past = 1;
10272     return s;
10273 }
10274
10275
10276
10277
10278 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
10279
10280 static char *
10281 tz_parse_offset(char *s, int *offset)
10282 {
10283     int hour = 0, min = 0, sec = 0;
10284     int neg = 0;
10285     if (!s) return 0;
10286     if (!offset) return 0;
10287
10288     if (*s == '-') {neg++; s++;}
10289     if (*s == '+') s++;
10290     if (!isdigit(*s)) return 0;
10291     hour = *s++ - '0';
10292     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10293     if (hour > 24) return 0;
10294     if (*s == ':') {
10295         if (!isdigit(*++s)) return 0;
10296         min = *s++ - '0';
10297         if (isdigit(*s)) min = min*10 + (*s++ - '0');
10298         if (min > 59) return 0;
10299         if (*s == ':') {
10300             if (!isdigit(*++s)) return 0;
10301             sec = *s++ - '0';
10302             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10303             if (sec > 59) return 0;
10304         }
10305     }
10306
10307     *offset = (hour*60+min)*60 + sec;
10308     if (neg) *offset = -*offset;
10309     return s;
10310 }
10311
10312 /*
10313     input time is w, whatever type of time the CRTL localtime() uses.
10314     sets dst, the zone, and the gmtoff (seconds)
10315
10316     caches the value of TZ and UCX$TZ env variables; note that
10317     my_setenv looks for these and sets a flag if they're changed
10318     for efficiency.
10319
10320     We have to watch out for the "australian" case (dst starts in
10321     october, ends in april)...flagged by "reverse" and checked by
10322     scanning through the months of the previous year.
10323
10324 */
10325
10326 static int
10327 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10328 {
10329     time_t when;
10330     struct tm *w2;
10331     char *s,*s2;
10332     char *dstzone, *tz, *s_start, *s_end;
10333     int std_off, dst_off, isdst;
10334     int y, dststart, dstend;
10335     static char envtz[1025];  /* longer than any logical, symbol, ... */
10336     static char ucxtz[1025];
10337     static char reversed = 0;
10338
10339     if (!w) return 0;
10340
10341     if (tz_updated) {
10342         tz_updated = 0;
10343         reversed = -1;  /* flag need to check  */
10344         envtz[0] = ucxtz[0] = '\0';
10345         tz = my_getenv("TZ",0);
10346         if (tz) strcpy(envtz, tz);
10347         tz = my_getenv("UCX$TZ",0);
10348         if (tz) strcpy(ucxtz, tz);
10349         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
10350     }
10351     tz = envtz;
10352     if (!*tz) tz = ucxtz;
10353
10354     s = tz;
10355     while (isalpha(*s)) s++;
10356     s = tz_parse_offset(s, &std_off);
10357     if (!s) return 0;
10358     if (!*s) {                  /* no DST, hurray we're done! */
10359         isdst = 0;
10360         goto done;
10361     }
10362
10363     dstzone = s;
10364     while (isalpha(*s)) s++;
10365     s2 = tz_parse_offset(s, &dst_off);
10366     if (s2) {
10367         s = s2;
10368     } else {
10369         dst_off = std_off - 3600;
10370     }
10371
10372     if (!*s) {      /* default dst start/end?? */
10373         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
10374             s = strchr(ucxtz,',');
10375         }
10376         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
10377     }
10378     if (*s != ',') return 0;
10379
10380     when = *w;
10381     when = _toutc(when);      /* convert to utc */
10382     when = when - std_off;    /* convert to pseudolocal time*/
10383
10384     w2 = localtime(&when);
10385     y = w2->tm_year;
10386     s_start = s+1;
10387     s = tz_parse_startend(s_start,w2,&dststart);
10388     if (!s) return 0;
10389     if (*s != ',') return 0;
10390
10391     when = *w;
10392     when = _toutc(when);      /* convert to utc */
10393     when = when - dst_off;    /* convert to pseudolocal time*/
10394     w2 = localtime(&when);
10395     if (w2->tm_year != y) {   /* spans a year, just check one time */
10396         when += dst_off - std_off;
10397         w2 = localtime(&when);
10398     }
10399     s_end = s+1;
10400     s = tz_parse_startend(s_end,w2,&dstend);
10401     if (!s) return 0;
10402
10403     if (reversed == -1) {  /* need to check if start later than end */
10404         int j, ds, de;
10405
10406         when = *w;
10407         if (when < 2*365*86400) {
10408             when += 2*365*86400;
10409         } else {
10410             when -= 365*86400;
10411         }
10412         w2 =localtime(&when);
10413         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
10414
10415         for (j = 0; j < 12; j++) {
10416             w2 =localtime(&when);
10417             tz_parse_startend(s_start,w2,&ds);
10418             tz_parse_startend(s_end,w2,&de);
10419             if (ds != de) break;
10420             when += 30*86400;
10421         }
10422         reversed = 0;
10423         if (de && !ds) reversed = 1;
10424     }
10425
10426     isdst = dststart && !dstend;
10427     if (reversed) isdst = dststart  || !dstend;
10428
10429 done:
10430     if (dst)    *dst = isdst;
10431     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10432     if (isdst)  tz = dstzone;
10433     if (zone) {
10434         while(isalpha(*tz))  *zone++ = *tz++;
10435         *zone = '\0';
10436     }
10437     return 1;
10438 }
10439
10440 #endif /* !RTL_USES_UTC */
10441
10442 /* my_time(), my_localtime(), my_gmtime()
10443  * By default traffic in UTC time values, using CRTL gmtime() or
10444  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10445  * Note: We need to use these functions even when the CRTL has working
10446  * UTC support, since they also handle C<use vmsish qw(times);>
10447  *
10448  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
10449  * Modified by Charles Bailey <bailey@newman.upenn.edu>
10450  */
10451
10452 /*{{{time_t my_time(time_t *timep)*/
10453 time_t Perl_my_time(pTHX_ time_t *timep)
10454 {
10455   time_t when;
10456   struct tm *tm_p;
10457
10458   if (gmtime_emulation_type == 0) {
10459     int dstnow;
10460     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
10461                               /* results of calls to gmtime() and localtime() */
10462                               /* for same &base */
10463
10464     gmtime_emulation_type++;
10465     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10466       char off[LNM$C_NAMLENGTH+1];;
10467
10468       gmtime_emulation_type++;
10469       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10470         gmtime_emulation_type++;
10471         utc_offset_secs = 0;
10472         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10473       }
10474       else { utc_offset_secs = atol(off); }
10475     }
10476     else { /* We've got a working gmtime() */
10477       struct tm gmt, local;
10478
10479       gmt = *tm_p;
10480       tm_p = localtime(&base);
10481       local = *tm_p;
10482       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
10483       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10484       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
10485       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
10486     }
10487   }
10488
10489   when = time(NULL);
10490 # ifdef VMSISH_TIME
10491 # ifdef RTL_USES_UTC
10492   if (VMSISH_TIME) when = _toloc(when);
10493 # else
10494   if (!VMSISH_TIME) when = _toutc(when);
10495 # endif
10496 # endif
10497   if (timep != NULL) *timep = when;
10498   return when;
10499
10500 }  /* end of my_time() */
10501 /*}}}*/
10502
10503
10504 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10505 struct tm *
10506 Perl_my_gmtime(pTHX_ const time_t *timep)
10507 {
10508   char *p;
10509   time_t when;
10510   struct tm *rsltmp;
10511
10512   if (timep == NULL) {
10513     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10514     return NULL;
10515   }
10516   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10517
10518   when = *timep;
10519 # ifdef VMSISH_TIME
10520   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10521 #  endif
10522 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
10523   return gmtime(&when);
10524 # else
10525   /* CRTL localtime() wants local time as input, so does no tz correction */
10526   rsltmp = localtime(&when);
10527   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
10528   return rsltmp;
10529 #endif
10530 }  /* end of my_gmtime() */
10531 /*}}}*/
10532
10533
10534 /*{{{struct tm *my_localtime(const time_t *timep)*/
10535 struct tm *
10536 Perl_my_localtime(pTHX_ const time_t *timep)
10537 {
10538   time_t when, whenutc;
10539   struct tm *rsltmp;
10540   int dst, offset;
10541
10542   if (timep == NULL) {
10543     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10544     return NULL;
10545   }
10546   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10547   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10548
10549   when = *timep;
10550 # ifdef RTL_USES_UTC
10551 # ifdef VMSISH_TIME
10552   if (VMSISH_TIME) when = _toutc(when);
10553 # endif
10554   /* CRTL localtime() wants UTC as input, does tz correction itself */
10555   return localtime(&when);
10556
10557 # else /* !RTL_USES_UTC */
10558   whenutc = when;
10559 # ifdef VMSISH_TIME
10560   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
10561   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
10562 # endif
10563   dst = -1;
10564 #ifndef RTL_USES_UTC
10565   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
10566       when = whenutc - offset;                   /* pseudolocal time*/
10567   }
10568 # endif
10569   /* CRTL localtime() wants local time as input, so does no tz correction */
10570   rsltmp = localtime(&when);
10571   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10572   return rsltmp;
10573 # endif
10574
10575 } /*  end of my_localtime() */
10576 /*}}}*/
10577
10578 /* Reset definitions for later calls */
10579 #define gmtime(t)    my_gmtime(t)
10580 #define localtime(t) my_localtime(t)
10581 #define time(t)      my_time(t)
10582
10583
10584 /* my_utime - update modification/access time of a file
10585  *
10586  * VMS 7.3 and later implementation
10587  * Only the UTC translation is home-grown. The rest is handled by the
10588  * CRTL utime(), which will take into account the relevant feature
10589  * logicals and ODS-5 volume characteristics for true access times.
10590  *
10591  * pre VMS 7.3 implementation:
10592  * The calling sequence is identical to POSIX utime(), but under
10593  * VMS with ODS-2, only the modification time is changed; ODS-2 does
10594  * not maintain access times.  Restrictions differ from the POSIX
10595  * definition in that the time can be changed as long as the
10596  * caller has permission to execute the necessary IO$_MODIFY $QIO;
10597  * no separate checks are made to insure that the caller is the
10598  * owner of the file or has special privs enabled.
10599  * Code here is based on Joe Meadows' FILE utility.
10600  *
10601  */
10602
10603 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10604  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
10605  * in 100 ns intervals.
10606  */
10607 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10608
10609 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10610 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10611 {
10612 #if __CRTL_VER >= 70300000
10613   struct utimbuf utc_utimes, *utc_utimesp;
10614
10615   if (utimes != NULL) {
10616     utc_utimes.actime = utimes->actime;
10617     utc_utimes.modtime = utimes->modtime;
10618 # ifdef VMSISH_TIME
10619     /* If input was local; convert to UTC for sys svc */
10620     if (VMSISH_TIME) {
10621       utc_utimes.actime = _toutc(utimes->actime);
10622       utc_utimes.modtime = _toutc(utimes->modtime);
10623     }
10624 # endif
10625     utc_utimesp = &utc_utimes;
10626   }
10627   else {
10628     utc_utimesp = NULL;
10629   }
10630
10631   return utime(file, utc_utimesp);
10632
10633 #else /* __CRTL_VER < 70300000 */
10634
10635   register int i;
10636   int sts;
10637   long int bintime[2], len = 2, lowbit, unixtime,
10638            secscale = 10000000; /* seconds --> 100 ns intervals */
10639   unsigned long int chan, iosb[2], retsts;
10640   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10641   struct FAB myfab = cc$rms_fab;
10642   struct NAM mynam = cc$rms_nam;
10643 #if defined (__DECC) && defined (__VAX)
10644   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10645    * at least through VMS V6.1, which causes a type-conversion warning.
10646    */
10647 #  pragma message save
10648 #  pragma message disable cvtdiftypes
10649 #endif
10650   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10651   struct fibdef myfib;
10652 #if defined (__DECC) && defined (__VAX)
10653   /* This should be right after the declaration of myatr, but due
10654    * to a bug in VAX DEC C, this takes effect a statement early.
10655    */
10656 #  pragma message restore
10657 #endif
10658   /* cast ok for read only parameter */
10659   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10660                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10661                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10662
10663   if (file == NULL || *file == '\0') {
10664     SETERRNO(ENOENT, LIB$_INVARG);
10665     return -1;
10666   }
10667
10668   /* Convert to VMS format ensuring that it will fit in 255 characters */
10669   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10670       SETERRNO(ENOENT, LIB$_INVARG);
10671       return -1;
10672   }
10673   if (utimes != NULL) {
10674     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
10675      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10676      * Since time_t is unsigned long int, and lib$emul takes a signed long int
10677      * as input, we force the sign bit to be clear by shifting unixtime right
10678      * one bit, then multiplying by an extra factor of 2 in lib$emul().
10679      */
10680     lowbit = (utimes->modtime & 1) ? secscale : 0;
10681     unixtime = (long int) utimes->modtime;
10682 #   ifdef VMSISH_TIME
10683     /* If input was UTC; convert to local for sys svc */
10684     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10685 #   endif
10686     unixtime >>= 1;  secscale <<= 1;
10687     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10688     if (!(retsts & 1)) {
10689       SETERRNO(EVMSERR, retsts);
10690       return -1;
10691     }
10692     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10693     if (!(retsts & 1)) {
10694       SETERRNO(EVMSERR, retsts);
10695       return -1;
10696     }
10697   }
10698   else {
10699     /* Just get the current time in VMS format directly */
10700     retsts = sys$gettim(bintime);
10701     if (!(retsts & 1)) {
10702       SETERRNO(EVMSERR, retsts);
10703       return -1;
10704     }
10705   }
10706
10707   myfab.fab$l_fna = vmsspec;
10708   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10709   myfab.fab$l_nam = &mynam;
10710   mynam.nam$l_esa = esa;
10711   mynam.nam$b_ess = (unsigned char) sizeof esa;
10712   mynam.nam$l_rsa = rsa;
10713   mynam.nam$b_rss = (unsigned char) sizeof rsa;
10714   if (decc_efs_case_preserve)
10715       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10716
10717   /* Look for the file to be affected, letting RMS parse the file
10718    * specification for us as well.  I have set errno using only
10719    * values documented in the utime() man page for VMS POSIX.
10720    */
10721   retsts = sys$parse(&myfab,0,0);
10722   if (!(retsts & 1)) {
10723     set_vaxc_errno(retsts);
10724     if      (retsts == RMS$_PRV) set_errno(EACCES);
10725     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10726     else                         set_errno(EVMSERR);
10727     return -1;
10728   }
10729   retsts = sys$search(&myfab,0,0);
10730   if (!(retsts & 1)) {
10731     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10732     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10733     set_vaxc_errno(retsts);
10734     if      (retsts == RMS$_PRV) set_errno(EACCES);
10735     else if (retsts == RMS$_FNF) set_errno(ENOENT);
10736     else                         set_errno(EVMSERR);
10737     return -1;
10738   }
10739
10740   devdsc.dsc$w_length = mynam.nam$b_dev;
10741   /* cast ok for read only parameter */
10742   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10743
10744   retsts = sys$assign(&devdsc,&chan,0,0);
10745   if (!(retsts & 1)) {
10746     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10747     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10748     set_vaxc_errno(retsts);
10749     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
10750     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
10751     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
10752     else                               set_errno(EVMSERR);
10753     return -1;
10754   }
10755
10756   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10757   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10758
10759   memset((void *) &myfib, 0, sizeof myfib);
10760 #if defined(__DECC) || defined(__DECCXX)
10761   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10762   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10763   /* This prevents the revision time of the file being reset to the current
10764    * time as a result of our IO$_MODIFY $QIO. */
10765   myfib.fib$l_acctl = FIB$M_NORECORD;
10766 #else
10767   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10768   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10769   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10770 #endif
10771   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10772   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10773   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10774   _ckvmssts(sys$dassgn(chan));
10775   if (retsts & 1) retsts = iosb[0];
10776   if (!(retsts & 1)) {
10777     set_vaxc_errno(retsts);
10778     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10779     else                      set_errno(EVMSERR);
10780     return -1;
10781   }
10782
10783   return 0;
10784
10785 #endif /* #if __CRTL_VER >= 70300000 */
10786
10787 }  /* end of my_utime() */
10788 /*}}}*/
10789
10790 /*
10791  * flex_stat, flex_lstat, flex_fstat
10792  * basic stat, but gets it right when asked to stat
10793  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10794  */
10795
10796 #ifndef _USE_STD_STAT
10797 /* encode_dev packs a VMS device name string into an integer to allow
10798  * simple comparisons. This can be used, for example, to check whether two
10799  * files are located on the same device, by comparing their encoded device
10800  * names. Even a string comparison would not do, because stat() reuses the
10801  * device name buffer for each call; so without encode_dev, it would be
10802  * necessary to save the buffer and use strcmp (this would mean a number of
10803  * changes to the standard Perl code, to say nothing of what a Perl script
10804  * would have to do.
10805  *
10806  * The device lock id, if it exists, should be unique (unless perhaps compared
10807  * with lock ids transferred from other nodes). We have a lock id if the disk is
10808  * mounted cluster-wide, which is when we tend to get long (host-qualified)
10809  * device names. Thus we use the lock id in preference, and only if that isn't
10810  * available, do we try to pack the device name into an integer (flagged by
10811  * the sign bit (LOCKID_MASK) being set).
10812  *
10813  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10814  * name and its encoded form, but it seems very unlikely that we will find
10815  * two files on different disks that share the same encoded device names,
10816  * and even more remote that they will share the same file id (if the test
10817  * is to check for the same file).
10818  *
10819  * A better method might be to use sys$device_scan on the first call, and to
10820  * search for the device, returning an index into the cached array.
10821  * The number returned would be more intelligible.
10822  * This is probably not worth it, and anyway would take quite a bit longer
10823  * on the first call.
10824  */
10825 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
10826 static mydev_t encode_dev (pTHX_ const char *dev)
10827 {
10828   int i;
10829   unsigned long int f;
10830   mydev_t enc;
10831   char c;
10832   const char *q;
10833
10834   if (!dev || !dev[0]) return 0;
10835
10836 #if LOCKID_MASK
10837   {
10838     struct dsc$descriptor_s dev_desc;
10839     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10840
10841     /* For cluster-mounted disks, the disk lock identifier is unique, so we
10842        can try that first. */
10843     dev_desc.dsc$w_length =  strlen (dev);
10844     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
10845     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
10846     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
10847     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10848     if (!$VMS_STATUS_SUCCESS(status)) {
10849       switch (status) {
10850         case SS$_NOSUCHDEV:
10851           SETERRNO(ENODEV, status);
10852           return 0;
10853         default:
10854           _ckvmssts(status);
10855       }
10856     }
10857     if (lockid) return (lockid & ~LOCKID_MASK);
10858   }
10859 #endif
10860
10861   /* Otherwise we try to encode the device name */
10862   enc = 0;
10863   f = 1;
10864   i = 0;
10865   for (q = dev + strlen(dev); q--; q >= dev) {
10866     if (*q == ':')
10867         break;
10868     if (isdigit (*q))
10869       c= (*q) - '0';
10870     else if (isalpha (toupper (*q)))
10871       c= toupper (*q) - 'A' + (char)10;
10872     else
10873       continue; /* Skip '$'s */
10874     i++;
10875     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
10876     if (i>1) f *= 36;
10877     enc += f * (unsigned long int) c;
10878   }
10879   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
10880
10881 }  /* end of encode_dev() */
10882 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10883         device_no = encode_dev(aTHX_ devname)
10884 #else
10885 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10886         device_no = new_dev_no
10887 #endif
10888
10889 static int
10890 is_null_device(name)
10891     const char *name;
10892 {
10893   if (decc_bug_devnull != 0) {
10894     if (strncmp("/dev/null", name, 9) == 0)
10895       return 1;
10896   }
10897     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10898        The underscore prefix, controller letter, and unit number are
10899        independently optional; for our purposes, the colon punctuation
10900        is not.  The colon can be trailed by optional directory and/or
10901        filename, but two consecutive colons indicates a nodename rather
10902        than a device.  [pr]  */
10903   if (*name == '_') ++name;
10904   if (tolower(*name++) != 'n') return 0;
10905   if (tolower(*name++) != 'l') return 0;
10906   if (tolower(*name) == 'a') ++name;
10907   if (*name == '0') ++name;
10908   return (*name++ == ':') && (*name != ':');
10909 }
10910
10911
10912 static I32
10913 Perl_cando_by_name_int
10914    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10915 {
10916   static char usrname[L_cuserid];
10917   static struct dsc$descriptor_s usrdsc =
10918          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10919   char vmsname[NAM$C_MAXRSS+1];
10920   char *fileified;
10921   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10922   unsigned short int retlen, trnlnm_iter_count;
10923   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10924   union prvdef curprv;
10925   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10926          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10927          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10928   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10929          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10930          {0,0,0,0}};
10931   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10932          {0,0,0,0}};
10933   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10934
10935   if (!fname || !*fname) return FALSE;
10936   /* Make sure we expand logical names, since sys$check_access doesn't */
10937
10938   fileified = NULL;
10939   if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
10940     fileified = PerlMem_malloc(VMS_MAXRSS);
10941     if (!strpbrk(fname,"/]>:")) {
10942       strcpy(fileified,fname);
10943       trnlnm_iter_count = 0;
10944       while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10945         trnlnm_iter_count++;
10946         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10947       }
10948       fname = fileified;
10949     }
10950     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10951       PerlMem_free(fileified);
10952       return FALSE;
10953     }
10954     retlen = namdsc.dsc$w_length = strlen(vmsname);
10955     namdsc.dsc$a_pointer = vmsname;
10956     if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10957       vmsname[retlen-1] == ':') {
10958       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) return FALSE;
10959       namdsc.dsc$w_length = strlen(fileified);
10960       namdsc.dsc$a_pointer = fileified;
10961     }
10962   }
10963   else {
10964     retlen = namdsc.dsc$w_length = strlen(fname);
10965     namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
10966   }
10967
10968   switch (bit) {
10969     case S_IXUSR: case S_IXGRP: case S_IXOTH:
10970       access = ARM$M_EXECUTE;
10971       flags = CHP$M_READ;
10972       break;
10973     case S_IRUSR: case S_IRGRP: case S_IROTH:
10974       access = ARM$M_READ;
10975       flags = CHP$M_READ | CHP$M_USEREADALL;
10976       break;
10977     case S_IWUSR: case S_IWGRP: case S_IWOTH:
10978       access = ARM$M_WRITE;
10979       flags = CHP$M_READ | CHP$M_WRITE;
10980       break;
10981     case S_IDUSR: case S_IDGRP: case S_IDOTH:
10982       access = ARM$M_DELETE;
10983       flags = CHP$M_READ | CHP$M_WRITE;
10984       break;
10985     default:
10986       if (fileified != NULL)
10987         PerlMem_free(fileified);
10988       return FALSE;
10989   }
10990
10991   /* Before we call $check_access, create a user profile with the current
10992    * process privs since otherwise it just uses the default privs from the
10993    * UAF and might give false positives or negatives.  This only works on
10994    * VMS versions v6.0 and later since that's when sys$create_user_profile
10995    * became available.
10996    */
10997
10998   /* get current process privs and username */
10999   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11000   _ckvmssts(iosb[0]);
11001
11002 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11003
11004   /* find out the space required for the profile */
11005   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11006                                     &usrprodsc.dsc$w_length,0));
11007
11008   /* allocate space for the profile and get it filled in */
11009   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11010   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11011   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11012                                     &usrprodsc.dsc$w_length,0));
11013
11014   /* use the profile to check access to the file; free profile & analyze results */
11015   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
11016   PerlMem_free(usrprodsc.dsc$a_pointer);
11017   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11018
11019 #else
11020
11021   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11022
11023 #endif
11024
11025   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11026       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11027       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11028     set_vaxc_errno(retsts);
11029     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11030     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11031     else set_errno(ENOENT);
11032     if (fileified != NULL)
11033       PerlMem_free(fileified);
11034     return FALSE;
11035   }
11036   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11037     if (fileified != NULL)
11038       PerlMem_free(fileified);
11039     return TRUE;
11040   }
11041   _ckvmssts(retsts);
11042
11043   if (fileified != NULL)
11044     PerlMem_free(fileified);
11045   return FALSE;  /* Should never get here */
11046
11047 }
11048
11049 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
11050 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11051  * subset of the applicable information.
11052  */
11053 bool
11054 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11055 {
11056   return cando_by_name_int
11057         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11058 }  /* end of cando() */
11059 /*}}}*/
11060
11061
11062 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11063 I32
11064 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11065 {
11066    return cando_by_name_int(bit, effective, fname, 0);
11067
11068 }  /* end of cando_by_name() */
11069 /*}}}*/
11070
11071
11072 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11073 int
11074 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11075 {
11076   if (!fstat(fd,(stat_t *) statbufp)) {
11077     char *cptr;
11078     char *vms_filename;
11079     vms_filename = PerlMem_malloc(VMS_MAXRSS);
11080     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11081
11082     /* Save name for cando by name in VMS format */
11083     cptr = getname(fd, vms_filename, 1);
11084
11085     /* This should not happen, but just in case */
11086     if (cptr == NULL) {
11087         statbufp->st_devnam[0] = 0;
11088     }
11089     else {
11090         /* Make sure that the saved name fits in 255 characters */
11091         cptr = do_rmsexpand
11092                        (vms_filename,
11093                         statbufp->st_devnam,
11094                         0,
11095                         NULL,
11096                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11097                         NULL,
11098                         NULL);
11099         if (cptr == NULL)
11100             statbufp->st_devnam[0] = 0;
11101     }
11102     PerlMem_free(vms_filename);
11103
11104     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11105     VMS_DEVICE_ENCODE
11106         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11107
11108 #   ifdef RTL_USES_UTC
11109 #   ifdef VMSISH_TIME
11110     if (VMSISH_TIME) {
11111       statbufp->st_mtime = _toloc(statbufp->st_mtime);
11112       statbufp->st_atime = _toloc(statbufp->st_atime);
11113       statbufp->st_ctime = _toloc(statbufp->st_ctime);
11114     }
11115 #   endif
11116 #   else
11117 #   ifdef VMSISH_TIME
11118     if (!VMSISH_TIME) { /* Return UTC instead of local time */
11119 #   else
11120     if (1) {
11121 #   endif
11122       statbufp->st_mtime = _toutc(statbufp->st_mtime);
11123       statbufp->st_atime = _toutc(statbufp->st_atime);
11124       statbufp->st_ctime = _toutc(statbufp->st_ctime);
11125     }
11126 #endif
11127     return 0;
11128   }
11129   return -1;
11130
11131 }  /* end of flex_fstat() */
11132 /*}}}*/
11133
11134 #if !defined(__VAX) && __CRTL_VER >= 80200000
11135 #ifdef lstat
11136 #undef lstat
11137 #endif
11138 #else
11139 #ifdef lstat
11140 #undef lstat
11141 #endif
11142 #define lstat(_x, _y) stat(_x, _y)
11143 #endif
11144
11145 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11146
11147 static int
11148 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11149 {
11150     char fileified[VMS_MAXRSS];
11151     char temp_fspec[VMS_MAXRSS];
11152     char *save_spec;
11153     int retval = -1;
11154     int saved_errno, saved_vaxc_errno;
11155
11156     if (!fspec) return retval;
11157     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11158     strcpy(temp_fspec, fspec);
11159
11160     if (decc_bug_devnull != 0) {
11161       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11162         memset(statbufp,0,sizeof *statbufp);
11163         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11164         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11165         statbufp->st_uid = 0x00010001;
11166         statbufp->st_gid = 0x0001;
11167         time((time_t *)&statbufp->st_mtime);
11168         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11169         return 0;
11170       }
11171     }
11172
11173     /* Try for a directory name first.  If fspec contains a filename without
11174      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11175      * and sea:[wine.dark]water. exist, we prefer the directory here.
11176      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11177      * not sea:[wine.dark]., if the latter exists.  If the intended target is
11178      * the file with null type, specify this by calling flex_stat() with
11179      * a '.' at the end of fspec.
11180      *
11181      * If we are in Posix filespec mode, accept the filename as is.
11182      */
11183 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11184   if (decc_posix_compliant_pathnames == 0) {
11185 #endif
11186     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11187       if (lstat_flag == 0)
11188         retval = stat(fileified,(stat_t *) statbufp);
11189       else
11190         retval = lstat(fileified,(stat_t *) statbufp);
11191       save_spec = fileified;
11192     }
11193     if (retval) {
11194       if (lstat_flag == 0)
11195         retval = stat(temp_fspec,(stat_t *) statbufp);
11196       else
11197         retval = lstat(temp_fspec,(stat_t *) statbufp);
11198       save_spec = temp_fspec;
11199     }
11200 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11201   } else {
11202     if (lstat_flag == 0)
11203       retval = stat(temp_fspec,(stat_t *) statbufp);
11204     else
11205       retval = lstat(temp_fspec,(stat_t *) statbufp);
11206       save_spec = temp_fspec;
11207   }
11208 #endif
11209     if (!retval) {
11210     char * cptr;
11211       cptr = do_rmsexpand
11212        (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
11213       if (cptr == NULL)
11214         statbufp->st_devnam[0] = 0;
11215
11216       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11217       VMS_DEVICE_ENCODE
11218         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11219 #     ifdef RTL_USES_UTC
11220 #     ifdef VMSISH_TIME
11221       if (VMSISH_TIME) {
11222         statbufp->st_mtime = _toloc(statbufp->st_mtime);
11223         statbufp->st_atime = _toloc(statbufp->st_atime);
11224         statbufp->st_ctime = _toloc(statbufp->st_ctime);
11225       }
11226 #     endif
11227 #     else
11228 #     ifdef VMSISH_TIME
11229       if (!VMSISH_TIME) { /* Return UTC instead of local time */
11230 #     else
11231       if (1) {
11232 #     endif
11233         statbufp->st_mtime = _toutc(statbufp->st_mtime);
11234         statbufp->st_atime = _toutc(statbufp->st_atime);
11235         statbufp->st_ctime = _toutc(statbufp->st_ctime);
11236       }
11237 #     endif
11238     }
11239     /* If we were successful, leave errno where we found it */
11240     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
11241     return retval;
11242
11243 }  /* end of flex_stat_int() */
11244
11245
11246 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
11247 int
11248 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
11249 {
11250    return flex_stat_int(fspec, statbufp, 0);
11251 }
11252 /*}}}*/
11253
11254 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
11255 int
11256 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
11257 {
11258    return flex_stat_int(fspec, statbufp, 1);
11259 }
11260 /*}}}*/
11261
11262
11263 /*{{{char *my_getlogin()*/
11264 /* VMS cuserid == Unix getlogin, except calling sequence */
11265 char *
11266 my_getlogin(void)
11267 {
11268     static char user[L_cuserid];
11269     return cuserid(user);
11270 }
11271 /*}}}*/
11272
11273
11274 /*  rmscopy - copy a file using VMS RMS routines
11275  *
11276  *  Copies contents and attributes of spec_in to spec_out, except owner
11277  *  and protection information.  Name and type of spec_in are used as
11278  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
11279  *  should try to propagate timestamps from the input file to the output file.
11280  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
11281  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
11282  *  propagated to the output file at creation iff the output file specification
11283  *  did not contain an explicit name or type, and the revision date is always
11284  *  updated at the end of the copy operation.  If it is greater than 0, then
11285  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11286  *  other than the revision date should be propagated, and bit 1 indicates
11287  *  that the revision date should be propagated.
11288  *
11289  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11290  *
11291  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11292  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
11293  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
11294  * as part of the Perl standard distribution under the terms of the
11295  * GNU General Public License or the Perl Artistic License.  Copies
11296  * of each may be found in the Perl standard distribution.
11297  */ /* FIXME */
11298 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11299 int
11300 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11301 {
11302     char *vmsin, * vmsout, *esa, *esa_out,
11303          *rsa, *ubf;
11304     unsigned long int i, sts, sts2;
11305     int dna_len;
11306     struct FAB fab_in, fab_out;
11307     struct RAB rab_in, rab_out;
11308     rms_setup_nam(nam);
11309     rms_setup_nam(nam_out);
11310     struct XABDAT xabdat;
11311     struct XABFHC xabfhc;
11312     struct XABRDT xabrdt;
11313     struct XABSUM xabsum;
11314
11315     vmsin = PerlMem_malloc(VMS_MAXRSS);
11316     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11317     vmsout = PerlMem_malloc(VMS_MAXRSS);
11318     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11319     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11320         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11321       PerlMem_free(vmsin);
11322       PerlMem_free(vmsout);
11323       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11324       return 0;
11325     }
11326
11327     esa = PerlMem_malloc(VMS_MAXRSS);
11328     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11329     fab_in = cc$rms_fab;
11330     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11331     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11332     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11333     fab_in.fab$l_fop = FAB$M_SQO;
11334     rms_bind_fab_nam(fab_in, nam);
11335     fab_in.fab$l_xab = (void *) &xabdat;
11336
11337     rsa = PerlMem_malloc(VMS_MAXRSS);
11338     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11339     rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11340     rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11341     rms_nam_esl(nam) = 0;
11342     rms_nam_rsl(nam) = 0;
11343     rms_nam_esll(nam) = 0;
11344     rms_nam_rsll(nam) = 0;
11345 #ifdef NAM$M_NO_SHORT_UPCASE
11346     if (decc_efs_case_preserve)
11347         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11348 #endif
11349
11350     xabdat = cc$rms_xabdat;        /* To get creation date */
11351     xabdat.xab$l_nxt = (void *) &xabfhc;
11352
11353     xabfhc = cc$rms_xabfhc;        /* To get record length */
11354     xabfhc.xab$l_nxt = (void *) &xabsum;
11355
11356     xabsum = cc$rms_xabsum;        /* To get key and area information */
11357
11358     if (!((sts = sys$open(&fab_in)) & 1)) {
11359       PerlMem_free(vmsin);
11360       PerlMem_free(vmsout);
11361       PerlMem_free(esa);
11362       PerlMem_free(rsa);
11363       set_vaxc_errno(sts);
11364       switch (sts) {
11365         case RMS$_FNF: case RMS$_DNF:
11366           set_errno(ENOENT); break;
11367         case RMS$_DIR:
11368           set_errno(ENOTDIR); break;
11369         case RMS$_DEV:
11370           set_errno(ENODEV); break;
11371         case RMS$_SYN:
11372           set_errno(EINVAL); break;
11373         case RMS$_PRV:
11374           set_errno(EACCES); break;
11375         default:
11376           set_errno(EVMSERR);
11377       }
11378       return 0;
11379     }
11380
11381     nam_out = nam;
11382     fab_out = fab_in;
11383     fab_out.fab$w_ifi = 0;
11384     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11385     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11386     fab_out.fab$l_fop = FAB$M_SQO;
11387     rms_bind_fab_nam(fab_out, nam_out);
11388     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11389     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11390     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11391     esa_out = PerlMem_malloc(VMS_MAXRSS);
11392     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11393     rms_set_rsa(nam_out, NULL, 0);
11394     rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11395
11396     if (preserve_dates == 0) {  /* Act like DCL COPY */
11397       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11398       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
11399       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11400         PerlMem_free(vmsin);
11401         PerlMem_free(vmsout);
11402         PerlMem_free(esa);
11403         PerlMem_free(rsa);
11404         PerlMem_free(esa_out);
11405         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11406         set_vaxc_errno(sts);
11407         return 0;
11408       }
11409       fab_out.fab$l_xab = (void *) &xabdat;
11410       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11411         preserve_dates = 1;
11412     }
11413     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
11414       preserve_dates =0;      /* bitmask from this point forward   */
11415
11416     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11417     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11418       PerlMem_free(vmsin);
11419       PerlMem_free(vmsout);
11420       PerlMem_free(esa);
11421       PerlMem_free(rsa);
11422       PerlMem_free(esa_out);
11423       set_vaxc_errno(sts);
11424       switch (sts) {
11425         case RMS$_DNF:
11426           set_errno(ENOENT); break;
11427         case RMS$_DIR:
11428           set_errno(ENOTDIR); break;
11429         case RMS$_DEV:
11430           set_errno(ENODEV); break;
11431         case RMS$_SYN:
11432           set_errno(EINVAL); break;
11433         case RMS$_PRV:
11434           set_errno(EACCES); break;
11435         default:
11436           set_errno(EVMSERR);
11437       }
11438       return 0;
11439     }
11440     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
11441     if (preserve_dates & 2) {
11442       /* sys$close() will process xabrdt, not xabdat */
11443       xabrdt = cc$rms_xabrdt;
11444 #ifndef __GNUC__
11445       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11446 #else
11447       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11448        * is unsigned long[2], while DECC & VAXC use a struct */
11449       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11450 #endif
11451       fab_out.fab$l_xab = (void *) &xabrdt;
11452     }
11453
11454     ubf = PerlMem_malloc(32256);
11455     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11456     rab_in = cc$rms_rab;
11457     rab_in.rab$l_fab = &fab_in;
11458     rab_in.rab$l_rop = RAB$M_BIO;
11459     rab_in.rab$l_ubf = ubf;
11460     rab_in.rab$w_usz = 32256;
11461     if (!((sts = sys$connect(&rab_in)) & 1)) {
11462       sys$close(&fab_in); sys$close(&fab_out);
11463       PerlMem_free(vmsin);
11464       PerlMem_free(vmsout);
11465       PerlMem_free(esa);
11466       PerlMem_free(ubf);
11467       PerlMem_free(rsa);
11468       PerlMem_free(esa_out);
11469       set_errno(EVMSERR); set_vaxc_errno(sts);
11470       return 0;
11471     }
11472
11473     rab_out = cc$rms_rab;
11474     rab_out.rab$l_fab = &fab_out;
11475     rab_out.rab$l_rbf = ubf;
11476     if (!((sts = sys$connect(&rab_out)) & 1)) {
11477       sys$close(&fab_in); sys$close(&fab_out);
11478       PerlMem_free(vmsin);
11479       PerlMem_free(vmsout);
11480       PerlMem_free(esa);
11481       PerlMem_free(ubf);
11482       PerlMem_free(rsa);
11483       PerlMem_free(esa_out);
11484       set_errno(EVMSERR); set_vaxc_errno(sts);
11485       return 0;
11486     }
11487
11488     while ((sts = sys$read(&rab_in))) {  /* always true  */
11489       if (sts == RMS$_EOF) break;
11490       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11491       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11492         sys$close(&fab_in); sys$close(&fab_out);
11493         PerlMem_free(vmsin);
11494         PerlMem_free(vmsout);
11495         PerlMem_free(esa);
11496         PerlMem_free(ubf);
11497         PerlMem_free(rsa);
11498         PerlMem_free(esa_out);
11499         set_errno(EVMSERR); set_vaxc_errno(sts);
11500         return 0;
11501       }
11502     }
11503
11504
11505     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
11506     sys$close(&fab_in);  sys$close(&fab_out);
11507     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11508     if (!(sts & 1)) {
11509       PerlMem_free(vmsin);
11510       PerlMem_free(vmsout);
11511       PerlMem_free(esa);
11512       PerlMem_free(ubf);
11513       PerlMem_free(rsa);
11514       PerlMem_free(esa_out);
11515       set_errno(EVMSERR); set_vaxc_errno(sts);
11516       return 0;
11517     }
11518
11519     PerlMem_free(vmsin);
11520     PerlMem_free(vmsout);
11521     PerlMem_free(esa);
11522     PerlMem_free(ubf);
11523     PerlMem_free(rsa);
11524     PerlMem_free(esa_out);
11525     return 1;
11526
11527 }  /* end of rmscopy() */
11528 /*}}}*/
11529
11530
11531 /***  The following glue provides 'hooks' to make some of the routines
11532  * from this file available from Perl.  These routines are sufficiently
11533  * basic, and are required sufficiently early in the build process,
11534  * that's it's nice to have them available to miniperl as well as the
11535  * full Perl, so they're set up here instead of in an extension.  The
11536  * Perl code which handles importation of these names into a given
11537  * package lives in [.VMS]Filespec.pm in @INC.
11538  */
11539
11540 void
11541 rmsexpand_fromperl(pTHX_ CV *cv)
11542 {
11543   dXSARGS;
11544   char *fspec, *defspec = NULL, *rslt;
11545   STRLEN n_a;
11546   int fs_utf8, dfs_utf8;
11547
11548   fs_utf8 = 0;
11549   dfs_utf8 = 0;
11550   if (!items || items > 2)
11551     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11552   fspec = SvPV(ST(0),n_a);
11553   fs_utf8 = SvUTF8(ST(0));
11554   if (!fspec || !*fspec) XSRETURN_UNDEF;
11555   if (items == 2) {
11556     defspec = SvPV(ST(1),n_a);
11557     dfs_utf8 = SvUTF8(ST(1));
11558   }
11559   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11560   ST(0) = sv_newmortal();
11561   if (rslt != NULL) {
11562     sv_usepvn(ST(0),rslt,strlen(rslt));
11563     if (fs_utf8) {
11564         SvUTF8_on(ST(0));
11565     }
11566   }
11567   XSRETURN(1);
11568 }
11569
11570 void
11571 vmsify_fromperl(pTHX_ CV *cv)
11572 {
11573   dXSARGS;
11574   char *vmsified;
11575   STRLEN n_a;
11576   int utf8_fl;
11577
11578   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11579   utf8_fl = SvUTF8(ST(0));
11580   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11581   ST(0) = sv_newmortal();
11582   if (vmsified != NULL) {
11583     sv_usepvn(ST(0),vmsified,strlen(vmsified));
11584     if (utf8_fl) {
11585         SvUTF8_on(ST(0));
11586     }
11587   }
11588   XSRETURN(1);
11589 }
11590
11591 void
11592 unixify_fromperl(pTHX_ CV *cv)
11593 {
11594   dXSARGS;
11595   char *unixified;
11596   STRLEN n_a;
11597   int utf8_fl;
11598
11599   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11600   utf8_fl = SvUTF8(ST(0));
11601   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11602   ST(0) = sv_newmortal();
11603   if (unixified != NULL) {
11604     sv_usepvn(ST(0),unixified,strlen(unixified));
11605     if (utf8_fl) {
11606         SvUTF8_on(ST(0));
11607     }
11608   }
11609   XSRETURN(1);
11610 }
11611
11612 void
11613 fileify_fromperl(pTHX_ CV *cv)
11614 {
11615   dXSARGS;
11616   char *fileified;
11617   STRLEN n_a;
11618   int utf8_fl;
11619
11620   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11621   utf8_fl = SvUTF8(ST(0));
11622   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11623   ST(0) = sv_newmortal();
11624   if (fileified != NULL) {
11625     sv_usepvn(ST(0),fileified,strlen(fileified));
11626     if (utf8_fl) {
11627         SvUTF8_on(ST(0));
11628     }
11629   }
11630   XSRETURN(1);
11631 }
11632
11633 void
11634 pathify_fromperl(pTHX_ CV *cv)
11635 {
11636   dXSARGS;
11637   char *pathified;
11638   STRLEN n_a;
11639   int utf8_fl;
11640
11641   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11642   utf8_fl = SvUTF8(ST(0));
11643   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11644   ST(0) = sv_newmortal();
11645   if (pathified != NULL) {
11646     sv_usepvn(ST(0),pathified,strlen(pathified));
11647     if (utf8_fl) {
11648         SvUTF8_on(ST(0));
11649     }
11650   }
11651   XSRETURN(1);
11652 }
11653
11654 void
11655 vmspath_fromperl(pTHX_ CV *cv)
11656 {
11657   dXSARGS;
11658   char *vmspath;
11659   STRLEN n_a;
11660   int utf8_fl;
11661
11662   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11663   utf8_fl = SvUTF8(ST(0));
11664   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11665   ST(0) = sv_newmortal();
11666   if (vmspath != NULL) {
11667     sv_usepvn(ST(0),vmspath,strlen(vmspath));
11668     if (utf8_fl) {
11669         SvUTF8_on(ST(0));
11670     }
11671   }
11672   XSRETURN(1);
11673 }
11674
11675 void
11676 unixpath_fromperl(pTHX_ CV *cv)
11677 {
11678   dXSARGS;
11679   char *unixpath;
11680   STRLEN n_a;
11681   int utf8_fl;
11682
11683   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11684   utf8_fl = SvUTF8(ST(0));
11685   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11686   ST(0) = sv_newmortal();
11687   if (unixpath != NULL) {
11688     sv_usepvn(ST(0),unixpath,strlen(unixpath));
11689     if (utf8_fl) {
11690         SvUTF8_on(ST(0));
11691     }
11692   }
11693   XSRETURN(1);
11694 }
11695
11696 void
11697 candelete_fromperl(pTHX_ CV *cv)
11698 {
11699   dXSARGS;
11700   char *fspec, *fsp;
11701   SV *mysv;
11702   IO *io;
11703   STRLEN n_a;
11704
11705   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11706
11707   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11708   Newx(fspec, VMS_MAXRSS, char);
11709   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11710   if (SvTYPE(mysv) == SVt_PVGV) {
11711     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11712       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11713       ST(0) = &PL_sv_no;
11714       Safefree(fspec);
11715       XSRETURN(1);
11716     }
11717     fsp = fspec;
11718   }
11719   else {
11720     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11721       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11722       ST(0) = &PL_sv_no;
11723       Safefree(fspec);
11724       XSRETURN(1);
11725     }
11726   }
11727
11728   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11729   Safefree(fspec);
11730   XSRETURN(1);
11731 }
11732
11733 void
11734 rmscopy_fromperl(pTHX_ CV *cv)
11735 {
11736   dXSARGS;
11737   char *inspec, *outspec, *inp, *outp;
11738   int date_flag;
11739   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11740                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11741   unsigned long int sts;
11742   SV *mysv;
11743   IO *io;
11744   STRLEN n_a;
11745
11746   if (items < 2 || items > 3)
11747     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11748
11749   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11750   Newx(inspec, VMS_MAXRSS, char);
11751   if (SvTYPE(mysv) == SVt_PVGV) {
11752     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11753       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11754       ST(0) = &PL_sv_no;
11755       Safefree(inspec);
11756       XSRETURN(1);
11757     }
11758     inp = inspec;
11759   }
11760   else {
11761     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11762       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11763       ST(0) = &PL_sv_no;
11764       Safefree(inspec);
11765       XSRETURN(1);
11766     }
11767   }
11768   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11769   Newx(outspec, VMS_MAXRSS, char);
11770   if (SvTYPE(mysv) == SVt_PVGV) {
11771     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11772       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11773       ST(0) = &PL_sv_no;
11774       Safefree(inspec);
11775       Safefree(outspec);
11776       XSRETURN(1);
11777     }
11778     outp = outspec;
11779   }
11780   else {
11781     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11782       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11783       ST(0) = &PL_sv_no;
11784       Safefree(inspec);
11785       Safefree(outspec);
11786       XSRETURN(1);
11787     }
11788   }
11789   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11790
11791   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11792   Safefree(inspec);
11793   Safefree(outspec);
11794   XSRETURN(1);
11795 }
11796
11797 /* The mod2fname is limited to shorter filenames by design, so it should
11798  * not be modified to support longer EFS pathnames
11799  */
11800 void
11801 mod2fname(pTHX_ CV *cv)
11802 {
11803   dXSARGS;
11804   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11805        workbuff[NAM$C_MAXRSS*1 + 1];
11806   int total_namelen = 3, counter, num_entries;
11807   /* ODS-5 ups this, but we want to be consistent, so... */
11808   int max_name_len = 39;
11809   AV *in_array = (AV *)SvRV(ST(0));
11810
11811   num_entries = av_len(in_array);
11812
11813   /* All the names start with PL_. */
11814   strcpy(ultimate_name, "PL_");
11815
11816   /* Clean up our working buffer */
11817   Zero(work_name, sizeof(work_name), char);
11818
11819   /* Run through the entries and build up a working name */
11820   for(counter = 0; counter <= num_entries; counter++) {
11821     /* If it's not the first name then tack on a __ */
11822     if (counter) {
11823       strcat(work_name, "__");
11824     }
11825     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11826                            PL_na));
11827   }
11828
11829   /* Check to see if we actually have to bother...*/
11830   if (strlen(work_name) + 3 <= max_name_len) {
11831     strcat(ultimate_name, work_name);
11832   } else {
11833     /* It's too darned big, so we need to go strip. We use the same */
11834     /* algorithm as xsubpp does. First, strip out doubled __ */
11835     char *source, *dest, last;
11836     dest = workbuff;
11837     last = 0;
11838     for (source = work_name; *source; source++) {
11839       if (last == *source && last == '_') {
11840         continue;
11841       }
11842       *dest++ = *source;
11843       last = *source;
11844     }
11845     /* Go put it back */
11846     strcpy(work_name, workbuff);
11847     /* Is it still too big? */
11848     if (strlen(work_name) + 3 > max_name_len) {
11849       /* Strip duplicate letters */
11850       last = 0;
11851       dest = workbuff;
11852       for (source = work_name; *source; source++) {
11853         if (last == toupper(*source)) {
11854         continue;
11855         }
11856         *dest++ = *source;
11857         last = toupper(*source);
11858       }
11859       strcpy(work_name, workbuff);
11860     }
11861
11862     /* Is it *still* too big? */
11863     if (strlen(work_name) + 3 > max_name_len) {
11864       /* Too bad, we truncate */
11865       work_name[max_name_len - 2] = 0;
11866     }
11867     strcat(ultimate_name, work_name);
11868   }
11869
11870   /* Okay, return it */
11871   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11872   XSRETURN(1);
11873 }
11874
11875 void
11876 hushexit_fromperl(pTHX_ CV *cv)
11877 {
11878     dXSARGS;
11879
11880     if (items > 0) {
11881         VMSISH_HUSHED = SvTRUE(ST(0));
11882     }
11883     ST(0) = boolSV(VMSISH_HUSHED);
11884     XSRETURN(1);
11885 }
11886
11887
11888 PerlIO *
11889 Perl_vms_start_glob
11890    (pTHX_ SV *tmpglob,
11891     IO *io)
11892 {
11893     PerlIO *fp;
11894     struct vs_str_st *rslt;
11895     char *vmsspec;
11896     char *rstr;
11897     char *begin, *cp;
11898     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11899     PerlIO *tmpfp;
11900     STRLEN i;
11901     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11902     struct dsc$descriptor_vs rsdsc;
11903     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11904     unsigned long hasver = 0, isunix = 0;
11905     unsigned long int lff_flags = 0;
11906     int rms_sts;
11907
11908 #ifdef VMS_LONGNAME_SUPPORT
11909     lff_flags = LIB$M_FIL_LONG_NAMES;
11910 #endif
11911     /* The Newx macro will not allow me to assign a smaller array
11912      * to the rslt pointer, so we will assign it to the begin char pointer
11913      * and then copy the value into the rslt pointer.
11914      */
11915     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11916     rslt = (struct vs_str_st *)begin;
11917     rslt->length = 0;
11918     rstr = &rslt->str[0];
11919     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11920     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11921     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11922     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11923
11924     Newx(vmsspec, VMS_MAXRSS, char);
11925
11926         /* We could find out if there's an explicit dev/dir or version
11927            by peeking into lib$find_file's internal context at
11928            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11929            but that's unsupported, so I don't want to do it now and
11930            have it bite someone in the future. */
11931         /* Fix-me: vms_split_path() is the only way to do this, the
11932            existing method will fail with many legal EFS or UNIX specifications
11933          */
11934
11935     cp = SvPV(tmpglob,i);
11936
11937     for (; i; i--) {
11938         if (cp[i] == ';') hasver = 1;
11939         if (cp[i] == '.') {
11940             if (sts) hasver = 1;
11941             else sts = 1;
11942         }
11943         if (cp[i] == '/') {
11944             hasdir = isunix = 1;
11945             break;
11946         }
11947         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11948             hasdir = 1;
11949             break;
11950         }
11951     }
11952     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11953         Stat_t st;
11954         int stat_sts;
11955         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11956         if (!stat_sts && S_ISDIR(st.st_mode)) {
11957             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
11958             ok = (wilddsc.dsc$a_pointer != NULL);
11959         }
11960         else {
11961             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
11962             ok = (wilddsc.dsc$a_pointer != NULL);
11963         }
11964         if (ok)
11965             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11966
11967         /* If not extended character set, replace ? with % */
11968         /* With extended character set, ? is a wildcard single character */
11969         if (!decc_efs_case_preserve) {
11970             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11971                 if (*cp == '?') *cp = '%';
11972         }
11973         sts = SS$_NORMAL;
11974         while (ok && $VMS_STATUS_SUCCESS(sts)) {
11975          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11976          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11977
11978             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11979                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
11980             if (!$VMS_STATUS_SUCCESS(sts))
11981                 break;
11982
11983             /* with varying string, 1st word of buffer contains result length */
11984             rstr[rslt->length] = '\0';
11985
11986              /* Find where all the components are */
11987              v_sts = vms_split_path
11988                        (rstr,
11989                         &v_spec,
11990                         &v_len,
11991                         &r_spec,
11992                         &r_len,
11993                         &d_spec,
11994                         &d_len,
11995                         &n_spec,
11996                         &n_len,
11997                         &e_spec,
11998                         &e_len,
11999                         &vs_spec,
12000                         &vs_len);
12001
12002             /* If no version on input, truncate the version on output */
12003             if (!hasver && (vs_len > 0)) {
12004                 *vs_spec = '\0';
12005                 vs_len = 0;
12006
12007                 /* No version & a null extension on UNIX handling */
12008                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12009                     e_len = 0;
12010                     *e_spec = '\0';
12011                 }
12012             }
12013
12014             if (!decc_efs_case_preserve) {
12015                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12016             }
12017
12018             if (hasdir) {
12019                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12020                 begin = rstr;
12021             }
12022             else {
12023                 /* Start with the name */
12024                 begin = n_spec;
12025             }
12026             strcat(begin,"\n");
12027             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12028         }
12029         if (cxt) (void)lib$find_file_end(&cxt);
12030         if (ok && sts != RMS$_NMF &&
12031             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12032         if (!ok) {
12033             if (!(sts & 1)) {
12034                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12035             }
12036             PerlIO_close(tmpfp);
12037             fp = NULL;
12038         }
12039         else {
12040             PerlIO_rewind(tmpfp);
12041             IoTYPE(io) = IoTYPE_RDONLY;
12042             IoIFP(io) = fp = tmpfp;
12043             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
12044         }
12045     }
12046     Safefree(vmsspec);
12047     Safefree(rslt);
12048     return fp;
12049 }
12050
12051
12052 #ifdef HAS_SYMLINK
12053 static char *
12054 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
12055
12056 void
12057 vms_realpath_fromperl(pTHX_ CV *cv)
12058 {
12059   dXSARGS;
12060   char *fspec, *rslt_spec, *rslt;
12061   STRLEN n_a;
12062
12063   if (!items || items != 1)
12064     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12065
12066   fspec = SvPV(ST(0),n_a);
12067   if (!fspec || !*fspec) XSRETURN_UNDEF;
12068
12069   Newx(rslt_spec, VMS_MAXRSS + 1, char);
12070   rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12071   ST(0) = sv_newmortal();
12072   if (rslt != NULL)
12073     sv_usepvn(ST(0),rslt,strlen(rslt));
12074   else
12075     Safefree(rslt_spec);
12076   XSRETURN(1);
12077 }
12078 #endif
12079
12080 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12081 int do_vms_case_tolerant(void);
12082
12083 void
12084 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12085 {
12086   dXSARGS;
12087   ST(0) = boolSV(do_vms_case_tolerant());
12088   XSRETURN(1);
12089 }
12090 #endif
12091
12092 void
12093 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12094                           struct interp_intern *dst)
12095 {
12096     memcpy(dst,src,sizeof(struct interp_intern));
12097 }
12098
12099 void
12100 Perl_sys_intern_clear(pTHX)
12101 {
12102 }
12103
12104 void
12105 Perl_sys_intern_init(pTHX)
12106 {
12107     unsigned int ix = RAND_MAX;
12108     double x;
12109
12110     VMSISH_HUSHED = 0;
12111
12112     /* fix me later to track running under GNV */
12113     /* this allows some limited testing */
12114     MY_POSIX_EXIT = decc_filename_unix_report;
12115
12116     x = (float)ix;
12117     MY_INV_RAND_MAX = 1./x;
12118 }
12119
12120 void
12121 init_os_extras(void)
12122 {
12123   dTHX;
12124   char* file = __FILE__;
12125   if (decc_disable_to_vms_logname_translation) {
12126     no_translate_barewords = TRUE;
12127   } else {
12128     no_translate_barewords = FALSE;
12129   }
12130
12131   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
12132   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
12133   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
12134   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
12135   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
12136   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
12137   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
12138   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
12139   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
12140   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
12141   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
12142 #ifdef HAS_SYMLINK
12143   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
12144 #endif
12145 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12146   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
12147 #endif
12148
12149   store_pipelocs(aTHX);         /* will redo any earlier attempts */
12150
12151   return;
12152 }
12153
12154 #ifdef HAS_SYMLINK
12155
12156 #if __CRTL_VER == 80200000
12157 /* This missed getting in to the DECC SDK for 8.2 */
12158 char *realpath(const char *file_name, char * resolved_name, ...);
12159 #endif
12160
12161 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
12162 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
12163  * The perl fallback routine to provide realpath() is not as efficient
12164  * on OpenVMS.
12165  */
12166 static char *
12167 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12168 {
12169     return realpath(filespec, outbuf);
12170 }
12171
12172 /*}}}*/
12173 /* External entry points */
12174 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12175 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
12176 #else
12177 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12178 { return NULL; }
12179 #endif
12180
12181
12182 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12183 /* case_tolerant */
12184
12185 /*{{{int do_vms_case_tolerant(void)*/
12186 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
12187  * controlled by a process setting.
12188  */
12189 int do_vms_case_tolerant(void)
12190 {
12191     return vms_process_case_tolerant;
12192 }
12193 /*}}}*/
12194 /* External entry points */
12195 int Perl_vms_case_tolerant(void)
12196 { return do_vms_case_tolerant(); }
12197 #else
12198 int Perl_vms_case_tolerant(void)
12199 { return vms_process_case_tolerant; }
12200 #endif
12201
12202
12203  /* Start of DECC RTL Feature handling */
12204
12205 static int sys_trnlnm
12206    (const char * logname,
12207     char * value,
12208     int value_len)
12209 {
12210     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
12211     const unsigned long attr = LNM$M_CASE_BLIND;
12212     struct dsc$descriptor_s name_dsc;
12213     int status;
12214     unsigned short result;
12215     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
12216                                 {0, 0, 0, 0}};
12217
12218     name_dsc.dsc$w_length = strlen(logname);
12219     name_dsc.dsc$a_pointer = (char *)logname;
12220     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12221     name_dsc.dsc$b_class = DSC$K_CLASS_S;
12222
12223     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
12224
12225     if ($VMS_STATUS_SUCCESS(status)) {
12226
12227          /* Null terminate and return the string */
12228         /*--------------------------------------*/
12229         value[result] = 0;
12230     }
12231
12232     return status;
12233 }
12234
12235 static int sys_crelnm
12236    (const char * logname,
12237     const char * value)
12238 {
12239     int ret_val;
12240     const char * proc_table = "LNM$PROCESS_TABLE";
12241     struct dsc$descriptor_s proc_table_dsc;
12242     struct dsc$descriptor_s logname_dsc;
12243     struct itmlst_3 item_list[2];
12244
12245     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
12246     proc_table_dsc.dsc$w_length = strlen(proc_table);
12247     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12248     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
12249
12250     logname_dsc.dsc$a_pointer = (char *) logname;
12251     logname_dsc.dsc$w_length = strlen(logname);
12252     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12253     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
12254
12255     item_list[0].buflen = strlen(value);
12256     item_list[0].itmcode = LNM$_STRING;
12257     item_list[0].bufadr = (char *)value;
12258     item_list[0].retlen = NULL;
12259
12260     item_list[1].buflen = 0;
12261     item_list[1].itmcode = 0;
12262
12263     ret_val = sys$crelnm
12264                        (NULL,
12265                         (const struct dsc$descriptor_s *)&proc_table_dsc,
12266                         (const struct dsc$descriptor_s *)&logname_dsc,
12267                         NULL,
12268                         (const struct item_list_3 *) item_list);
12269
12270     return ret_val;
12271 }
12272
12273 /* C RTL Feature settings */
12274
12275 static int set_features
12276    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
12277     int (* cli_routine)(void),  /* Not documented */
12278     void *image_info)           /* Not documented */
12279 {
12280     int status;
12281     int s;
12282     int dflt;
12283     char* str;
12284     char val_str[10];
12285 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12286     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12287     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12288     unsigned long case_perm;
12289     unsigned long case_image;
12290 #endif
12291
12292     /* Allow an exception to bring Perl into the VMS debugger */
12293     vms_debug_on_exception = 0;
12294     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12295     if ($VMS_STATUS_SUCCESS(status)) {
12296        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12297          vms_debug_on_exception = 1;
12298        else
12299          vms_debug_on_exception = 0;
12300     }
12301
12302     /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
12303     vms_vtf7_filenames = 0;
12304     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12305     if ($VMS_STATUS_SUCCESS(status)) {
12306        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12307          vms_vtf7_filenames = 1;
12308        else
12309          vms_vtf7_filenames = 0;
12310     }
12311
12312     /* Dectect running under GNV Bash or other UNIX like shell */
12313 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12314     gnv_unix_shell = 0;
12315     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12316     if ($VMS_STATUS_SUCCESS(status)) {
12317        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12318          gnv_unix_shell = 1;
12319          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12320          set_feature_default("DECC$EFS_CHARSET", 1);
12321          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12322          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12323          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12324          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12325        }
12326        else
12327          gnv_unix_shell = 0;
12328     }
12329 #endif
12330
12331     /* hacks to see if known bugs are still present for testing */
12332
12333     /* Readdir is returning filenames in VMS syntax always */
12334     decc_bug_readdir_efs1 = 1;
12335     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12336     if ($VMS_STATUS_SUCCESS(status)) {
12337        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12338          decc_bug_readdir_efs1 = 1;
12339        else
12340          decc_bug_readdir_efs1 = 0;
12341     }
12342
12343     /* PCP mode requires creating /dev/null special device file */
12344     decc_bug_devnull = 0;
12345     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12346     if ($VMS_STATUS_SUCCESS(status)) {
12347        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12348           decc_bug_devnull = 1;
12349        else
12350           decc_bug_devnull = 0;
12351     }
12352
12353     /* fgetname returning a VMS name in UNIX mode */
12354     decc_bug_fgetname = 1;
12355     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12356     if ($VMS_STATUS_SUCCESS(status)) {
12357       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12358         decc_bug_fgetname = 1;
12359       else
12360         decc_bug_fgetname = 0;
12361     }
12362
12363     /* UNIX directory names with no paths are broken in a lot of places */
12364     decc_dir_barename = 1;
12365     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12366     if ($VMS_STATUS_SUCCESS(status)) {
12367       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12368         decc_dir_barename = 1;
12369       else
12370         decc_dir_barename = 0;
12371     }
12372
12373 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12374     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12375     if (s >= 0) {
12376         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12377         if (decc_disable_to_vms_logname_translation < 0)
12378             decc_disable_to_vms_logname_translation = 0;
12379     }
12380
12381     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12382     if (s >= 0) {
12383         decc_efs_case_preserve = decc$feature_get_value(s, 1);
12384         if (decc_efs_case_preserve < 0)
12385             decc_efs_case_preserve = 0;
12386     }
12387
12388     s = decc$feature_get_index("DECC$EFS_CHARSET");
12389     if (s >= 0) {
12390         decc_efs_charset = decc$feature_get_value(s, 1);
12391         if (decc_efs_charset < 0)
12392             decc_efs_charset = 0;
12393     }
12394
12395     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12396     if (s >= 0) {
12397         decc_filename_unix_report = decc$feature_get_value(s, 1);
12398         if (decc_filename_unix_report > 0)
12399             decc_filename_unix_report = 1;
12400         else
12401             decc_filename_unix_report = 0;
12402     }
12403
12404     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12405     if (s >= 0) {
12406         decc_filename_unix_only = decc$feature_get_value(s, 1);
12407         if (decc_filename_unix_only > 0) {
12408             decc_filename_unix_only = 1;
12409         }
12410         else {
12411             decc_filename_unix_only = 0;
12412         }
12413     }
12414
12415     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12416     if (s >= 0) {
12417         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12418         if (decc_filename_unix_no_version < 0)
12419             decc_filename_unix_no_version = 0;
12420     }
12421
12422     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12423     if (s >= 0) {
12424         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12425         if (decc_readdir_dropdotnotype < 0)
12426             decc_readdir_dropdotnotype = 0;
12427     }
12428
12429     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12430     if ($VMS_STATUS_SUCCESS(status)) {
12431         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12432         if (s >= 0) {
12433             dflt = decc$feature_get_value(s, 4);
12434             if (dflt > 0) {
12435                 decc_disable_posix_root = decc$feature_get_value(s, 1);
12436                 if (decc_disable_posix_root <= 0) {
12437                     decc$feature_set_value(s, 1, 1);
12438                     decc_disable_posix_root = 1;
12439                 }
12440             }
12441             else {
12442                 /* Traditionally Perl assumes this is off */
12443                 decc_disable_posix_root = 1;
12444                 decc$feature_set_value(s, 1, 1);
12445             }
12446         }
12447     }
12448
12449 #if __CRTL_VER >= 80200000
12450     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12451     if (s >= 0) {
12452         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12453         if (decc_posix_compliant_pathnames < 0)
12454             decc_posix_compliant_pathnames = 0;
12455         if (decc_posix_compliant_pathnames > 4)
12456             decc_posix_compliant_pathnames = 0;
12457     }
12458
12459 #endif
12460 #else
12461     status = sys_trnlnm
12462         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12463     if ($VMS_STATUS_SUCCESS(status)) {
12464         val_str[0] = _toupper(val_str[0]);
12465         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12466            decc_disable_to_vms_logname_translation = 1;
12467         }
12468     }
12469
12470 #ifndef __VAX
12471     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12472     if ($VMS_STATUS_SUCCESS(status)) {
12473         val_str[0] = _toupper(val_str[0]);
12474         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12475            decc_efs_case_preserve = 1;
12476         }
12477     }
12478 #endif
12479
12480     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12481     if ($VMS_STATUS_SUCCESS(status)) {
12482         val_str[0] = _toupper(val_str[0]);
12483         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12484            decc_filename_unix_report = 1;
12485         }
12486     }
12487     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12488     if ($VMS_STATUS_SUCCESS(status)) {
12489         val_str[0] = _toupper(val_str[0]);
12490         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12491            decc_filename_unix_only = 1;
12492            decc_filename_unix_report = 1;
12493         }
12494     }
12495     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12496     if ($VMS_STATUS_SUCCESS(status)) {
12497         val_str[0] = _toupper(val_str[0]);
12498         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12499            decc_filename_unix_no_version = 1;
12500         }
12501     }
12502     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12503     if ($VMS_STATUS_SUCCESS(status)) {
12504         val_str[0] = _toupper(val_str[0]);
12505         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12506            decc_readdir_dropdotnotype = 1;
12507         }
12508     }
12509 #endif
12510
12511 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12512
12513      /* Report true case tolerance */
12514     /*----------------------------*/
12515     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12516     if (!$VMS_STATUS_SUCCESS(status))
12517         case_perm = PPROP$K_CASE_BLIND;
12518     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12519     if (!$VMS_STATUS_SUCCESS(status))
12520         case_image = PPROP$K_CASE_BLIND;
12521     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12522         (case_image == PPROP$K_CASE_SENSITIVE))
12523         vms_process_case_tolerant = 0;
12524
12525 #endif
12526
12527
12528     /* CRTL can be initialized past this point, but not before. */
12529 /*    DECC$CRTL_INIT(); */
12530
12531     return SS$_NORMAL;
12532 }
12533
12534 #ifdef __DECC
12535 /* DECC dependent attributes */
12536 #if __DECC_VER < 60560002
12537 #define relative
12538 #define not_executable
12539 #else
12540 #define relative ,rel
12541 #define not_executable ,noexe
12542 #endif
12543 #pragma nostandard
12544 #pragma extern_model save
12545 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12546 #endif
12547         const __align (LONGWORD) int spare[8] = {0};
12548 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
12549 /*                        NOWRT, LONG */
12550 #ifdef __DECC
12551 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
12552         nowrt,noshr relative not_executable
12553 #endif
12554 const long vms_cc_features = (const long)set_features;
12555
12556 /*
12557 ** Force a reference to LIB$INITIALIZE to ensure it
12558 ** exists in the image.
12559 */
12560 int lib$initialize(void);
12561 #ifdef __DECC
12562 #pragma extern_model strict_refdef
12563 #endif
12564     int lib_init_ref = (int) lib$initialize;
12565
12566 #ifdef __DECC
12567 #pragma extern_model restore
12568 #pragma standard
12569 #endif
12570
12571 /*  End of vms.c */