vms/vms.c

   1 /* vms.c
   2  *
   3  * VMS-specific routines for perl5
   4  * Version: 5.7.0
   5  *
   6  * August 2005 Convert VMS status code to UNIX status codes
   7  * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
   8  *             and Perl_cando by Craig Berry
   9  * 29-Aug-2000 Charles Lane's piping improvements rolled in
  10  * 20-Aug-1999 revisions by Charles Bailey  bailey@newman.upenn.edu
  11  */
  12
  13 #include <acedef.h>
  14 #include <acldef.h>
  15 #include <armdef.h>
  16 #include <atrdef.h>
  17 #include <chpdef.h>
  18 #include <clidef.h>
  19 #include <climsgdef.h>
  20 #include <dcdef.h>
  21 #include <descrip.h>
  22 #include <devdef.h>
  23 #include <dvidef.h>
  24 #include <fibdef.h>
  25 #include <float.h>
  26 #include <fscndef.h>
  27 #include <iodef.h>
  28 #include <jpidef.h>
  29 #include <kgbdef.h>
  30 #include <libclidef.h>
  31 #include <libdef.h>
  32 #include <lib$routines.h>
  33 #include <lnmdef.h>
  34 #include <msgdef.h>
  35 #if __CRTL_VER >= 70301000 && !defined(__VAX)
  36 #include <ppropdef.h>
  37 #endif
  38 #include <prvdef.h>
  39 #include <psldef.h>
  40 #include <rms.h>
  41 #include <shrdef.h>
  42 #include <ssdef.h>
  43 #include <starlet.h>
  44 #include <strdef.h>
  45 #include <str$routines.h>
  46 #include <syidef.h>
  47 #include <uaidef.h>
  48 #include <uicdef.h>
  49 #include <stsdef.h>
  50 #include <rmsdef.h>
  51 #include <smgdef.h>
  52 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
  53 #include <efndef.h>
  54 #define NO_EFN EFN$C_ENF
  55 #else
  56 #define NO_EFN 0;
  57 #endif
  58
  59 #if  __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
  60 int   decc$feature_get_index(const char *name);
  61 char* decc$feature_get_name(int index);
  62 int   decc$feature_get_value(int index, int mode);
  63 int   decc$feature_set_value(int index, int mode, int value);
  64 #else
  65 #include <unixlib.h>
  66 #endif
  67
  68 #pragma member_alignment save
  69 #pragma nomember_alignment longword
  70 struct item_list_3 {
  71         unsigned short len;
  72         unsigned short code;
  73         void * bufadr;
  74         unsigned short * retadr;
  75 };
  76 #pragma member_alignment restore
  77
  78 /* More specific prototype than in starlet_c.h makes programming errors
  79    more visible.
  80  */
  81 #ifdef sys$getdviw
  82 #undef sys$getdviw
  83 int sys$getdviw
  84        (unsigned long efn,
  85         unsigned short chan,
  86         const struct dsc$descriptor_s * devnam,
  87         const struct item_list_3 * itmlst,
  88         void * iosb,
  89         void * (astadr)(unsigned long),
  90         void * astprm,
  91         void * nullarg);
  92 #endif
  93
  94 #if __CRTL_VER >= 70300000 && !defined(__VAX)
  95
  96 static int set_feature_default(const char *name, int value)
  97 {
  98     int status;
  99     int index;
 100
 101     index = decc$feature_get_index(name);
 102
 103     status = decc$feature_set_value(index, 1, value);
 104     if (index == -1 || (status == -1)) {
 105       return -1;
 106     }
 107
 108     status = decc$feature_get_value(index, 1);
 109     if (status != value) {
 110       return -1;
 111     }
 112
 113 return 0;
 114 }
 115 #endif
 116
 117 /* Older versions of ssdef.h don't have these */
 118 #ifndef SS$_INVFILFOROP
 119 #  define SS$_INVFILFOROP 3930
 120 #endif
 121 #ifndef SS$_NOSUCHOBJECT
 122 #  define SS$_NOSUCHOBJECT 2696
 123 #endif
 124
 125 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
 126 #define PERLIO_NOT_STDIO 0
 127
 128 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
 129  * code below needs to get to the underlying CRTL routines. */
 130 #define DONT_MASK_RTL_CALLS
 131 #include "EXTERN.h"
 132 #include "perl.h"
 133 #include "XSUB.h"
 134 /* Anticipating future expansion in lexical warnings . . . */
 135 #ifndef WARN_INTERNAL
 136 #  define WARN_INTERNAL WARN_MISC
 137 #endif
 138
 139 #ifdef VMS_LONGNAME_SUPPORT
 140 #include <libfildef.h>
 141 #endif
 142
 143 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
 144 #  define RTL_USES_UTC 1
 145 #endif
 146
 147 #ifdef USE_VMS_DECTERM
 148
 149 /* Routine to create a decterm for use with the Perl debugger */
 150 /* No headers, this information was found in the Programming Concepts Manual */
 151
 152 int decw$term_port
 153    (const struct dsc$descriptor_s * display,
 154     const struct dsc$descriptor_s * setup_file,
 155     const struct dsc$descriptor_s * customization,
 156     struct dsc$descriptor_s * result_device_name,
 157     unsigned short * result_device_name_length,
 158     void * controller,
 159     void * char_buffer,
 160     void * char_change_buffer);
 161 #endif
 162
 163 /* gcc's header files don't #define direct access macros
 164  * corresponding to VAXC's variant structs */
 165 #ifdef __GNUC__
 166 #  define uic$v_format uic$r_uic_form.uic$v_format
 167 #  define uic$v_group uic$r_uic_form.uic$v_group
 168 #  define uic$v_member uic$r_uic_form.uic$v_member
 169 #  define prv$v_bypass  prv$r_prvdef_bits0.prv$v_bypass
 170 #  define prv$v_grpprv  prv$r_prvdef_bits0.prv$v_grpprv
 171 #  define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
 172 #  define prv$v_sysprv  prv$r_prvdef_bits0.prv$v_sysprv
 173 #endif
 174
 175 #if defined(NEED_AN_H_ERRNO)
 176 dEXT int h_errno;
 177 #endif
 178
 179 #ifdef __DECC
 180 #pragma message disable pragma
 181 #pragma member_alignment save
 182 #pragma nomember_alignment longword
 183 #pragma message save
 184 #pragma message disable misalgndmem
 185 #endif
 186 struct itmlst_3 {
 187   unsigned short int buflen;
 188   unsigned short int itmcode;
 189   void *bufadr;
 190   unsigned short int *retlen;
 191 };
 192
 193 struct filescan_itmlst_2 {
 194     unsigned short length;
 195     unsigned short itmcode;
 196     char * component;
 197 };
 198
 199 struct vs_str_st {
 200     unsigned short length;
 201     char str[65536];
 202 };
 203
 204 #ifdef __DECC
 205 #pragma message restore
 206 #pragma member_alignment restore
 207 #endif
 208
 209 #define do_fileify_dirspec(a,b,c,d)     mp_do_fileify_dirspec(aTHX_ a,b,c,d)
 210 #define do_pathify_dirspec(a,b,c,d)     mp_do_pathify_dirspec(aTHX_ a,b,c,d)
 211 #define do_tovmsspec(a,b,c,d)           mp_do_tovmsspec(aTHX_ a,b,c,0,d)
 212 #define do_tovmspath(a,b,c,d)           mp_do_tovmspath(aTHX_ a,b,c,d)
 213 #define do_rmsexpand(a,b,c,d,e,f,g)     mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
 214 #define do_vms_realpath(a,b,c)          mp_do_vms_realpath(aTHX_ a,b,c)
 215 #define do_tounixspec(a,b,c,d)          mp_do_tounixspec(aTHX_ a,b,c,d)
 216 #define do_tounixpath(a,b,c,d)          mp_do_tounixpath(aTHX_ a,b,c,d)
 217 #define do_vms_case_tolerant(a)         mp_do_vms_case_tolerant(a)
 218 #define expand_wild_cards(a,b,c,d)      mp_expand_wild_cards(aTHX_ a,b,c,d)
 219 #define getredirection(a,b)             mp_getredirection(aTHX_ a,b)
 220
 221 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
 222 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
 223 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
 224 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
 225
 226 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
 227 #define PERL_LNM_MAX_ALLOWED_INDEX 127
 228
 229 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
 230  * depending on the facility.  SHOW LOGICAL does 10, so we'll imitate that for
 231  * the Perl facility.
 232  */
 233 #define PERL_LNM_MAX_ITER 10
 234
 235   /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
 236 #if __CRTL_VER >= 70302000 && !defined(__VAX)
 237 #define MAX_DCL_SYMBOL          (8192)
 238 #define MAX_DCL_LINE_LENGTH     (4096 - 4)
 239 #else
 240 #define MAX_DCL_SYMBOL          (1024)
 241 #define MAX_DCL_LINE_LENGTH     (1024 - 4)
 242 #endif
 243
 244 static char *__mystrtolower(char *str)
 245 {
 246   if (str) for (; *str; ++str) *str= tolower(*str);
 247   return str;
 248 }
 249
 250 static struct dsc$descriptor_s fildevdsc =
 251   { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
 252 static struct dsc$descriptor_s crtlenvdsc =
 253   { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
 254 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
 255 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
 256 static struct dsc$descriptor_s **env_tables = defenv;
 257 static bool will_taint = FALSE;  /* tainting active, but no PL_curinterp yet */
 258
 259 /* True if we shouldn't treat barewords as logicals during directory */
 260 /* munching */
 261 static int no_translate_barewords;
 262
 263 #ifndef RTL_USES_UTC
 264 static int tz_updated = 1;
 265 #endif
 266
 267 /* DECC Features that may need to affect how Perl interprets
 268  * displays filename information
 269  */
 270 static int decc_disable_to_vms_logname_translation = 1;
 271 static int decc_disable_posix_root = 1;
 272 int decc_efs_case_preserve = 0;
 273 static int decc_efs_charset = 0;
 274 static int decc_filename_unix_no_version = 0;
 275 static int decc_filename_unix_only = 0;
 276 int decc_filename_unix_report = 0;
 277 int decc_posix_compliant_pathnames = 0;
 278 int decc_readdir_dropdotnotype = 0;
 279 static int vms_process_case_tolerant = 1;
 280 int vms_vtf7_filenames = 0;
 281 int gnv_unix_shell = 0;
 282
 283 /* bug workarounds if needed */
 284 int decc_bug_readdir_efs1 = 0;
 285 int decc_bug_devnull = 1;
 286 int decc_bug_fgetname = 0;
 287 int decc_dir_barename = 0;
 288
 289 static int vms_debug_on_exception = 0;
 290
 291 /* Is this a UNIX file specification?
 292  *   No longer a simple check with EFS file specs
 293  *   For now, not a full check, but need to
 294  *   handle POSIX ^UP^ specifications
 295  *   Fixing to handle ^/ cases would require
 296  *   changes to many other conversion routines.
 297  */
 298
 299 static int is_unix_filespec(const char *path)
 300 {
 301 int ret_val;
 302 const char * pch1;
 303
 304     ret_val = 0;
 305     if (strncmp(path,"\"^UP^",5) != 0) {
 306         pch1 = strchr(path, '/');
 307         if (pch1 != NULL)
 308             ret_val = 1;
 309         else {
 310
 311             /* If the user wants UNIX files, "." needs to be treated as in UNIX */
 312             if (decc_filename_unix_report || decc_filename_unix_only) {
 313             if (strcmp(path,".") == 0)
 314                 ret_val = 1;
 315             }
 316         }
 317     }
 318     return ret_val;
 319 }
 320
 321 /* This routine converts a UCS-2 character to be VTF-7 encoded.
 322  */
 323
 324 static void ucs2_to_vtf7
 325    (char *outspec,
 326     unsigned long ucs2_char,
 327     int * output_cnt)
 328 {
 329 unsigned char * ucs_ptr;
 330 int hex;
 331
 332     ucs_ptr = (unsigned char *)&ucs2_char;
 333
 334     outspec[0] = '^';
 335     outspec[1] = 'U';
 336     hex = (ucs_ptr[1] >> 4) & 0xf;
 337     if (hex < 0xA)
 338         outspec[2] = hex + '0';
 339     else
 340         outspec[2] = (hex - 9) + 'A';
 341     hex = ucs_ptr[1] & 0xF;
 342     if (hex < 0xA)
 343         outspec[3] = hex + '0';
 344     else {
 345         outspec[3] = (hex - 9) + 'A';
 346     }
 347     hex = (ucs_ptr[0] >> 4) & 0xf;
 348     if (hex < 0xA)
 349         outspec[4] = hex + '0';
 350     else
 351         outspec[4] = (hex - 9) + 'A';
 352     hex = ucs_ptr[1] & 0xF;
 353     if (hex < 0xA)
 354         outspec[5] = hex + '0';
 355     else {
 356         outspec[5] = (hex - 9) + 'A';
 357     }
 358     *output_cnt = 6;
 359 }
 360
 361
 362 /* This handles the conversion of a UNIX extended character set to a ^
 363  * escaped VMS character.
 364  * in a UNIX file specification.
 365  *
 366  * The output count variable contains the number of characters added
 367  * to the output string.
 368  *
 369  * The return value is the number of characters read from the input string
 370  */
 371 static int copy_expand_unix_filename_escape
 372   (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
 373 {
 374 int count;
 375 int scnt;
 376 int utf8_flag;
 377
 378     utf8_flag = 0;
 379     if (utf8_fl)
 380       utf8_flag = *utf8_fl;
 381
 382     count = 0;
 383     *output_cnt = 0;
 384     if (*inspec >= 0x80) {
 385         if (utf8_fl && vms_vtf7_filenames) {
 386         unsigned long ucs_char;
 387
 388             ucs_char = 0;
 389
 390             if ((*inspec & 0xE0) == 0xC0) {
 391                 /* 2 byte Unicode */
 392                 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
 393                 if (ucs_char >= 0x80) {
 394                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 395                     return 2;
 396                 }
 397             } else if ((*inspec & 0xF0) == 0xE0) {
 398                 /* 3 byte Unicode */
 399                 ucs_char = ((inspec[0] & 0xF) << 12) +
 400                    ((inspec[1] & 0x3f) << 6) +
 401                    (inspec[2] & 0x3f);
 402                 if (ucs_char >= 0x800) {
 403                     ucs2_to_vtf7(outspec, ucs_char, output_cnt);
 404                     return 3;
 405                 }
 406
 407 #if 0 /* I do not see longer sequences supported by OpenVMS */
 408       /* Maybe some one can fix this later */
 409             } else if ((*inspec & 0xF8) == 0xF0) {
 410                 /* 4 byte Unicode */
 411                 /* UCS-4 to UCS-2 */
 412             } else if ((*inspec & 0xFC) == 0xF8) {
 413                 /* 5 byte Unicode */
 414                 /* UCS-4 to UCS-2 */
 415             } else if ((*inspec & 0xFE) == 0xFC) {
 416                 /* 6 byte Unicode */
 417                 /* UCS-4 to UCS-2 */
 418 #endif
 419             }
 420         }
 421
 422         /* High bit set, but not a unicode character! */
 423
 424         /* Non printing DECMCS or ISO Latin-1 character? */
 425         if (*inspec <= 0x9F) {
 426         int hex;
 427             outspec[0] = '^';
 428             outspec++;
 429             hex = (*inspec >> 4) & 0xF;
 430             if (hex < 0xA)
 431                 outspec[1] = hex + '0';
 432             else {
 433                 outspec[1] = (hex - 9) + 'A';
 434             }
 435             hex = *inspec & 0xF;
 436             if (hex < 0xA)
 437                 outspec[2] = hex + '0';
 438             else {
 439                 outspec[2] = (hex - 9) + 'A';
 440             }
 441             *output_cnt = 3;
 442             return 1;
 443         } else if (*inspec == 0xA0) {
 444             outspec[0] = '^';
 445             outspec[1] = 'A';
 446             outspec[2] = '0';
 447             *output_cnt = 3;
 448             return 1;
 449         } else if (*inspec == 0xFF) {
 450             outspec[0] = '^';
 451             outspec[1] = 'F';
 452             outspec[2] = 'F';
 453             *output_cnt = 3;
 454             return 1;
 455         }
 456         *outspec = *inspec;
 457         *output_cnt = 1;
 458         return 1;
 459     }
 460
 461     /* Is this a macro that needs to be passed through?
 462      * Macros start with $( and an alpha character, followed
 463      * by a string of alpha numeric characters ending with a )
 464      * If this does not match, then encode it as ODS-5.
 465      */
 466     if ((inspec[0] == '$') && (inspec[1] == '(')) {
 467     int tcnt;
 468
 469         if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
 470             tcnt = 3;
 471             outspec[0] = inspec[0];
 472             outspec[1] = inspec[1];
 473             outspec[2] = inspec[2];
 474
 475             while(isalnum(inspec[tcnt]) ||
 476                   (inspec[2] == '.') || (inspec[2] == '_')) {
 477                 outspec[tcnt] = inspec[tcnt];
 478                 tcnt++;
 479             }
 480             if (inspec[tcnt] == ')') {
 481                 outspec[tcnt] = inspec[tcnt];
 482                 tcnt++;
 483                 *output_cnt = tcnt;
 484                 return tcnt;
 485             }
 486         }
 487     }
 488
 489     switch (*inspec) {
 490     case 0x7f:
 491         outspec[0] = '^';
 492         outspec[1] = '7';
 493         outspec[2] = 'F';
 494         *output_cnt = 3;
 495         return 1;
 496         break;
 497     case '?':
 498         if (decc_efs_charset == 0)
 499           outspec[0] = '%';
 500         else
 501           outspec[0] = '?';
 502         *output_cnt = 1;
 503         return 1;
 504         break;
 505     case '.':
 506     case '~':
 507     case '!':
 508     case '#':
 509     case '&':
 510     case '\'':
 511     case '`':
 512     case '(':
 513     case ')':
 514     case '+':
 515     case '@':
 516     case '{':
 517     case '}':
 518     case ',':
 519     case ';':
 520     case '[':
 521     case ']':
 522     case '%':
 523     case '^':
 524     case '=':
 525         /* Assume that this is to be escaped */
 526         outspec[0] = '^';
 527         outspec[1] = *inspec;
 528         *output_cnt = 2;
 529         return 1;
 530         break;
 531     case ' ': /* space */
 532         /* Assume that this is to be escaped */
 533         outspec[0] = '^';
 534         outspec[1] = '_';
 535         *output_cnt = 2;
 536         return 1;
 537         break;
 538     default:
 539         *outspec = *inspec;
 540         *output_cnt = 1;
 541         return 1;
 542         break;
 543     }
 544 }
 545
 546
 547 /* This handles the expansion of a '^' prefix to the proper character
 548  * in a UNIX file specification.
 549  *
 550  * The output count variable contains the number of characters added
 551  * to the output string.
 552  *
 553  * The return value is the number of characters read from the input
 554  * string
 555  */
 556 static int copy_expand_vms_filename_escape
 557   (char *outspec, const char *inspec, int *output_cnt)
 558 {
 559 int count;
 560 int scnt;
 561
 562     count = 0;
 563     *output_cnt = 0;
 564     if (*inspec == '^') {
 565         inspec++;
 566         switch (*inspec) {
 567         case '.':
 568             /* Non trailing dots should just be passed through */
 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 #ifdef sys$filescan
 631 #undef sys$filescan
 632 int sys$filescan
 633    (const struct dsc$descriptor_s * srcstr,
 634     struct filescan_itmlst_2 * valuelist,
 635     unsigned long * fldflags,
 636     struct dsc$descriptor_s *auxout,
 637     unsigned short * retlen);
 638 #endif
 639
 640 /* vms_split_path - Verify that the input file specification is a
 641  * VMS format file specification, and provide pointers to the components of
 642  * it.  With EFS format filenames, this is virtually the only way to
 643  * parse a VMS path specification into components.
 644  *
 645  * If the sum of the components do not add up to the length of the
 646  * string, then the passed file specification is probably a UNIX style
 647  * path.
 648  */
 649 static int vms_split_path
 650    (const char * path,
 651     char * * volume,
 652     int * vol_len,
 653     char * * root,
 654     int * root_len,
 655     char * * dir,
 656     int * dir_len,
 657     char * * name,
 658     int * name_len,
 659     char * * ext,
 660     int * ext_len,
 661     char * * version,
 662     int * ver_len)
 663 {
 664 struct dsc$descriptor path_desc;
 665 int status;
 666 unsigned long flags;
 667 int ret_stat;
 668 struct filescan_itmlst_2 item_list[9];
 669 const int filespec = 0;
 670 const int nodespec = 1;
 671 const int devspec = 2;
 672 const int rootspec = 3;
 673 const int dirspec = 4;
 674 const int namespec = 5;
 675 const int typespec = 6;
 676 const int verspec = 7;
 677
 678     /* Assume the worst for an easy exit */
 679     ret_stat = -1;
 680     *volume = NULL;
 681     *vol_len = 0;
 682     *root = NULL;
 683     *root_len = 0;
 684     *dir = NULL;
 685     *dir_len;
 686     *name = NULL;
 687     *name_len = 0;
 688     *ext = NULL;
 689     *ext_len = 0;
 690     *version = NULL;
 691     *ver_len = 0;
 692
 693     path_desc.dsc$a_pointer = (char *)path; /* cast ok */
 694     path_desc.dsc$w_length = strlen(path);
 695     path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
 696     path_desc.dsc$b_class = DSC$K_CLASS_S;
 697
 698     /* Get the total length, if it is shorter than the string passed
 699      * then this was probably not a VMS formatted file specification
 700      */
 701     item_list[filespec].itmcode = FSCN$_FILESPEC;
 702     item_list[filespec].length = 0;
 703     item_list[filespec].component = NULL;
 704
 705     /* If the node is present, then it gets considered as part of the
 706      * volume name to hopefully make things simple.
 707      */
 708     item_list[nodespec].itmcode = FSCN$_NODE;
 709     item_list[nodespec].length = 0;
 710     item_list[nodespec].component = NULL;
 711
 712     item_list[devspec].itmcode = FSCN$_DEVICE;
 713     item_list[devspec].length = 0;
 714     item_list[devspec].component = NULL;
 715
 716     /* root is a special case,  adding it to either the directory or
 717      * the device components will probalby complicate things for the
 718      * callers of this routine, so leave it separate.
 719      */
 720     item_list[rootspec].itmcode = FSCN$_ROOT;
 721     item_list[rootspec].length = 0;
 722     item_list[rootspec].component = NULL;
 723
 724     item_list[dirspec].itmcode = FSCN$_DIRECTORY;
 725     item_list[dirspec].length = 0;
 726     item_list[dirspec].component = NULL;
 727
 728     item_list[namespec].itmcode = FSCN$_NAME;
 729     item_list[namespec].length = 0;
 730     item_list[namespec].component = NULL;
 731
 732     item_list[typespec].itmcode = FSCN$_TYPE;
 733     item_list[typespec].length = 0;
 734     item_list[typespec].component = NULL;
 735
 736     item_list[verspec].itmcode = FSCN$_VERSION;
 737     item_list[verspec].length = 0;
 738     item_list[verspec].component = NULL;
 739
 740     item_list[8].itmcode = 0;
 741     item_list[8].length = 0;
 742     item_list[8].component = NULL;
 743
 744     status = sys$filescan
 745        ((const struct dsc$descriptor_s *)&path_desc, item_list,
 746         &flags, NULL, NULL);
 747     _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
 748
 749     /* If we parsed it successfully these two lengths should be the same */
 750     if (path_desc.dsc$w_length != item_list[filespec].length)
 751         return ret_stat;
 752
 753     /* If we got here, then it is a VMS file specification */
 754     ret_stat = 0;
 755
 756     /* set the volume name */
 757     if (item_list[nodespec].length > 0) {
 758         *volume = item_list[nodespec].component;
 759         *vol_len = item_list[nodespec].length + item_list[devspec].length;
 760     }
 761     else {
 762         *volume = item_list[devspec].component;
 763         *vol_len = item_list[devspec].length;
 764     }
 765
 766     *root = item_list[rootspec].component;
 767     *root_len = item_list[rootspec].length;
 768
 769     *dir = item_list[dirspec].component;
 770     *dir_len = item_list[dirspec].length;
 771
 772     /* Now fun with versions and EFS file specifications
 773      * The parser can not tell the difference when a "." is a version
 774      * delimiter or a part of the file specification.
 775      */
 776     if ((decc_efs_charset) &&
 777         (item_list[verspec].length > 0) &&
 778         (item_list[verspec].component[0] == '.')) {
 779         *name = item_list[namespec].component;
 780         *name_len = item_list[namespec].length + item_list[typespec].length;
 781         *ext = item_list[verspec].component;
 782         *ext_len = item_list[verspec].length;
 783         *version = NULL;
 784         *ver_len = 0;
 785     }
 786     else {
 787         *name = item_list[namespec].component;
 788         *name_len = item_list[namespec].length;
 789         *ext = item_list[typespec].component;
 790         *ext_len = item_list[typespec].length;
 791         *version = item_list[verspec].component;
 792         *ver_len = item_list[verspec].length;
 793     }
 794     return ret_stat;
 795 }
 796
 797
 798 /* my_maxidx
 799  * Routine to retrieve the maximum equivalence index for an input
 800  * logical name.  Some calls to this routine have no knowledge if
 801  * the variable is a logical or not.  So on error we return a max
 802  * index of zero.
 803  */
 804 /*{{{int my_maxidx(const char *lnm) */
 805 static int
 806 my_maxidx(const char *lnm)
 807 {
 808     int status;
 809     int midx;
 810     int attr = LNM$M_CASE_BLIND;
 811     struct dsc$descriptor lnmdsc;
 812     struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
 813                                 {0, 0, 0, 0}};
 814
 815     lnmdsc.dsc$w_length = strlen(lnm);
 816     lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
 817     lnmdsc.dsc$b_class = DSC$K_CLASS_S;
 818     lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
 819
 820     status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
 821     if ((status & 1) == 0)
 822        midx = 0;
 823
 824     return (midx);
 825 }
 826 /*}}}*/
 827
 828 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
 829 int
 830 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 831   struct dsc$descriptor_s **tabvec, unsigned long int flags)
 832 {
 833     const char *cp1;
 834     char uplnm[LNM$C_NAMLENGTH+1], *cp2;
 835     unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
 836     unsigned long int retsts, attr = LNM$M_CASE_BLIND;
 837     int midx;
 838     unsigned char acmode;
 839     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
 840                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
 841     struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
 842                                  {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
 843                                  {0, 0, 0, 0}};
 844     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
 845 #if defined(PERL_IMPLICIT_CONTEXT)
 846     pTHX = NULL;
 847     if (PL_curinterp) {
 848       aTHX = PERL_GET_INTERP;
 849     } else {
 850       aTHX = NULL;
 851     }
 852 #endif
 853
 854     if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
 855       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
 856     }
 857     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
 858       *cp2 = _toupper(*cp1);
 859       if (cp1 - lnm > LNM$C_NAMLENGTH) {
 860         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
 861         return 0;
 862       }
 863     }
 864     lnmdsc.dsc$w_length = cp1 - lnm;
 865     lnmdsc.dsc$a_pointer = uplnm;
 866     uplnm[lnmdsc.dsc$w_length] = '\0';
 867     secure = flags & PERL__TRNENV_SECURE;
 868     acmode = secure ? PSL$C_EXEC : PSL$C_USER;
 869     if (!tabvec || !*tabvec) tabvec = env_tables;
 870
 871     for (curtab = 0; tabvec[curtab]; curtab++) {
 872       if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
 873         if (!ivenv && !secure) {
 874           char *eq, *end;
 875           int i;
 876           if (!environ) {
 877             ivenv = 1;
 878             Perl_warn(aTHX_ "Can't read CRTL environ\n");
 879             continue;
 880           }
 881           retsts = SS$_NOLOGNAM;
 882           for (i = 0; environ[i]; i++) {
 883             if ((eq = strchr(environ[i],'=')) &&
 884                 lnmdsc.dsc$w_length == (eq - environ[i]) &&
 885                 !strncmp(environ[i],uplnm,eq - environ[i])) {
 886               eq++;
 887               for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
 888               if (!eqvlen) continue;
 889               retsts = SS$_NORMAL;
 890               break;
 891             }
 892           }
 893           if (retsts != SS$_NOLOGNAM) break;
 894         }
 895       }
 896       else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
 897                !str$case_blind_compare(&tmpdsc,&clisym)) {
 898         if (!ivsym && !secure) {
 899           unsigned short int deflen = LNM$C_NAMLENGTH;
 900           struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
 901           /* dynamic dsc to accomodate possible long value */
 902           _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
 903           retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
 904           if (retsts & 1) {
 905             if (eqvlen > MAX_DCL_SYMBOL) {
 906               set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
 907               eqvlen = MAX_DCL_SYMBOL;
 908               /* Special hack--we might be called before the interpreter's */
 909               /* fully initialized, in which case either thr or PL_curcop */
 910               /* might be bogus. We have to check, since ckWARN needs them */
 911               /* both to be valid if running threaded */
 912                 if (ckWARN(WARN_MISC)) {
 913                   Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
 914                 }
 915             }
 916             strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
 917           }
 918           _ckvmssts(lib$sfree1_dd(&eqvdsc));
 919           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
 920           if (retsts == LIB$_NOSUCHSYM) continue;
 921           break;
 922         }
 923       }
 924       else if (!ivlnm) {
 925         if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
 926           midx = my_maxidx(lnm);
 927           for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
 928             lnmlst[1].bufadr = cp2;
 929             eqvlen = 0;
 930             retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 931             if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
 932             if (retsts == SS$_NOLOGNAM) break;
 933             /* PPFs have a prefix */
 934             if (
 935 #if INTSIZE == 4
 936                  *((int *)uplnm) == *((int *)"SYS$")                    &&
 937 #endif
 938                  eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00        &&
 939                  ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT"))  ||
 940                    (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT"))   ||
 941                    (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR"))   ||
 942                    (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) )  ) {
 943               memmove(eqv,eqv+4,eqvlen-4);
 944               eqvlen -= 4;
 945             }
 946             cp2 += eqvlen;
 947             *cp2 = '\0';
 948           }
 949           if ((retsts == SS$_IVLOGNAM) ||
 950               (retsts == SS$_NOLOGNAM)) { continue; }
 951         }
 952         else {
 953           retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
 954           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
 955           if (retsts == SS$_NOLOGNAM) continue;
 956           eqv[eqvlen] = '\0';
 957         }
 958         eqvlen = strlen(eqv);
 959         break;
 960       }
 961     }
 962     if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
 963     else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
 964              retsts == SS$_IVLOGNAM   || retsts == SS$_IVLOGTAB   ||
 965              retsts == SS$_NOLOGNAM) {
 966       set_errno(EINVAL);  set_vaxc_errno(retsts);
 967     }
 968     else _ckvmssts(retsts);
 969     return 0;
 970 }  /* end of vmstrnenv */
 971 /*}}}*/
 972
 973 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
 974 /* Define as a function so we can access statics. */
 975 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
 976 {
 977   return vmstrnenv(lnm,eqv,idx,fildev,
 978 #ifdef SECURE_INTERNAL_GETENV
 979                    (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
 980 #else
 981                    0
 982 #endif
 983                                                                               );
 984 }
 985 /*}}}*/
 986
 987 /* my_getenv
 988  * Note: Uses Perl temp to store result so char * can be returned to
 989  * caller; this pointer will be invalidated at next Perl statement
 990  * transition.
 991  * We define this as a function rather than a macro in terms of my_getenv_len()
 992  * so that it'll work when PL_curinterp is undefined (and we therefore can't
 993  * allocate SVs).
 994  */
 995 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 996 char *
 997 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 998 {
 999     const char *cp1;
1000     static char *__my_getenv_eqv = NULL;
1001     char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1002     unsigned long int idx = 0;
1003     int trnsuccess, success, secure, saverr, savvmserr;
1004     int midx, flags;
1005     SV *tmpsv;
1006
1007     midx = my_maxidx(lnm) + 1;
1008
1009     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1010       /* Set up a temporary buffer for the return value; Perl will
1011        * clean it up at the next statement transition */
1012       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1013       if (!tmpsv) return NULL;
1014       eqv = SvPVX(tmpsv);
1015     }
1016     else {
1017       /* Assume no interpreter ==> single thread */
1018       if (__my_getenv_eqv != NULL) {
1019         Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1020       }
1021       else {
1022         Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1023       }
1024       eqv = __my_getenv_eqv;
1025     }
1026
1027     for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1028     if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1029       int len;
1030       getcwd(eqv,LNM$C_NAMLENGTH);
1031
1032       len = strlen(eqv);
1033
1034       /* Get rid of "000000/ in rooted filespecs */
1035       if (len > 7) {
1036         char * zeros;
1037         zeros = strstr(eqv, "/000000/");
1038         if (zeros != NULL) {
1039           int mlen;
1040           mlen = len - (zeros - eqv) - 7;
1041           memmove(zeros, &zeros[7], mlen);
1042           len = len - 7;
1043           eqv[len] = '\0';
1044         }
1045       }
1046       return eqv;
1047     }
1048     else {
1049       /* Impose security constraints only if tainting */
1050       if (sys) {
1051         /* Impose security constraints only if tainting */
1052         secure = PL_curinterp ? PL_tainting : will_taint;
1053         saverr = errno;  savvmserr = vaxc$errno;
1054       }
1055       else {
1056         secure = 0;
1057       }
1058
1059       flags =
1060 #ifdef SECURE_INTERNAL_GETENV
1061               secure ? PERL__TRNENV_SECURE : 0
1062 #else
1063               0
1064 #endif
1065       ;
1066
1067       /* For the getenv interface we combine all the equivalence names
1068        * of a search list logical into one value to acquire a maximum
1069        * value length of 255*128 (assuming %ENV is using logicals).
1070        */
1071       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1072
1073       /* If the name contains a semicolon-delimited index, parse it
1074        * off and make sure we only retrieve the equivalence name for
1075        * that index.  */
1076       if ((cp2 = strchr(lnm,';')) != NULL) {
1077         strcpy(uplnm,lnm);
1078         uplnm[cp2-lnm] = '\0';
1079         idx = strtoul(cp2+1,NULL,0);
1080         lnm = uplnm;
1081         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1082       }
1083
1084       success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1085
1086       /* Discard NOLOGNAM on internal calls since we're often looking
1087        * for an optional name, and this "error" often shows up as the
1088        * (bogus) exit status for a die() call later on.  */
1089       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1090       return success ? eqv : Nullch;
1091     }
1092
1093 }  /* end of my_getenv() */
1094 /*}}}*/
1095
1096
1097 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1098 char *
1099 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1100 {
1101     const char *cp1;
1102     char *buf, *cp2;
1103     unsigned long idx = 0;
1104     int midx, flags;
1105     static char *__my_getenv_len_eqv = NULL;
1106     int secure, saverr, savvmserr;
1107     SV *tmpsv;
1108
1109     midx = my_maxidx(lnm) + 1;
1110
1111     if (PL_curinterp) {  /* Perl interpreter running -- may be threaded */
1112       /* Set up a temporary buffer for the return value; Perl will
1113        * clean it up at the next statement transition */
1114       tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1115       if (!tmpsv) return NULL;
1116       buf = SvPVX(tmpsv);
1117     }
1118     else {
1119       /* Assume no interpreter ==> single thread */
1120       if (__my_getenv_len_eqv != NULL) {
1121         Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1122       }
1123       else {
1124         Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1125       }
1126       buf = __my_getenv_len_eqv;
1127     }
1128
1129     for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1130     if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1131     char * zeros;
1132
1133       getcwd(buf,LNM$C_NAMLENGTH);
1134       *len = strlen(buf);
1135
1136       /* Get rid of "000000/ in rooted filespecs */
1137       if (*len > 7) {
1138       zeros = strstr(buf, "/000000/");
1139       if (zeros != NULL) {
1140         int mlen;
1141         mlen = *len - (zeros - buf) - 7;
1142         memmove(zeros, &zeros[7], mlen);
1143         *len = *len - 7;
1144         buf[*len] = '\0';
1145         }
1146       }
1147       return buf;
1148     }
1149     else {
1150       if (sys) {
1151         /* Impose security constraints only if tainting */
1152         secure = PL_curinterp ? PL_tainting : will_taint;
1153         saverr = errno;  savvmserr = vaxc$errno;
1154       }
1155       else {
1156         secure = 0;
1157       }
1158
1159       flags =
1160 #ifdef SECURE_INTERNAL_GETENV
1161               secure ? PERL__TRNENV_SECURE : 0
1162 #else
1163               0
1164 #endif
1165       ;
1166
1167       flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1168
1169       if ((cp2 = strchr(lnm,';')) != NULL) {
1170         strcpy(buf,lnm);
1171         buf[cp2-lnm] = '\0';
1172         idx = strtoul(cp2+1,NULL,0);
1173         lnm = buf;
1174         flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1175       }
1176
1177       *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1178
1179       /* Get rid of "000000/ in rooted filespecs */
1180       if (*len > 7) {
1181       char * zeros;
1182         zeros = strstr(buf, "/000000/");
1183         if (zeros != NULL) {
1184           int mlen;
1185           mlen = *len - (zeros - buf) - 7;
1186           memmove(zeros, &zeros[7], mlen);
1187           *len = *len - 7;
1188           buf[*len] = '\0';
1189         }
1190       }
1191
1192       /* Discard NOLOGNAM on internal calls since we're often looking
1193        * for an optional name, and this "error" often shows up as the
1194        * (bogus) exit status for a die() call later on.  */
1195       if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1196       return *len ? buf : Nullch;
1197     }
1198
1199 }  /* end of my_getenv_len() */
1200 /*}}}*/
1201
1202 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1203
1204 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1205
1206 /*{{{ void prime_env_iter() */
1207 void
1208 prime_env_iter(void)
1209 /* Fill the %ENV associative array with all logical names we can
1210  * find, in preparation for iterating over it.
1211  */
1212 {
1213   static int primed = 0;
1214   HV *seenhv = NULL, *envhv;
1215   SV *sv = NULL;
1216   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1217   unsigned short int chan;
1218 #ifndef CLI$M_TRUSTED
1219 #  define CLI$M_TRUSTED 0x40  /* Missing from VAXC headers */
1220 #endif
1221   unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1222   unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1223   long int i;
1224   bool have_sym = FALSE, have_lnm = FALSE;
1225   struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1226   $DESCRIPTOR(cmddsc,cmd);    $DESCRIPTOR(nldsc,"_NLA0:");
1227   $DESCRIPTOR(clidsc,"DCL");  $DESCRIPTOR(clitabdsc,"DCLTABLES");
1228   $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1229   $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1230 #if defined(PERL_IMPLICIT_CONTEXT)
1231   pTHX;
1232 #endif
1233 #if defined(USE_ITHREADS)
1234   static perl_mutex primenv_mutex;
1235   MUTEX_INIT(&primenv_mutex);
1236 #endif
1237
1238 #if defined(PERL_IMPLICIT_CONTEXT)
1239     /* We jump through these hoops because we can be called at */
1240     /* platform-specific initialization time, which is before anything is */
1241     /* set up--we can't even do a plain dTHX since that relies on the */
1242     /* interpreter structure to be initialized */
1243     if (PL_curinterp) {
1244       aTHX = PERL_GET_INTERP;
1245     } else {
1246       aTHX = NULL;
1247     }
1248 #endif
1249
1250   if (primed || !PL_envgv) return;
1251   MUTEX_LOCK(&primenv_mutex);
1252   if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1253   envhv = GvHVn(PL_envgv);
1254   /* Perform a dummy fetch as an lval to insure that the hash table is
1255    * set up.  Otherwise, the hv_store() will turn into a nullop. */
1256   (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1257
1258   for (i = 0; env_tables[i]; i++) {
1259      if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1260          !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1261      if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1262   }
1263   if (have_sym || have_lnm) {
1264     long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1265     _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1266     _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1267     _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1268   }
1269
1270   for (i--; i >= 0; i--) {
1271     if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1272       char *start;
1273       int j;
1274       for (j = 0; environ[j]; j++) {
1275         if (!(start = strchr(environ[j],'='))) {
1276           if (ckWARN(WARN_INTERNAL))
1277             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1278         }
1279         else {
1280           start++;
1281           sv = newSVpv(start,0);
1282           SvTAINTED_on(sv);
1283           (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1284         }
1285       }
1286       continue;
1287     }
1288     else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1289              !str$case_blind_compare(&tmpdsc,&clisym)) {
1290       strcpy(cmd,"Show Symbol/Global *");
1291       cmddsc.dsc$w_length = 20;
1292       if (env_tables[i]->dsc$w_length == 12 &&
1293           (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1294           !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local  *");
1295       flags = defflags | CLI$M_NOLOGNAM;
1296     }
1297     else {
1298       strcpy(cmd,"Show Logical *");
1299       if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1300         strcat(cmd," /Table=");
1301         strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1302         cmddsc.dsc$w_length = strlen(cmd);
1303       }
1304       else cmddsc.dsc$w_length = 14;  /* N.B. We test this below */
1305       flags = defflags | CLI$M_NOCLISYM;
1306     }
1307
1308     /* Create a new subprocess to execute each command, to exclude the
1309      * remote possibility that someone could subvert a mbx or file used
1310      * to write multiple commands to a single subprocess.
1311      */
1312     do {
1313       retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1314                          0,&riseandshine,0,0,&clidsc,&clitabdsc);
1315       flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1316       defflags &= ~CLI$M_TRUSTED;
1317     } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1318     _ckvmssts(retsts);
1319     if (!buf) Newx(buf,mbxbufsiz + 1,char);
1320     if (seenhv) SvREFCNT_dec(seenhv);
1321     seenhv = newHV();
1322     while (1) {
1323       char *cp1, *cp2, *key;
1324       unsigned long int sts, iosb[2], retlen, keylen;
1325       register U32 hash;
1326
1327       sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1328       if (sts & 1) sts = iosb[0] & 0xffff;
1329       if (sts == SS$_ENDOFFILE) {
1330         int wakect = 0;
1331         while (substs == 0) { sys$hiber(); wakect++;}
1332         if (wakect > 1) sys$wake(0,0);  /* Stole someone else's wake */
1333         _ckvmssts(substs);
1334         break;
1335       }
1336       _ckvmssts(sts);
1337       retlen = iosb[0] >> 16;
1338       if (!retlen) continue;  /* blank line */
1339       buf[retlen] = '\0';
1340       if (iosb[1] != subpid) {
1341         if (iosb[1]) {
1342           Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1343         }
1344         continue;
1345       }
1346       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1347         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1348
1349       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1350       if (*cp1 == '(' || /* Logical name table name */
1351           *cp1 == '='    /* Next eqv of searchlist  */) continue;
1352       if (*cp1 == '"') cp1++;
1353       for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1354       key = cp1;  keylen = cp2 - cp1;
1355       if (keylen && hv_exists(seenhv,key,keylen)) continue;
1356       while (*cp2 && *cp2 != '=') cp2++;
1357       while (*cp2 && *cp2 == '=') cp2++;
1358       while (*cp2 && *cp2 == ' ') cp2++;
1359       if (*cp2 == '"') {  /* String translation; may embed "" */
1360         for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1361         cp2++;  cp1--; /* Skip "" surrounding translation */
1362       }
1363       else {  /* Numeric translation */
1364         for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1365         cp1--;  /* stop on last non-space char */
1366       }
1367       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1368         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1369         continue;
1370       }
1371       PERL_HASH(hash,key,keylen);
1372
1373       if (cp1 == cp2 && *cp2 == '.') {
1374         /* A single dot usually means an unprintable character, such as a null
1375          * to indicate a zero-length value.  Get the actual value to make sure.
1376          */
1377         char lnm[LNM$C_NAMLENGTH+1];
1378         char eqv[MAX_DCL_SYMBOL+1];
1379         int trnlen;
1380         strncpy(lnm, key, keylen);
1381         trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1382         sv = newSVpvn(eqv, strlen(eqv));
1383       }
1384       else {
1385         sv = newSVpvn(cp2,cp1 - cp2 + 1);
1386       }
1387
1388       SvTAINTED_on(sv);
1389       hv_store(envhv,key,keylen,sv,hash);
1390       hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1391     }
1392     if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1393       /* get the PPFs for this process, not the subprocess */
1394       const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1395       char eqv[LNM$C_NAMLENGTH+1];
1396       int trnlen, i;
1397       for (i = 0; ppfs[i]; i++) {
1398         trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1399         sv = newSVpv(eqv,trnlen);
1400         SvTAINTED_on(sv);
1401         hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1402       }
1403     }
1404   }
1405   primed = 1;
1406   if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1407   if (buf) Safefree(buf);
1408   if (seenhv) SvREFCNT_dec(seenhv);
1409   MUTEX_UNLOCK(&primenv_mutex);
1410   return;
1411
1412 }  /* end of prime_env_iter */
1413 /*}}}*/
1414
1415
1416 /*{{{ int  vmssetenv(const char *lnm, const char *eqv)*/
1417 /* Define or delete an element in the same "environment" as
1418  * vmstrnenv().  If an element is to be deleted, it's removed from
1419  * the first place it's found.  If it's to be set, it's set in the
1420  * place designated by the first element of the table vector.
1421  * Like setenv() returns 0 for success, non-zero on error.
1422  */
1423 int
1424 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1425 {
1426     const char *cp1;
1427     char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1428     unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1429     int nseg = 0, j;
1430     unsigned long int retsts, usermode = PSL$C_USER;
1431     struct itmlst_3 *ile, *ilist;
1432     struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1433                             eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1434                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1435     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
1436     $DESCRIPTOR(local,"_LOCAL");
1437
1438     if (!lnm) {
1439         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1440         return SS$_IVLOGNAM;
1441     }
1442
1443     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1444       *cp2 = _toupper(*cp1);
1445       if (cp1 - lnm > LNM$C_NAMLENGTH) {
1446         set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1447         return SS$_IVLOGNAM;
1448       }
1449     }
1450     lnmdsc.dsc$w_length = cp1 - lnm;
1451     if (!tabvec || !*tabvec) tabvec = env_tables;
1452
1453     if (!eqv) {  /* we're deleting n element */
1454       for (curtab = 0; tabvec[curtab]; curtab++) {
1455         if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1456         int i;
1457           for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1458             if ((cp1 = strchr(environ[i],'=')) &&
1459                 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1460                 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1461 #ifdef HAS_SETENV
1462               return setenv(lnm,"",1) ? vaxc$errno : 0;
1463             }
1464           }
1465           ivenv = 1; retsts = SS$_NOLOGNAM;
1466 #else
1467               if (ckWARN(WARN_INTERNAL))
1468                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1469               ivenv = 1; retsts = SS$_NOSUCHPGM;
1470               break;
1471             }
1472           }
1473 #endif
1474         }
1475         else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1476                  !str$case_blind_compare(&tmpdsc,&clisym)) {
1477           unsigned int symtype;
1478           if (tabvec[curtab]->dsc$w_length == 12 &&
1479               (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1480               !str$case_blind_compare(&tmpdsc,&local))
1481             symtype = LIB$K_CLI_LOCAL_SYM;
1482           else symtype = LIB$K_CLI_GLOBAL_SYM;
1483           retsts = lib$delete_symbol(&lnmdsc,&symtype);
1484           if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1485           if (retsts == LIB$_NOSUCHSYM) continue;
1486           break;
1487         }
1488         else if (!ivlnm) {
1489           retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1490           if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1491           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1492           retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1493           if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1494         }
1495       }
1496     }
1497     else {  /* we're defining a value */
1498       if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1499 #ifdef HAS_SETENV
1500         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1501 #else
1502         if (ckWARN(WARN_INTERNAL))
1503           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1504         retsts = SS$_NOSUCHPGM;
1505 #endif
1506       }
1507       else {
1508         eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1509         eqvdsc.dsc$w_length  = strlen(eqv);
1510         if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1511             !str$case_blind_compare(&tmpdsc,&clisym)) {
1512           unsigned int symtype;
1513           if (tabvec[0]->dsc$w_length == 12 &&
1514               (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1515                !str$case_blind_compare(&tmpdsc,&local))
1516             symtype = LIB$K_CLI_LOCAL_SYM;
1517           else symtype = LIB$K_CLI_GLOBAL_SYM;
1518           retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1519         }
1520         else {
1521           if (!*eqv) eqvdsc.dsc$w_length = 1;
1522           if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1523
1524             nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1525             if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1526               Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1527                           lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1528               eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1529               nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1530             }
1531
1532             Newx(ilist,nseg+1,struct itmlst_3);
1533             ile = ilist;
1534             if (!ile) {
1535               set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1536               return SS$_INSFMEM;
1537             }
1538             memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1539
1540             for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1541               ile->itmcode = LNM$_STRING;
1542               ile->bufadr = c;
1543               if ((j+1) == nseg) {
1544                 ile->buflen = strlen(c);
1545                 /* in case we are truncating one that's too long */
1546                 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1547               }
1548               else {
1549                 ile->buflen = LNM$C_NAMLENGTH;
1550               }
1551             }
1552
1553             retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1554             Safefree (ilist);
1555           }
1556           else {
1557             retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1558           }
1559         }
1560       }
1561     }
1562     if (!(retsts & 1)) {
1563       switch (retsts) {
1564         case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1565         case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1566           set_errno(EVMSERR); break;
1567         case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1568         case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1569           set_errno(EINVAL); break;
1570         case SS$_NOPRIV:
1571           set_errno(EACCES); break;
1572         default:
1573           _ckvmssts(retsts);
1574           set_errno(EVMSERR);
1575        }
1576        set_vaxc_errno(retsts);
1577        return (int) retsts || 44; /* retsts should never be 0, but just in case */
1578     }
1579     else {
1580       /* We reset error values on success because Perl does an hv_fetch()
1581        * before each hv_store(), and if the thing we're setting didn't
1582        * previously exist, we've got a leftover error message.  (Of course,
1583        * this fails in the face of
1584        *    $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1585        * in that the error reported in $! isn't spurious,
1586        * but it's right more often than not.)
1587        */
1588       set_errno(0); set_vaxc_errno(retsts);
1589       return 0;
1590     }
1591
1592 }  /* end of vmssetenv() */
1593 /*}}}*/
1594
1595 /*{{{ void  my_setenv(const char *lnm, const char *eqv)*/
1596 /* This has to be a function since there's a prototype for it in proto.h */
1597 void
1598 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1599 {
1600     if (lnm && *lnm) {
1601       int len = strlen(lnm);
1602       if  (len == 7) {
1603         char uplnm[8];
1604         int i;
1605         for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1606         if (!strcmp(uplnm,"DEFAULT")) {
1607           if (eqv && *eqv) my_chdir(eqv);
1608           return;
1609         }
1610     }
1611 #ifndef RTL_USES_UTC
1612     if (len == 6 || len == 2) {
1613       char uplnm[7];
1614       int i;
1615       for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1616       uplnm[len] = '\0';
1617       if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1618       if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1619     }
1620 #endif
1621   }
1622   (void) vmssetenv(lnm,eqv,NULL);
1623 }
1624 /*}}}*/
1625
1626 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1627 /*  vmssetuserlnm
1628  *  sets a user-mode logical in the process logical name table
1629  *  used for redirection of sys$error
1630  */
1631 void
1632 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1633 {
1634     $DESCRIPTOR(d_tab, "LNM$PROCESS");
1635     struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1636     unsigned long int iss, attr = LNM$M_CONFINE;
1637     unsigned char acmode = PSL$C_USER;
1638     struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1639                                  {0, 0, 0, 0}};
1640     d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1641     d_name.dsc$w_length = strlen(name);
1642
1643     lnmlst[0].buflen = strlen(eqv);
1644     lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1645
1646     iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1647     if (!(iss&1)) lib$signal(iss);
1648 }
1649 /*}}}*/
1650
1651
1652 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1653 /* my_crypt - VMS password hashing
1654  * my_crypt() provides an interface compatible with the Unix crypt()
1655  * C library function, and uses sys$hash_password() to perform VMS
1656  * password hashing.  The quadword hashed password value is returned
1657  * as a NUL-terminated 8 character string.  my_crypt() does not change
1658  * the case of its string arguments; in order to match the behavior
1659  * of LOGINOUT et al., alphabetic characters in both arguments must
1660  *  be upcased by the caller.
1661  *
1662  * - fix me to call ACM services when available
1663  */
1664 char *
1665 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1666 {
1667 #   ifndef UAI$C_PREFERRED_ALGORITHM
1668 #     define UAI$C_PREFERRED_ALGORITHM 127
1669 #   endif
1670     unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1671     unsigned short int salt = 0;
1672     unsigned long int sts;
1673     struct const_dsc {
1674         unsigned short int dsc$w_length;
1675         unsigned char      dsc$b_type;
1676         unsigned char      dsc$b_class;
1677         const char *       dsc$a_pointer;
1678     }  usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1679        txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1680     struct itmlst_3 uailst[3] = {
1681         { sizeof alg,  UAI$_ENCRYPT, &alg, 0},
1682         { sizeof salt, UAI$_SALT,    &salt, 0},
1683         { 0,           0,            NULL,  NULL}};
1684     static char hash[9];
1685
1686     usrdsc.dsc$w_length = strlen(usrname);
1687     usrdsc.dsc$a_pointer = usrname;
1688     if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1689       switch (sts) {
1690         case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1691           set_errno(EACCES);
1692           break;
1693         case RMS$_RNF:
1694           set_errno(ESRCH);  /* There isn't a Unix no-such-user error */
1695           break;
1696         default:
1697           set_errno(EVMSERR);
1698       }
1699       set_vaxc_errno(sts);
1700       if (sts != RMS$_RNF) return NULL;
1701     }
1702
1703     txtdsc.dsc$w_length = strlen(textpasswd);
1704     txtdsc.dsc$a_pointer = textpasswd;
1705     if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1706       set_errno(EVMSERR);  set_vaxc_errno(sts);  return NULL;
1707     }
1708
1709     return (char *) hash;
1710
1711 }  /* end of my_crypt() */
1712 /*}}}*/
1713
1714
1715 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1716 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1717 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1718
1719 /* fixup barenames that are directories for internal use.
1720  * There have been problems with the consistent handling of UNIX
1721  * style directory names when routines are presented with a name that
1722  * has no directory delimitors at all.  So this routine will eventually
1723  * fix the issue.
1724  */
1725 static char * fixup_bare_dirnames(const char * name)
1726 {
1727   if (decc_disable_to_vms_logname_translation) {
1728 /* fix me */
1729   }
1730   return NULL;
1731 }
1732
1733 /* mp_do_kill_file
1734  * A little hack to get around a bug in some implemenation of remove()
1735  * that do not know how to delete a directory
1736  *
1737  * Delete any file to which user has control access, regardless of whether
1738  * delete access is explicitly allowed.
1739  * Limitations: User must have write access to parent directory.
1740  *              Does not block signals or ASTs; if interrupted in midstream
1741  *              may leave file with an altered ACL.
1742  * HANDLE WITH CARE!
1743  */
1744 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1745 static int
1746 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1747 {
1748     char *vmsname, *rspec;
1749     char *remove_name;
1750     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1751     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1752     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1753     struct myacedef {
1754       unsigned char myace$b_length;
1755       unsigned char myace$b_type;
1756       unsigned short int myace$w_flags;
1757       unsigned long int myace$l_access;
1758       unsigned long int myace$l_ident;
1759     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1760                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1761       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1762      struct itmlst_3
1763        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1764                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1765        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1766        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1767        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1768        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1769
1770     /* Expand the input spec using RMS, since the CRTL remove() and
1771      * system services won't do this by themselves, so we may miss
1772      * a file "hiding" behind a logical name or search list. */
1773     vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1774     if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1775
1776     if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1777       PerlMem_free(vmsname);
1778       return -1;
1779     }
1780
1781     if (decc_posix_compliant_pathnames) {
1782       /* In POSIX mode, we prefer to remove the UNIX name */
1783       rspec = vmsname;
1784       remove_name = (char *)name;
1785     }
1786     else {
1787       rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1788       if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1789       if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1790         PerlMem_free(rspec);
1791         PerlMem_free(vmsname);
1792         return -1;
1793       }
1794       PerlMem_free(vmsname);
1795       remove_name = rspec;
1796     }
1797
1798 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1799     if (dirflag != 0) {
1800         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1801           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1802           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1803
1804           do_pathify_dirspec(name, remove_name, 0, NULL);
1805           if (!rmdir(remove_name)) {
1806
1807             PerlMem_free(remove_name);
1808             PerlMem_free(rspec);
1809             return 0;   /* Can we just get rid of it? */
1810           }
1811         }
1812         else {
1813           if (!rmdir(remove_name)) {
1814             PerlMem_free(rspec);
1815             return 0;   /* Can we just get rid of it? */
1816           }
1817         }
1818     }
1819     else
1820 #endif
1821       if (!remove(remove_name)) {
1822         PerlMem_free(rspec);
1823         return 0;   /* Can we just get rid of it? */
1824       }
1825
1826     /* If not, can changing protections help? */
1827     if (vaxc$errno != RMS$_PRV) {
1828       PerlMem_free(rspec);
1829       return -1;
1830     }
1831
1832     /* No, so we get our own UIC to use as a rights identifier,
1833      * and the insert an ACE at the head of the ACL which allows us
1834      * to delete the file.
1835      */
1836     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1837     fildsc.dsc$w_length = strlen(rspec);
1838     fildsc.dsc$a_pointer = rspec;
1839     cxt = 0;
1840     newace.myace$l_ident = oldace.myace$l_ident;
1841     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1842       switch (aclsts) {
1843         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1844           set_errno(ENOENT); break;
1845         case RMS$_DIR:
1846           set_errno(ENOTDIR); break;
1847         case RMS$_DEV:
1848           set_errno(ENODEV); break;
1849         case RMS$_SYN: case SS$_INVFILFOROP:
1850           set_errno(EINVAL); break;
1851         case RMS$_PRV:
1852           set_errno(EACCES); break;
1853         default:
1854           _ckvmssts(aclsts);
1855       }
1856       set_vaxc_errno(aclsts);
1857       PerlMem_free(rspec);
1858       return -1;
1859     }
1860     /* Grab any existing ACEs with this identifier in case we fail */
1861     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1862     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1863                     || fndsts == SS$_NOMOREACE ) {
1864       /* Add the new ACE . . . */
1865       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1866         goto yourroom;
1867
1868 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1869       if (dirflag != 0)
1870         if (decc_dir_barename && decc_posix_compliant_pathnames) {
1871           remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1872           if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1873
1874           do_pathify_dirspec(name, remove_name, 0, NULL);
1875           rmsts = rmdir(remove_name);
1876           PerlMem_free(remove_name);
1877         }
1878         else {
1879         rmsts = rmdir(remove_name);
1880         }
1881       else
1882 #endif
1883         rmsts = remove(remove_name);
1884       if (rmsts) {
1885         /* We blew it - dir with files in it, no write priv for
1886          * parent directory, etc.  Put things back the way they were. */
1887         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1888           goto yourroom;
1889         if (fndsts & 1) {
1890           addlst[0].bufadr = &oldace;
1891           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1892             goto yourroom;
1893         }
1894       }
1895     }
1896
1897     yourroom:
1898     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1899     /* We just deleted it, so of course it's not there.  Some versions of
1900      * VMS seem to return success on the unlock operation anyhow (after all
1901      * the unlock is successful), but others don't.
1902      */
1903     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1904     if (aclsts & 1) aclsts = fndsts;
1905     if (!(aclsts & 1)) {
1906       set_errno(EVMSERR);
1907       set_vaxc_errno(aclsts);
1908       PerlMem_free(rspec);
1909       return -1;
1910     }
1911
1912     PerlMem_free(rspec);
1913     return rmsts;
1914
1915 }  /* end of kill_file() */
1916 /*}}}*/
1917
1918
1919 /*{{{int do_rmdir(char *name)*/
1920 int
1921 Perl_do_rmdir(pTHX_ const char *name)
1922 {
1923     char dirfile[NAM$C_MAXRSS+1];
1924     int retval;
1925     Stat_t st;
1926
1927     if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1928     if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1929     else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1930     return retval;
1931
1932 }  /* end of do_rmdir */
1933 /*}}}*/
1934
1935 /* kill_file
1936  * Delete any file to which user has control access, regardless of whether
1937  * delete access is explicitly allowed.
1938  * Limitations: User must have write access to parent directory.
1939  *              Does not block signals or ASTs; if interrupted in midstream
1940  *              may leave file with an altered ACL.
1941  * HANDLE WITH CARE!
1942  */
1943 /*{{{int kill_file(char *name)*/
1944 int
1945 Perl_kill_file(pTHX_ const char *name)
1946 {
1947     char rspec[NAM$C_MAXRSS+1];
1948     char *tspec;
1949     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1950     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1951     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1952     struct myacedef {
1953       unsigned char myace$b_length;
1954       unsigned char myace$b_type;
1955       unsigned short int myace$w_flags;
1956       unsigned long int myace$l_access;
1957       unsigned long int myace$l_ident;
1958     } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1959                  ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1960       oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1961      struct itmlst_3
1962        findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1963                      {sizeof oldace, ACL$C_READACE,   &oldace, 0},{0,0,0,0}},
1964        addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1965        dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1966        lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1967        ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1968
1969     /* Expand the input spec using RMS, since the CRTL remove() and
1970      * system services won't do this by themselves, so we may miss
1971      * a file "hiding" behind a logical name or search list. */
1972     tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1973     if (tspec == NULL) return -1;
1974     if (!remove(rspec)) return 0;   /* Can we just get rid of it? */
1975     /* If not, can changing protections help? */
1976     if (vaxc$errno != RMS$_PRV) return -1;
1977
1978     /* No, so we get our own UIC to use as a rights identifier,
1979      * and the insert an ACE at the head of the ACL which allows us
1980      * to delete the file.
1981      */
1982     _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1983     fildsc.dsc$w_length = strlen(rspec);
1984     fildsc.dsc$a_pointer = rspec;
1985     cxt = 0;
1986     newace.myace$l_ident = oldace.myace$l_ident;
1987     if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1988       switch (aclsts) {
1989         case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1990           set_errno(ENOENT); break;
1991         case RMS$_DIR:
1992           set_errno(ENOTDIR); break;
1993         case RMS$_DEV:
1994           set_errno(ENODEV); break;
1995         case RMS$_SYN: case SS$_INVFILFOROP:
1996           set_errno(EINVAL); break;
1997         case RMS$_PRV:
1998           set_errno(EACCES); break;
1999         default:
2000           _ckvmssts(aclsts);
2001       }
2002       set_vaxc_errno(aclsts);
2003       return -1;
2004     }
2005     /* Grab any existing ACEs with this identifier in case we fail */
2006     aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2007     if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2008                     || fndsts == SS$_NOMOREACE ) {
2009       /* Add the new ACE . . . */
2010       if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2011         goto yourroom;
2012       if ((rmsts = remove(name))) {
2013         /* We blew it - dir with files in it, no write priv for
2014          * parent directory, etc.  Put things back the way they were. */
2015         if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2016           goto yourroom;
2017         if (fndsts & 1) {
2018           addlst[0].bufadr = &oldace;
2019           if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2020             goto yourroom;
2021         }
2022       }
2023     }
2024
2025     yourroom:
2026     fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2027     /* We just deleted it, so of course it's not there.  Some versions of
2028      * VMS seem to return success on the unlock operation anyhow (after all
2029      * the unlock is successful), but others don't.
2030      */
2031     if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2032     if (aclsts & 1) aclsts = fndsts;
2033     if (!(aclsts & 1)) {
2034       set_errno(EVMSERR);
2035       set_vaxc_errno(aclsts);
2036       return -1;
2037     }
2038
2039     return rmsts;
2040
2041 }  /* end of kill_file() */
2042 /*}}}*/
2043
2044
2045 /*{{{int my_mkdir(char *,Mode_t)*/
2046 int
2047 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2048 {
2049   STRLEN dirlen = strlen(dir);
2050
2051   /* zero length string sometimes gives ACCVIO */
2052   if (dirlen == 0) return -1;
2053
2054   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2055    * null file name/type.  However, it's commonplace under Unix,
2056    * so we'll allow it for a gain in portability.
2057    */
2058   if (dir[dirlen-1] == '/') {
2059     char *newdir = savepvn(dir,dirlen-1);
2060     int ret = mkdir(newdir,mode);
2061     Safefree(newdir);
2062     return ret;
2063   }
2064   else return mkdir(dir,mode);
2065 }  /* end of my_mkdir */
2066 /*}}}*/
2067
2068 /*{{{int my_chdir(char *)*/
2069 int
2070 Perl_my_chdir(pTHX_ const char *dir)
2071 {
2072   STRLEN dirlen = strlen(dir);
2073
2074   /* zero length string sometimes gives ACCVIO */
2075   if (dirlen == 0) return -1;
2076   const char *dir1;
2077
2078   /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2079    * This does not work if DECC$EFS_CHARSET is active.  Hack it here
2080    * so that existing scripts do not need to be changed.
2081    */
2082   dir1 = dir;
2083   while ((dirlen > 0) && (*dir1 == ' ')) {
2084     dir1++;
2085     dirlen--;
2086   }
2087
2088   /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2089    * that implies
2090    * null file name/type.  However, it's commonplace under Unix,
2091    * so we'll allow it for a gain in portability.
2092    *
2093    * - Preview- '/' will be valid soon on VMS
2094    */
2095   if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2096     char *newdir = savepvn(dir1,dirlen-1);
2097     int ret = chdir(newdir);
2098     Safefree(newdir);
2099     return ret;
2100   }
2101   else return chdir(dir1);
2102 }  /* end of my_chdir */
2103 /*}}}*/
2104
2105
2106 /*{{{FILE *my_tmpfile()*/
2107 FILE *
2108 my_tmpfile(void)
2109 {
2110   FILE *fp;
2111   char *cp;
2112
2113   if ((fp = tmpfile())) return fp;
2114
2115   cp = PerlMem_malloc(L_tmpnam+24);
2116   if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2117
2118   if (decc_filename_unix_only == 0)
2119     strcpy(cp,"Sys$Scratch:");
2120   else
2121     strcpy(cp,"/tmp/");
2122   tmpnam(cp+strlen(cp));
2123   strcat(cp,".Perltmp");
2124   fp = fopen(cp,"w+","fop=dlt");
2125   PerlMem_free(cp);
2126   return fp;
2127 }
2128 /*}}}*/
2129
2130
2131 #ifndef HOMEGROWN_POSIX_SIGNALS
2132 /*
2133  * The C RTL's sigaction fails to check for invalid signal numbers so we
2134  * help it out a bit.  The docs are correct, but the actual routine doesn't
2135  * do what the docs say it will.
2136  */
2137 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2138 int
2139 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2140                    struct sigaction* oact)
2141 {
2142   if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2143         SETERRNO(EINVAL, SS$_INVARG);
2144         return -1;
2145   }
2146   return sigaction(sig, act, oact);
2147 }
2148 /*}}}*/
2149 #endif
2150
2151 #ifdef KILL_BY_SIGPRC
2152 #include <errnodef.h>
2153
2154 /* We implement our own kill() using the undocumented system service
2155    sys$sigprc for one of two reasons:
2156
2157    1.) If the kill() in an older CRTL uses sys$forcex, causing the
2158    target process to do a sys$exit, which usually can't be handled
2159    gracefully...certainly not by Perl and the %SIG{} mechanism.
2160
2161    2.) If the kill() in the CRTL can't be called from a signal
2162    handler without disappearing into the ether, i.e., the signal
2163    it purportedly sends is never trapped. Still true as of VMS 7.3.
2164
2165    sys$sigprc has the same parameters as sys$forcex, but throws an exception
2166    in the target process rather than calling sys$exit.
2167
2168    Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2169    on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2170    provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
2171    with condition codes C$_SIG0+nsig*8, catching the exception on the
2172    target process and resignaling with appropriate arguments.
2173
2174    But we don't have that VMS 7.0+ exception handler, so if you
2175    Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
2176
2177    Also note that SIGTERM is listed in the docs as being "unimplemented",
2178    yet always seems to be signaled with a VMS condition code of 4 (and
2179    correctly handled for that code).  So we hardwire it in.
2180
2181    Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2182    number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
2183    than signalling with an unrecognized (and unhandled by CRTL) code.
2184 */
2185
2186 #define _MY_SIG_MAX 28
2187
2188 static unsigned int
2189 Perl_sig_to_vmscondition_int(int sig)
2190 {
2191     static unsigned int sig_code[_MY_SIG_MAX+1] =
2192     {
2193         0,                  /*  0 ZERO     */
2194         SS$_HANGUP,         /*  1 SIGHUP   */
2195         SS$_CONTROLC,       /*  2 SIGINT   */
2196         SS$_CONTROLY,       /*  3 SIGQUIT  */
2197         SS$_RADRMOD,        /*  4 SIGILL   */
2198         SS$_BREAK,          /*  5 SIGTRAP  */
2199         SS$_OPCCUS,         /*  6 SIGABRT  */
2200         SS$_COMPAT,         /*  7 SIGEMT   */
2201 #ifdef __VAX
2202         SS$_FLTOVF,         /*  8 SIGFPE VAX */
2203 #else
2204         SS$_HPARITH,        /*  8 SIGFPE AXP */
2205 #endif
2206         SS$_ABORT,          /*  9 SIGKILL  */
2207         SS$_ACCVIO,         /* 10 SIGBUS   */
2208         SS$_ACCVIO,         /* 11 SIGSEGV  */
2209         SS$_BADPARAM,       /* 12 SIGSYS   */
2210         SS$_NOMBX,          /* 13 SIGPIPE  */
2211         SS$_ASTFLT,         /* 14 SIGALRM  */
2212         4,                  /* 15 SIGTERM  */
2213         0,                  /* 16 SIGUSR1  */
2214         0,                  /* 17 SIGUSR2  */
2215         0,                  /* 18 */
2216         0,                  /* 19 */
2217         0,                  /* 20 SIGCHLD  */
2218         0,                  /* 21 SIGCONT  */
2219         0,                  /* 22 SIGSTOP  */
2220         0,                  /* 23 SIGTSTP  */
2221         0,                  /* 24 SIGTTIN  */
2222         0,                  /* 25 SIGTTOU  */
2223         0,                  /* 26 */
2224         0,                  /* 27 */
2225         0                   /* 28 SIGWINCH  */
2226     };
2227
2228 #if __VMS_VER >= 60200000
2229     static int initted = 0;
2230     if (!initted) {
2231         initted = 1;
2232         sig_code[16] = C$_SIGUSR1;
2233         sig_code[17] = C$_SIGUSR2;
2234 #if __CRTL_VER >= 70000000
2235         sig_code[20] = C$_SIGCHLD;
2236 #endif
2237 #if __CRTL_VER >= 70300000
2238         sig_code[28] = C$_SIGWINCH;
2239 #endif
2240     }
2241 #endif
2242
2243     if (sig < _SIG_MIN) return 0;
2244     if (sig > _MY_SIG_MAX) return 0;
2245     return sig_code[sig];
2246 }
2247
2248 unsigned int
2249 Perl_sig_to_vmscondition(int sig)
2250 {
2251 #ifdef SS$_DEBUG
2252     if (vms_debug_on_exception != 0)
2253         lib$signal(SS$_DEBUG);
2254 #endif
2255     return Perl_sig_to_vmscondition_int(sig);
2256 }
2257
2258
2259 int
2260 Perl_my_kill(int pid, int sig)
2261 {
2262     dTHX;
2263     int iss;
2264     unsigned int code;
2265     int sys$sigprc(unsigned int *pidadr,
2266                      struct dsc$descriptor_s *prcname,
2267                      unsigned int code);
2268
2269      /* sig 0 means validate the PID */
2270     /*------------------------------*/
2271     if (sig == 0) {
2272         const unsigned long int jpicode = JPI$_PID;
2273         pid_t ret_pid;
2274         int status;
2275         status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2276         if ($VMS_STATUS_SUCCESS(status))
2277            return 0;
2278         switch (status) {
2279         case SS$_NOSUCHNODE:
2280         case SS$_UNREACHABLE:
2281         case SS$_NONEXPR:
2282            errno = ESRCH;
2283            break;
2284         case SS$_NOPRIV:
2285            errno = EPERM;
2286            break;
2287         default:
2288            errno = EVMSERR;
2289         }
2290         vaxc$errno=status;
2291         return -1;
2292     }
2293
2294     code = Perl_sig_to_vmscondition_int(sig);
2295
2296     if (!code) {
2297         SETERRNO(EINVAL, SS$_BADPARAM);
2298         return -1;
2299     }
2300
2301     /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2302      * signals are to be sent to multiple processes.
2303      *  pid = 0 - all processes in group except ones that the system exempts
2304      *  pid = -1 - all processes except ones that the system exempts
2305      *  pid = -n - all processes in group (abs(n)) except ...
2306      * For now, just report as not supported.
2307      */
2308
2309     if (pid <= 0) {
2310         SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2311         return -1;
2312     }
2313
2314     iss = sys$sigprc((unsigned int *)&pid,0,code);
2315     if (iss&1) return 0;
2316
2317     switch (iss) {
2318       case SS$_NOPRIV:
2319         set_errno(EPERM);  break;
2320       case SS$_NONEXPR:
2321       case SS$_NOSUCHNODE:
2322       case SS$_UNREACHABLE:
2323         set_errno(ESRCH);  break;
2324       case SS$_INSFMEM:
2325         set_errno(ENOMEM); break;
2326       default:
2327         _ckvmssts(iss);
2328         set_errno(EVMSERR);
2329     }
2330     set_vaxc_errno(iss);
2331
2332     return -1;
2333 }
2334 #endif
2335
2336 /* Routine to convert a VMS status code to a UNIX status code.
2337 ** More tricky than it appears because of conflicting conventions with
2338 ** existing code.
2339 **
2340 ** VMS status codes are a bit mask, with the least significant bit set for
2341 ** success.
2342 **
2343 ** Special UNIX status of EVMSERR indicates that no translation is currently
2344 ** available, and programs should check the VMS status code.
2345 **
2346 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2347 ** decoding.
2348 */
2349
2350 #ifndef C_FACILITY_NO
2351 #define C_FACILITY_NO 0x350000
2352 #endif
2353 #ifndef DCL_IVVERB
2354 #define DCL_IVVERB 0x38090
2355 #endif
2356
2357 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2358 {
2359 int facility;
2360 int fac_sp;
2361 int msg_no;
2362 int msg_status;
2363 int unix_status;
2364
2365   /* Assume the best or the worst */
2366   if (vms_status & STS$M_SUCCESS)
2367     unix_status = 0;
2368   else
2369     unix_status = EVMSERR;
2370
2371   msg_status = vms_status & ~STS$M_CONTROL;
2372
2373   facility = vms_status & STS$M_FAC_NO;
2374   fac_sp = vms_status & STS$M_FAC_SP;
2375   msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2376
2377   if (((facility == 0) || (fac_sp == 0))  && (child_flag == 0)) {
2378     switch(msg_no) {
2379     case SS$_NORMAL:
2380         unix_status = 0;
2381         break;
2382     case SS$_ACCVIO:
2383         unix_status = EFAULT;
2384         break;
2385     case SS$_DEVOFFLINE:
2386         unix_status = EBUSY;
2387         break;
2388     case SS$_CLEARED:
2389         unix_status = ENOTCONN;
2390         break;
2391     case SS$_IVCHAN:
2392     case SS$_IVLOGNAM:
2393     case SS$_BADPARAM:
2394     case SS$_IVLOGTAB:
2395     case SS$_NOLOGNAM:
2396     case SS$_NOLOGTAB:
2397     case SS$_INVFILFOROP:
2398     case SS$_INVARG:
2399     case SS$_NOSUCHID:
2400     case SS$_IVIDENT:
2401         unix_status = EINVAL;
2402         break;
2403     case SS$_UNSUPPORTED:
2404         unix_status = ENOTSUP;
2405         break;
2406     case SS$_FILACCERR:
2407     case SS$_NOGRPPRV:
2408     case SS$_NOSYSPRV:
2409         unix_status = EACCES;
2410         break;
2411     case SS$_DEVICEFULL:
2412         unix_status = ENOSPC;
2413         break;
2414     case SS$_NOSUCHDEV:
2415         unix_status = ENODEV;
2416         break;
2417     case SS$_NOSUCHFILE:
2418     case SS$_NOSUCHOBJECT:
2419         unix_status = ENOENT;
2420         break;
2421     case SS$_ABORT:                                 /* Fatal case */
2422     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2423     case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2424         unix_status = EINTR;
2425         break;
2426     case SS$_BUFFEROVF:
2427         unix_status = E2BIG;
2428         break;
2429     case SS$_INSFMEM:
2430         unix_status = ENOMEM;
2431         break;
2432     case SS$_NOPRIV:
2433         unix_status = EPERM;
2434         break;
2435     case SS$_NOSUCHNODE:
2436     case SS$_UNREACHABLE:
2437         unix_status = ESRCH;
2438         break;
2439     case SS$_NONEXPR:
2440         unix_status = ECHILD;
2441         break;
2442     default:
2443         if ((facility == 0) && (msg_no < 8)) {
2444           /* These are not real VMS status codes so assume that they are
2445           ** already UNIX status codes
2446           */
2447           unix_status = msg_no;
2448           break;
2449         }
2450     }
2451   }
2452   else {
2453     /* Translate a POSIX exit code to a UNIX exit code */
2454     if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000))  {
2455         unix_status = (msg_no & 0x07F8) >> 3;
2456     }
2457     else {
2458
2459          /* Documented traditional behavior for handling VMS child exits */
2460         /*--------------------------------------------------------------*/
2461         if (child_flag != 0) {
2462
2463              /* Success / Informational return 0 */
2464             /*----------------------------------*/
2465             if (msg_no & STS$K_SUCCESS)
2466                 return 0;
2467
2468              /* Warning returns 1 */
2469             /*-------------------*/
2470             if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2471                 return 1;
2472
2473              /* Everything else pass through the severity bits */
2474             /*------------------------------------------------*/
2475             return (msg_no & STS$M_SEVERITY);
2476         }
2477
2478          /* Normal VMS status to ERRNO mapping attempt */
2479         /*--------------------------------------------*/
2480         switch(msg_status) {
2481         /* case RMS$_EOF: */ /* End of File */
2482         case RMS$_FNF:  /* File Not Found */
2483         case RMS$_DNF:  /* Dir Not Found */
2484                 unix_status = ENOENT;
2485                 break;
2486         case RMS$_RNF:  /* Record Not Found */
2487                 unix_status = ESRCH;
2488                 break;
2489         case RMS$_DIR:
2490                 unix_status = ENOTDIR;
2491                 break;
2492         case RMS$_DEV:
2493                 unix_status = ENODEV;
2494                 break;
2495         case RMS$_IFI:
2496         case RMS$_FAC:
2497         case RMS$_ISI:
2498                 unix_status = EBADF;
2499                 break;
2500         case RMS$_FEX:
2501                 unix_status = EEXIST;
2502                 break;
2503         case RMS$_SYN:
2504         case RMS$_FNM:
2505         case LIB$_INVSTRDES:
2506         case LIB$_INVARG:
2507         case LIB$_NOSUCHSYM:
2508         case LIB$_INVSYMNAM:
2509         case DCL_IVVERB:
2510                 unix_status = EINVAL;
2511                 break;
2512         case CLI$_BUFOVF:
2513         case RMS$_RTB:
2514         case CLI$_TKNOVF:
2515         case CLI$_RSLOVF:
2516                 unix_status = E2BIG;
2517                 break;
2518         case RMS$_PRV:  /* No privilege */
2519         case RMS$_ACC:  /* ACP file access failed */
2520         case RMS$_WLK:  /* Device write locked */
2521                 unix_status = EACCES;
2522                 break;
2523         /* case RMS$_NMF: */  /* No more files */
2524         }
2525     }
2526   }
2527
2528   return unix_status;
2529 }
2530
2531 /* Try to guess at what VMS error status should go with a UNIX errno
2532  * value.  This is hard to do as there could be many possible VMS
2533  * error statuses that caused the errno value to be set.
2534  */
2535
2536 int Perl_unix_status_to_vms(int unix_status)
2537 {
2538 int test_unix_status;
2539
2540      /* Trivial cases first */
2541     /*---------------------*/
2542     if (unix_status == EVMSERR)
2543         return vaxc$errno;
2544
2545      /* Is vaxc$errno sane? */
2546     /*---------------------*/
2547     test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2548     if (test_unix_status == unix_status)
2549         return vaxc$errno;
2550
2551      /* If way out of range, must be VMS code already */
2552     /*-----------------------------------------------*/
2553     if (unix_status > EVMSERR)
2554         return unix_status;
2555
2556      /* If out of range, punt */
2557     /*-----------------------*/
2558     if (unix_status > __ERRNO_MAX)
2559         return SS$_ABORT;
2560
2561
2562      /* Ok, now we have to do it the hard way. */
2563     /*----------------------------------------*/
2564     switch(unix_status) {
2565     case 0:     return SS$_NORMAL;
2566     case EPERM: return SS$_NOPRIV;
2567     case ENOENT: return SS$_NOSUCHOBJECT;
2568     case ESRCH: return SS$_UNREACHABLE;
2569     case EINTR: return SS$_ABORT;
2570     /* case EIO: */
2571     /* case ENXIO:  */
2572     case E2BIG: return SS$_BUFFEROVF;
2573     /* case ENOEXEC */
2574     case EBADF: return RMS$_IFI;
2575     case ECHILD: return SS$_NONEXPR;
2576     /* case EAGAIN */
2577     case ENOMEM: return SS$_INSFMEM;
2578     case EACCES: return SS$_FILACCERR;
2579     case EFAULT: return SS$_ACCVIO;
2580     /* case ENOTBLK */
2581     case EBUSY: return SS$_DEVOFFLINE;
2582     case EEXIST: return RMS$_FEX;
2583     /* case EXDEV */
2584     case ENODEV: return SS$_NOSUCHDEV;
2585     case ENOTDIR: return RMS$_DIR;
2586     /* case EISDIR */
2587     case EINVAL: return SS$_INVARG;
2588     /* case ENFILE */
2589     /* case EMFILE */
2590     /* case ENOTTY */
2591     /* case ETXTBSY */
2592     /* case EFBIG */
2593     case ENOSPC: return SS$_DEVICEFULL;
2594     case ESPIPE: return LIB$_INVARG;
2595     /* case EROFS: */
2596     /* case EMLINK: */
2597     /* case EPIPE: */
2598     /* case EDOM */
2599     case ERANGE: return LIB$_INVARG;
2600     /* case EWOULDBLOCK */
2601     /* case EINPROGRESS */
2602     /* case EALREADY */
2603     /* case ENOTSOCK */
2604     /* case EDESTADDRREQ */
2605     /* case EMSGSIZE */
2606     /* case EPROTOTYPE */
2607     /* case ENOPROTOOPT */
2608     /* case EPROTONOSUPPORT */
2609     /* case ESOCKTNOSUPPORT */
2610     /* case EOPNOTSUPP */
2611     /* case EPFNOSUPPORT */
2612     /* case EAFNOSUPPORT */
2613     /* case EADDRINUSE */
2614     /* case EADDRNOTAVAIL */
2615     /* case ENETDOWN */
2616     /* case ENETUNREACH */
2617     /* case ENETRESET */
2618     /* case ECONNABORTED */
2619     /* case ECONNRESET */
2620     /* case ENOBUFS */
2621     /* case EISCONN */
2622     case ENOTCONN: return SS$_CLEARED;
2623     /* case ESHUTDOWN */
2624     /* case ETOOMANYREFS */
2625     /* case ETIMEDOUT */
2626     /* case ECONNREFUSED */
2627     /* case ELOOP */
2628     /* case ENAMETOOLONG */
2629     /* case EHOSTDOWN */
2630     /* case EHOSTUNREACH */
2631     /* case ENOTEMPTY */
2632     /* case EPROCLIM */
2633     /* case EUSERS  */
2634     /* case EDQUOT  */
2635     /* case ENOMSG  */
2636     /* case EIDRM */
2637     /* case EALIGN */
2638     /* case ESTALE */
2639     /* case EREMOTE */
2640     /* case ENOLCK */
2641     /* case ENOSYS */
2642     /* case EFTYPE */
2643     /* case ECANCELED */
2644     /* case EFAIL */
2645     /* case EINPROG */
2646     case ENOTSUP:
2647         return SS$_UNSUPPORTED;
2648     /* case EDEADLK */
2649     /* case ENWAIT */
2650     /* case EILSEQ */
2651     /* case EBADCAT */
2652     /* case EBADMSG */
2653     /* case EABANDONED */
2654     default:
2655         return SS$_ABORT; /* punt */
2656     }
2657
2658   return SS$_ABORT; /* Should not get here */
2659 }
2660
2661
2662 /* default piping mailbox size */
2663 #define PERL_BUFSIZ        512
2664
2665
2666 static void
2667 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2668 {
2669   unsigned long int mbxbufsiz;
2670   static unsigned long int syssize = 0;
2671   unsigned long int dviitm = DVI$_DEVNAM;
2672   char csize[LNM$C_NAMLENGTH+1];
2673   int sts;
2674
2675   if (!syssize) {
2676     unsigned long syiitm = SYI$_MAXBUF;
2677     /*
2678      * Get the SYSGEN parameter MAXBUF
2679      *
2680      * If the logical 'PERL_MBX_SIZE' is defined
2681      * use the value of the logical instead of PERL_BUFSIZ, but
2682      * keep the size between 128 and MAXBUF.
2683      *
2684      */
2685     _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2686   }
2687
2688   if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2689       mbxbufsiz = atoi(csize);
2690   } else {
2691       mbxbufsiz = PERL_BUFSIZ;
2692   }
2693   if (mbxbufsiz < 128) mbxbufsiz = 128;
2694   if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2695
2696   _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2697
2698   _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2699   namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2700
2701 }  /* end of create_mbx() */
2702
2703
2704 /*{{{  my_popen and my_pclose*/
2705
2706 typedef struct _iosb           IOSB;
2707 typedef struct _iosb*         pIOSB;
2708 typedef struct _pipe           Pipe;
2709 typedef struct _pipe*         pPipe;
2710 typedef struct pipe_details    Info;
2711 typedef struct pipe_details*  pInfo;
2712 typedef struct _srqp            RQE;
2713 typedef struct _srqp*          pRQE;
2714 typedef struct _tochildbuf      CBuf;
2715 typedef struct _tochildbuf*    pCBuf;
2716
2717 struct _iosb {
2718     unsigned short status;
2719     unsigned short count;
2720     unsigned long  dvispec;
2721 };
2722
2723 #pragma member_alignment save
2724 #pragma nomember_alignment quadword
2725 struct _srqp {          /* VMS self-relative queue entry */
2726     unsigned long qptr[2];
2727 };
2728 #pragma member_alignment restore
2729 static RQE  RQE_ZERO = {0,0};
2730
2731 struct _tochildbuf {
2732     RQE             q;
2733     int             eof;
2734     unsigned short  size;
2735     char            *buf;
2736 };
2737
2738 struct _pipe {
2739     RQE            free;
2740     RQE            wait;
2741     int            fd_out;
2742     unsigned short chan_in;
2743     unsigned short chan_out;
2744     char          *buf;
2745     unsigned int   bufsize;
2746     IOSB           iosb;
2747     IOSB           iosb2;
2748     int           *pipe_done;
2749     int            retry;
2750     int            type;
2751     int            shut_on_empty;
2752     int            need_wake;
2753     pPipe         *home;
2754     pInfo          info;
2755     pCBuf          curr;
2756     pCBuf          curr2;
2757 #if defined(PERL_IMPLICIT_CONTEXT)
2758     void            *thx;           /* Either a thread or an interpreter */
2759                                     /* pointer, depending on how we're built */
2760 #endif
2761 };
2762
2763
2764 struct pipe_details
2765 {
2766     pInfo           next;
2767     PerlIO *fp;  /* file pointer to pipe mailbox */
2768     int useFILE; /* using stdio, not perlio */
2769     int pid;   /* PID of subprocess */
2770     int mode;  /* == 'r' if pipe open for reading */
2771     int done;  /* subprocess has completed */
2772     int waiting; /* waiting for completion/closure */
2773     int             closing;        /* my_pclose is closing this pipe */
2774     unsigned long   completion;     /* termination status of subprocess */
2775     pPipe           in;             /* pipe in to sub */
2776     pPipe           out;            /* pipe out of sub */
2777     pPipe           err;            /* pipe of sub's sys$error */
2778     int             in_done;        /* true when in pipe finished */
2779     int             out_done;
2780     int             err_done;
2781     unsigned short  xchan;          /* channel to debug xterm */
2782     unsigned short  xchan_valid;    /* channel is assigned */
2783 };
2784
2785 struct exit_control_block
2786 {
2787     struct exit_control_block *flink;
2788     unsigned long int   (*exit_routine)();
2789     unsigned long int arg_count;
2790     unsigned long int *status_address;
2791     unsigned long int exit_status;
2792 };
2793
2794 typedef struct _closed_pipes    Xpipe;
2795 typedef struct _closed_pipes*  pXpipe;
2796
2797 struct _closed_pipes {
2798     int             pid;            /* PID of subprocess */
2799     unsigned long   completion;     /* termination status of subprocess */
2800 };
2801 #define NKEEPCLOSED 50
2802 static Xpipe closed_list[NKEEPCLOSED];
2803 static int   closed_index = 0;
2804 static int   closed_num = 0;
2805
2806 #define RETRY_DELAY     "0 ::0.20"
2807 #define MAX_RETRY              50
2808
2809 static int pipe_ef = 0;          /* first call to safe_popen inits these*/
2810 static unsigned long mypid;
2811 static unsigned long delaytime[2];
2812
2813 static pInfo open_pipes = NULL;
2814 static $DESCRIPTOR(nl_desc, "NL:");
2815
2816 #define PIPE_COMPLETION_WAIT    30  /* seconds, for EOF/FORCEX wait */
2817
2818
2819
2820 static unsigned long int
2821 pipe_exit_routine(pTHX)
2822 {
2823     pInfo info;
2824     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2825     int sts, did_stuff, need_eof, j;
2826
2827     /*
2828         flush any pending i/o
2829     */
2830     info = open_pipes;
2831     while (info) {
2832         if (info->fp) {
2833            if (!info->useFILE)
2834                PerlIO_flush(info->fp);   /* first, flush data */
2835            else
2836                fflush((FILE *)info->fp);
2837         }
2838         info = info->next;
2839     }
2840
2841     /*
2842      next we try sending an EOF...ignore if doesn't work, make sure we
2843      don't hang
2844     */
2845     did_stuff = 0;
2846     info = open_pipes;
2847
2848     while (info) {
2849       int need_eof;
2850       _ckvmssts_noperl(sys$setast(0));
2851       if (info->in && !info->in->shut_on_empty) {
2852         _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2853                           0, 0, 0, 0, 0, 0));
2854         info->waiting = 1;
2855         did_stuff = 1;
2856       }
2857       _ckvmssts_noperl(sys$setast(1));
2858       info = info->next;
2859     }
2860
2861     /* wait for EOF to have effect, up to ~ 30 sec [default] */
2862
2863     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2864         int nwait = 0;
2865
2866         info = open_pipes;
2867         while (info) {
2868           _ckvmssts_noperl(sys$setast(0));
2869           if (info->waiting && info->done)
2870                 info->waiting = 0;
2871           nwait += info->waiting;
2872           _ckvmssts_noperl(sys$setast(1));
2873           info = info->next;
2874         }
2875         if (!nwait) break;
2876         sleep(1);
2877     }
2878
2879     did_stuff = 0;
2880     info = open_pipes;
2881     while (info) {
2882       _ckvmssts_noperl(sys$setast(0));
2883       if (!info->done) { /* Tap them gently on the shoulder . . .*/
2884         sts = sys$forcex(&info->pid,0,&abort);
2885         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2886         did_stuff = 1;
2887       }
2888       _ckvmssts_noperl(sys$setast(1));
2889       info = info->next;
2890     }
2891
2892     /* again, wait for effect */
2893
2894     for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2895         int nwait = 0;
2896
2897         info = open_pipes;
2898         while (info) {
2899           _ckvmssts_noperl(sys$setast(0));
2900           if (info->waiting && info->done)
2901                 info->waiting = 0;
2902           nwait += info->waiting;
2903           _ckvmssts_noperl(sys$setast(1));
2904           info = info->next;
2905         }
2906         if (!nwait) break;
2907         sleep(1);
2908     }
2909
2910     info = open_pipes;
2911     while (info) {
2912       _ckvmssts_noperl(sys$setast(0));
2913       if (!info->done) {  /* We tried to be nice . . . */
2914         sts = sys$delprc(&info->pid,0);
2915         if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2916         info->done = 1;  /* sys$delprc is as done as we're going to get. */
2917       }
2918       _ckvmssts_noperl(sys$setast(1));
2919       info = info->next;
2920     }
2921
2922     while(open_pipes) {
2923       if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2924       else if (!(sts & 1)) retsts = sts;
2925     }
2926     return retsts;
2927 }
2928
2929 static struct exit_control_block pipe_exitblock =
2930        {(struct exit_control_block *) 0,
2931         pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2932
2933 static void pipe_mbxtofd_ast(pPipe p);
2934 static void pipe_tochild1_ast(pPipe p);
2935 static void pipe_tochild2_ast(pPipe p);
2936
2937 static void
2938 popen_completion_ast(pInfo info)
2939 {
2940   pInfo i = open_pipes;
2941   int iss;
2942   int sts;
2943   pXpipe x;
2944
2945   info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2946   closed_list[closed_index].pid = info->pid;
2947   closed_list[closed_index].completion = info->completion;
2948   closed_index++;
2949   if (closed_index == NKEEPCLOSED)
2950     closed_index = 0;
2951   closed_num++;
2952
2953   while (i) {
2954     if (i == info) break;
2955     i = i->next;
2956   }
2957   if (!i) return;       /* unlinked, probably freed too */
2958
2959   info->done = TRUE;
2960
2961 /*
2962     Writing to subprocess ...
2963             if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2964
2965             chan_out may be waiting for "done" flag, or hung waiting
2966             for i/o completion to child...cancel the i/o.  This will
2967             put it into "snarf mode" (done but no EOF yet) that discards
2968             input.
2969
2970     Output from subprocess (stdout, stderr) needs to be flushed and
2971     shut down.   We try sending an EOF, but if the mbx is full the pipe
2972     routine should still catch the "shut_on_empty" flag, telling it to
2973     use immediate-style reads so that "mbx empty" -> EOF.
2974
2975
2976 */
2977   if (info->in && !info->in_done) {               /* only for mode=w */
2978         if (info->in->shut_on_empty && info->in->need_wake) {
2979             info->in->need_wake = FALSE;
2980             _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2981         } else {
2982             _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2983         }
2984   }
2985
2986   if (info->out && !info->out_done) {             /* were we also piping output? */
2987       info->out->shut_on_empty = TRUE;
2988       iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2989       if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2990       _ckvmssts_noperl(iss);
2991   }
2992
2993   if (info->err && !info->err_done) {        /* we were piping stderr */
2994         info->err->shut_on_empty = TRUE;
2995         iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2996         if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2997         _ckvmssts_noperl(iss);
2998   }
2999   _ckvmssts_noperl(sys$setef(pipe_ef));
3000
3001 }
3002
3003 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3004 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3005
3006 /*
3007     we actually differ from vmstrnenv since we use this to
3008     get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3009     are pointing to the same thing
3010 */
3011
3012 static unsigned short
3013 popen_translate(pTHX_ char *logical, char *result)
3014 {
3015     int iss;
3016     $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3017     $DESCRIPTOR(d_log,"");
3018     struct _il3 {
3019         unsigned short length;
3020         unsigned short code;
3021         char *         buffer_addr;
3022         unsigned short *retlenaddr;
3023     } itmlst[2];
3024     unsigned short l, ifi;
3025
3026     d_log.dsc$a_pointer = logical;
3027     d_log.dsc$w_length  = strlen(logical);
3028
3029     itmlst[0].code = LNM$_STRING;
3030     itmlst[0].length = 255;
3031     itmlst[0].buffer_addr = result;
3032     itmlst[0].retlenaddr = &l;
3033
3034     itmlst[1].code = 0;
3035     itmlst[1].length = 0;
3036     itmlst[1].buffer_addr = 0;
3037     itmlst[1].retlenaddr = 0;
3038
3039     iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3040     if (iss == SS$_NOLOGNAM) {
3041         iss = SS$_NORMAL;
3042         l = 0;
3043     }
3044     if (!(iss&1)) lib$signal(iss);
3045     result[l] = '\0';
3046 /*
3047     logicals for PPFs have a 4 byte prefix  ESC+NUL+(RMS IFI)
3048     strip it off and return the ifi, if any
3049 */
3050     ifi  = 0;
3051     if (result[0] == 0x1b && result[1] == 0x00) {
3052         memmove(&ifi,result+2,2);
3053         strcpy(result,result+4);
3054     }
3055     return ifi;     /* this is the RMS internal file id */
3056 }
3057
3058 static void pipe_infromchild_ast(pPipe p);
3059
3060 /*
3061     I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3062     inside an AST routine without worrying about reentrancy and which Perl
3063     memory allocator is being used.
3064
3065     We read data and queue up the buffers, then spit them out one at a
3066     time to the output mailbox when the output mailbox is ready for one.
3067
3068 */
3069 #define INITIAL_TOCHILDQUEUE  2
3070
3071 static pPipe
3072 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3073 {
3074     pPipe p;
3075     pCBuf b;
3076     char mbx1[64], mbx2[64];
3077     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3078                                       DSC$K_CLASS_S, mbx1},
3079                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3080                                       DSC$K_CLASS_S, mbx2};
3081     unsigned int dviitm = DVI$_DEVBUFSIZ;
3082     int j, n;
3083
3084     n = sizeof(Pipe);
3085     _ckvmssts(lib$get_vm(&n, &p));
3086
3087     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3088     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3089     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3090
3091     p->buf           = 0;
3092     p->shut_on_empty = FALSE;
3093     p->need_wake     = FALSE;
3094     p->type          = 0;
3095     p->retry         = 0;
3096     p->iosb.status   = SS$_NORMAL;
3097     p->iosb2.status  = SS$_NORMAL;
3098     p->free          = RQE_ZERO;
3099     p->wait          = RQE_ZERO;
3100     p->curr          = 0;
3101     p->curr2         = 0;
3102     p->info          = 0;
3103 #ifdef PERL_IMPLICIT_CONTEXT
3104     p->thx           = aTHX;
3105 #endif
3106
3107     n = sizeof(CBuf) + p->bufsize;
3108
3109     for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3110         _ckvmssts(lib$get_vm(&n, &b));
3111         b->buf = (char *) b + sizeof(CBuf);
3112         _ckvmssts(lib$insqhi(b, &p->free));
3113     }
3114
3115     pipe_tochild2_ast(p);
3116     pipe_tochild1_ast(p);
3117     strcpy(wmbx, mbx1);
3118     strcpy(rmbx, mbx2);
3119     return p;
3120 }
3121
3122 /*  reads the MBX Perl is writing, and queues */
3123
3124 static void
3125 pipe_tochild1_ast(pPipe p)
3126 {
3127     pCBuf b = p->curr;
3128     int iss = p->iosb.status;
3129     int eof = (iss == SS$_ENDOFFILE);
3130     int sts;
3131 #ifdef PERL_IMPLICIT_CONTEXT
3132     pTHX = p->thx;
3133 #endif
3134
3135     if (p->retry) {
3136         if (eof) {
3137             p->shut_on_empty = TRUE;
3138             b->eof     = TRUE;
3139             _ckvmssts(sys$dassgn(p->chan_in));
3140         } else  {
3141             _ckvmssts(iss);
3142         }
3143
3144         b->eof  = eof;
3145         b->size = p->iosb.count;
3146         _ckvmssts(sts = lib$insqhi(b, &p->wait));
3147         if (p->need_wake) {
3148             p->need_wake = FALSE;
3149             _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3150         }
3151     } else {
3152         p->retry = 1;   /* initial call */
3153     }
3154
3155     if (eof) {                  /* flush the free queue, return when done */
3156         int n = sizeof(CBuf) + p->bufsize;
3157         while (1) {
3158             iss = lib$remqti(&p->free, &b);
3159             if (iss == LIB$_QUEWASEMP) return;
3160             _ckvmssts(iss);
3161             _ckvmssts(lib$free_vm(&n, &b));
3162         }
3163     }
3164
3165     iss = lib$remqti(&p->free, &b);
3166     if (iss == LIB$_QUEWASEMP) {
3167         int n = sizeof(CBuf) + p->bufsize;
3168         _ckvmssts(lib$get_vm(&n, &b));
3169         b->buf = (char *) b + sizeof(CBuf);
3170     } else {
3171        _ckvmssts(iss);
3172     }
3173
3174     p->curr = b;
3175     iss = sys$qio(0,p->chan_in,
3176              IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3177              &p->iosb,
3178              pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3179     if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3180     _ckvmssts(iss);
3181 }
3182
3183
3184 /* writes queued buffers to output, waits for each to complete before
3185    doing the next */
3186
3187 static void
3188 pipe_tochild2_ast(pPipe p)
3189 {
3190     pCBuf b = p->curr2;
3191     int iss = p->iosb2.status;
3192     int n = sizeof(CBuf) + p->bufsize;
3193     int done = (p->info && p->info->done) ||
3194               iss == SS$_CANCEL || iss == SS$_ABORT;
3195 #if defined(PERL_IMPLICIT_CONTEXT)
3196     pTHX = p->thx;
3197 #endif
3198
3199     do {
3200         if (p->type) {         /* type=1 has old buffer, dispose */
3201             if (p->shut_on_empty) {
3202                 _ckvmssts(lib$free_vm(&n, &b));
3203             } else {
3204                 _ckvmssts(lib$insqhi(b, &p->free));
3205             }
3206             p->type = 0;
3207         }
3208
3209         iss = lib$remqti(&p->wait, &b);
3210         if (iss == LIB$_QUEWASEMP) {
3211             if (p->shut_on_empty) {
3212                 if (done) {
3213                     _ckvmssts(sys$dassgn(p->chan_out));
3214                     *p->pipe_done = TRUE;
3215                     _ckvmssts(sys$setef(pipe_ef));
3216                 } else {
3217                     _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3218                         &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3219                 }
3220                 return;
3221             }
3222             p->need_wake = TRUE;
3223             return;
3224         }
3225         _ckvmssts(iss);
3226         p->type = 1;
3227     } while (done);
3228
3229
3230     p->curr2 = b;
3231     if (b->eof) {
3232         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3233             &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3234     } else {
3235         _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3236             &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3237     }
3238
3239     return;
3240
3241 }
3242
3243
3244 static pPipe
3245 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3246 {
3247     pPipe p;
3248     char mbx1[64], mbx2[64];
3249     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3250                                       DSC$K_CLASS_S, mbx1},
3251                             d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3252                                       DSC$K_CLASS_S, mbx2};
3253     unsigned int dviitm = DVI$_DEVBUFSIZ;
3254
3255     int n = sizeof(Pipe);
3256     _ckvmssts(lib$get_vm(&n, &p));
3257     create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3258     create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3259
3260     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3261     n = p->bufsize * sizeof(char);
3262     _ckvmssts(lib$get_vm(&n, &p->buf));
3263     p->shut_on_empty = FALSE;
3264     p->info   = 0;
3265     p->type   = 0;
3266     p->iosb.status = SS$_NORMAL;
3267 #if defined(PERL_IMPLICIT_CONTEXT)
3268     p->thx = aTHX;
3269 #endif
3270     pipe_infromchild_ast(p);
3271
3272     strcpy(wmbx, mbx1);
3273     strcpy(rmbx, mbx2);
3274     return p;
3275 }
3276
3277 static void
3278 pipe_infromchild_ast(pPipe p)
3279 {
3280     int iss = p->iosb.status;
3281     int eof = (iss == SS$_ENDOFFILE);
3282     int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3283     int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3284 #if defined(PERL_IMPLICIT_CONTEXT)
3285     pTHX = p->thx;
3286 #endif
3287
3288     if (p->info && p->info->closing && p->chan_out)  {           /* output shutdown */
3289         _ckvmssts(sys$dassgn(p->chan_out));
3290         p->chan_out = 0;
3291     }
3292
3293     /* read completed:
3294             input shutdown if EOF from self (done or shut_on_empty)
3295             output shutdown if closing flag set (my_pclose)
3296             send data/eof from child or eof from self
3297             otherwise, re-read (snarf of data from child)
3298     */
3299
3300     if (p->type == 1) {
3301         p->type = 0;
3302         if (myeof && p->chan_in) {                  /* input shutdown */
3303             _ckvmssts(sys$dassgn(p->chan_in));
3304             p->chan_in = 0;
3305         }
3306
3307         if (p->chan_out) {
3308             if (myeof || kideof) {      /* pass EOF to parent */
3309                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3310                               pipe_infromchild_ast, p,
3311                               0, 0, 0, 0, 0, 0));
3312                 return;
3313             } else if (eof) {       /* eat EOF --- fall through to read*/
3314
3315             } else {                /* transmit data */
3316                 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3317                               pipe_infromchild_ast,p,
3318                               p->buf, p->iosb.count, 0, 0, 0, 0));
3319                 return;
3320             }
3321         }
3322     }
3323
3324     /*  everything shut? flag as done */
3325
3326     if (!p->chan_in && !p->chan_out) {
3327         *p->pipe_done = TRUE;
3328         _ckvmssts(sys$setef(pipe_ef));
3329         return;
3330     }
3331
3332     /* write completed (or read, if snarfing from child)
3333             if still have input active,
3334                queue read...immediate mode if shut_on_empty so we get EOF if empty
3335             otherwise,
3336                check if Perl reading, generate EOFs as needed
3337     */
3338
3339     if (p->type == 0) {
3340         p->type = 1;
3341         if (p->chan_in) {
3342             iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3343                           pipe_infromchild_ast,p,
3344                           p->buf, p->bufsize, 0, 0, 0, 0);
3345             if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3346             _ckvmssts(iss);
3347         } else {           /* send EOFs for extra reads */
3348             p->iosb.status = SS$_ENDOFFILE;
3349             p->iosb.dvispec = 0;
3350             _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3351                       0, 0, 0,
3352                       pipe_infromchild_ast, p, 0, 0, 0, 0));
3353         }
3354     }
3355 }
3356
3357 static pPipe
3358 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3359 {
3360     pPipe p;
3361     char mbx[64];
3362     unsigned long dviitm = DVI$_DEVBUFSIZ;
3363     struct stat s;
3364     struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3365                                       DSC$K_CLASS_S, mbx};
3366     int n = sizeof(Pipe);
3367
3368     /* things like terminals and mbx's don't need this filter */
3369     if (fd && fstat(fd,&s) == 0) {
3370         unsigned long dviitm = DVI$_DEVCHAR, devchar;
3371         char device[65];
3372         unsigned short dev_len;
3373         struct dsc$descriptor_s d_dev;
3374         char * cptr;
3375         struct item_list_3 items[3];
3376         int status;
3377         unsigned short dvi_iosb[4];
3378
3379         cptr = getname(fd, out, 1);
3380         if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3381         d_dev.dsc$a_pointer = out;
3382         d_dev.dsc$w_length = strlen(out);
3383         d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3384         d_dev.dsc$b_class = DSC$K_CLASS_S;
3385
3386         items[0].len = 4;
3387         items[0].code = DVI$_DEVCHAR;
3388         items[0].bufadr = &devchar;
3389         items[0].retadr = NULL;
3390         items[1].len = 64;
3391         items[1].code = DVI$_FULLDEVNAM;
3392         items[1].bufadr = device;
3393         items[1].retadr = &dev_len;
3394         items[2].len = 0;
3395         items[2].code = 0;
3396
3397         status = sys$getdviw
3398                 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3399         _ckvmssts(status);
3400         if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3401             device[dev_len] = 0;
3402
3403             if (!(devchar & DEV$M_DIR)) {
3404                 strcpy(out, device);
3405                 return 0;
3406             }
3407         }
3408     }
3409
3410     _ckvmssts(lib$get_vm(&n, &p));
3411     p->fd_out = dup(fd);
3412     create_mbx(aTHX_ &p->chan_in, &d_mbx);
3413     _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3414     n = (p->bufsize+1) * sizeof(char);
3415     _ckvmssts(lib$get_vm(&n, &p->buf));
3416     p->shut_on_empty = FALSE;
3417     p->retry = 0;
3418     p->info  = 0;
3419     strcpy(out, mbx);
3420
3421     _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3422                   pipe_mbxtofd_ast, p,
3423                   p->buf, p->bufsize, 0, 0, 0, 0));
3424
3425     return p;
3426 }
3427
3428 static void
3429 pipe_mbxtofd_ast(pPipe p)
3430 {
3431     int iss = p->iosb.status;
3432     int done = p->info->done;
3433     int iss2;
3434     int eof = (iss == SS$_ENDOFFILE);
3435     int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3436     int err = !(iss&1) && !eof;
3437 #if defined(PERL_IMPLICIT_CONTEXT)
3438     pTHX = p->thx;
3439 #endif
3440
3441     if (done && myeof) {               /* end piping */
3442         close(p->fd_out);
3443         sys$dassgn(p->chan_in);
3444         *p->pipe_done = TRUE;
3445         _ckvmssts(sys$setef(pipe_ef));
3446         return;
3447     }
3448
3449     if (!err && !eof) {             /* good data to send to file */
3450         p->buf[p->iosb.count] = '\n';
3451         iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3452         if (iss2 < 0) {
3453             p->retry++;
3454             if (p->retry < MAX_RETRY) {
3455                 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3456                 return;
3457             }
3458         }
3459         p->retry = 0;
3460     } else if (err) {
3461         _ckvmssts(iss);
3462     }
3463
3464
3465     iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3466           pipe_mbxtofd_ast, p,
3467           p->buf, p->bufsize, 0, 0, 0, 0);
3468     if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3469     _ckvmssts(iss);
3470 }
3471
3472
3473 typedef struct _pipeloc     PLOC;
3474 typedef struct _pipeloc*   pPLOC;
3475
3476 struct _pipeloc {
3477     pPLOC   next;
3478     char    dir[NAM$C_MAXRSS+1];
3479 };
3480 static pPLOC  head_PLOC = 0;
3481
3482 void
3483 free_pipelocs(pTHX_ void *head)
3484 {
3485     pPLOC p, pnext;
3486     pPLOC *pHead = (pPLOC *)head;
3487
3488     p = *pHead;
3489     while (p) {
3490         pnext = p->next;
3491         PerlMem_free(p);
3492         p = pnext;
3493     }
3494     *pHead = 0;
3495 }
3496
3497 static void
3498 store_pipelocs(pTHX)
3499 {
3500     int    i;
3501     pPLOC  p;
3502     AV    *av = 0;
3503     SV    *dirsv;
3504     GV    *gv;
3505     char  *dir, *x;
3506     char  *unixdir;
3507     char  temp[NAM$C_MAXRSS+1];
3508     STRLEN n_a;
3509
3510     if (head_PLOC)
3511         free_pipelocs(aTHX_ &head_PLOC);
3512
3513 /*  the . directory from @INC comes last */
3514
3515     p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3516     if (p == NULL) _ckvmssts(SS$_INSFMEM);
3517     p->next = head_PLOC;
3518     head_PLOC = p;
3519     strcpy(p->dir,"./");
3520
3521 /*  get the directory from $^X */
3522
3523     unixdir = PerlMem_malloc(VMS_MAXRSS);
3524     if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3525
3526 #ifdef PERL_IMPLICIT_CONTEXT
3527     if (aTHX && PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3528 #else
3529     if (PL_origargv && PL_origargv[0]) {    /* maybe nul if embedded Perl */
3530 #endif
3531         strcpy(temp, PL_origargv[0]);
3532         x = strrchr(temp,']');
3533         if (x == NULL) {
3534         x = strrchr(temp,'>');
3535           if (x == NULL) {
3536             /* It could be a UNIX path */
3537             x = strrchr(temp,'/');
3538           }
3539         }
3540         if (x)
3541           x[1] = '\0';
3542         else {
3543           /* Got a bare name, so use default directory */
3544           temp[0] = '.';
3545           temp[1] = '\0';
3546         }
3547
3548         if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3549             p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3550             if (p == NULL) _ckvmssts(SS$_INSFMEM);
3551             p->next = head_PLOC;
3552             head_PLOC = p;
3553             strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3554             p->dir[NAM$C_MAXRSS] = '\0';
3555         }
3556     }
3557
3558 /*  reverse order of @INC entries, skip "." since entered above */
3559
3560 #ifdef PERL_IMPLICIT_CONTEXT
3561     if (aTHX)
3562 #endif
3563     if (PL_incgv) av = GvAVn(PL_incgv);
3564
3565     for (i = 0; av && i <= AvFILL(av); i++) {
3566         dirsv = *av_fetch(av,i,TRUE);
3567
3568         if (SvROK(dirsv)) continue;
3569         dir = SvPVx(dirsv,n_a);
3570         if (strcmp(dir,".") == 0) continue;
3571         if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3572             continue;
3573
3574         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3575         p->next = head_PLOC;
3576         head_PLOC = p;
3577         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3578         p->dir[NAM$C_MAXRSS] = '\0';
3579     }
3580
3581 /* most likely spot (ARCHLIB) put first in the list */
3582
3583 #ifdef ARCHLIB_EXP
3584     if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3585         p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3586         if (p == NULL) _ckvmssts(SS$_INSFMEM);
3587         p->next = head_PLOC;
3588         head_PLOC = p;
3589         strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3590         p->dir[NAM$C_MAXRSS] = '\0';
3591     }
3592 #endif
3593     PerlMem_free(unixdir);
3594 }
3595
3596 static I32
3597 Perl_cando_by_name_int
3598    (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3599 #if !defined(PERL_IMPLICIT_CONTEXT)
3600 #define cando_by_name_int               Perl_cando_by_name_int
3601 #else
3602 #define cando_by_name_int(a,b,c,d)      Perl_cando_by_name_int(aTHX_ a,b,c,d)
3603 #endif
3604
3605 static char *
3606 find_vmspipe(pTHX)
3607 {
3608     static int   vmspipe_file_status = 0;
3609     static char  vmspipe_file[NAM$C_MAXRSS+1];
3610
3611     /* already found? Check and use ... need read+execute permission */
3612
3613     if (vmspipe_file_status == 1) {
3614         if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3615          && cando_by_name_int
3616            (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3617             return vmspipe_file;
3618         }
3619         vmspipe_file_status = 0;
3620     }
3621
3622     /* scan through stored @INC, $^X */
3623
3624     if (vmspipe_file_status == 0) {
3625         char file[NAM$C_MAXRSS+1];
3626         pPLOC  p = head_PLOC;
3627
3628         while (p) {
3629             char * exp_res;
3630             int dirlen;
3631             strcpy(file, p->dir);
3632             dirlen = strlen(file);
3633             strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3634             file[NAM$C_MAXRSS] = '\0';
3635             p = p->next;
3636
3637             exp_res = do_rmsexpand
3638                 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3639             if (!exp_res) continue;
3640
3641             if (cando_by_name_int
3642                 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3643              && cando_by_name_int
3644                    (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3645                 vmspipe_file_status = 1;
3646                 return vmspipe_file;
3647             }
3648         }
3649         vmspipe_file_status = -1;   /* failed, use tempfiles */
3650     }
3651
3652     return 0;
3653 }
3654
3655 static FILE *
3656 vmspipe_tempfile(pTHX)
3657 {
3658     char file[NAM$C_MAXRSS+1];
3659     FILE *fp;
3660     static int index = 0;
3661     Stat_t s0, s1;
3662     int cmp_result;
3663
3664     /* create a tempfile */
3665
3666     /* we can't go from   W, shr=get to  R, shr=get without
3667        an intermediate vulnerable state, so don't bother trying...
3668
3669        and lib$spawn doesn't shr=put, so have to close the write
3670
3671        So... match up the creation date/time and the FID to
3672        make sure we're dealing with the same file
3673
3674     */
3675
3676     index++;
3677     if (!decc_filename_unix_only) {
3678       sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3679       fp = fopen(file,"w");
3680       if (!fp) {
3681         sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3682         fp = fopen(file,"w");
3683         if (!fp) {
3684             sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3685             fp = fopen(file,"w");
3686         }
3687       }
3688      }
3689      else {
3690       sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3691       fp = fopen(file,"w");
3692       if (!fp) {
3693         sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3694         fp = fopen(file,"w");
3695         if (!fp) {
3696           sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3697           fp = fopen(file,"w");
3698         }
3699       }
3700     }
3701     if (!fp) return 0;  /* we're hosed */
3702
3703     fprintf(fp,"$! 'f$verify(0)'\n");
3704     fprintf(fp,"$!  ---  protect against nonstandard definitions ---\n");
3705     fprintf(fp,"$ perl_cfile  = f$environment(\"procedure\")\n");
3706     fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3707     fprintf(fp,"$ perl_on     = \"set noon\"\n");
3708     fprintf(fp,"$ perl_exit   = \"exit\"\n");
3709     fprintf(fp,"$ perl_del    = \"delete\"\n");
3710     fprintf(fp,"$ pif         = \"if\"\n");
3711     fprintf(fp,"$!  --- define i/o redirection (sys$output set by lib$spawn)\n");
3712     fprintf(fp,"$ pif perl_popen_in  .nes. \"\" then perl_define/user/name_attributes=confine sys$input  'perl_popen_in'\n");
3713     fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error  'perl_popen_err'\n");
3714     fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define      sys$output 'perl_popen_out'\n");
3715     fprintf(fp,"$!  --- build command line to get max possible length\n");
3716     fprintf(fp,"$c=perl_popen_cmd0\n");
3717     fprintf(fp,"$c=c+perl_popen_cmd1\n");
3718     fprintf(fp,"$c=c+perl_popen_cmd2\n");
3719     fprintf(fp,"$x=perl_popen_cmd3\n");
3720     fprintf(fp,"$c=c+x\n");
3721     fprintf(fp,"$ perl_on\n");
3722     fprintf(fp,"$ 'c'\n");
3723     fprintf(fp,"$ perl_status = $STATUS\n");
3724     fprintf(fp,"$ perl_del  'perl_cfile'\n");
3725     fprintf(fp,"$ perl_exit 'perl_status'\n");
3726     fsync(fileno(fp));
3727
3728     fgetname(fp, file, 1);
3729     fstat(fileno(fp), (struct stat *)&s0);
3730     fclose(fp);
3731
3732     if (decc_filename_unix_only)
3733         do_tounixspec(file, file, 0, NULL);
3734     fp = fopen(file,"r","shr=get");
3735     if (!fp) return 0;
3736     fstat(fileno(fp), (struct stat *)&s1);
3737
3738     cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3739     if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime))  {
3740         fclose(fp);
3741         return 0;
3742     }
3743
3744     return fp;
3745 }
3746
3747
3748 #ifdef USE_VMS_DECTERM
3749
3750 static int vms_is_syscommand_xterm(void)
3751 {
3752     const static struct dsc$descriptor_s syscommand_dsc =
3753       { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3754
3755     const static struct dsc$descriptor_s decwdisplay_dsc =
3756       { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3757
3758     struct item_list_3 items[2];
3759     unsigned short dvi_iosb[4];
3760     unsigned long devchar;
3761     unsigned long devclass;
3762     int status;
3763
3764     /* Very simple check to guess if sys$command is a decterm? */
3765     /* First see if the DECW$DISPLAY: device exists */
3766     items[0].len = 4;
3767     items[0].code = DVI$_DEVCHAR;
3768     items[0].bufadr = &devchar;
3769     items[0].retadr = NULL;
3770     items[1].len = 0;
3771     items[1].code = 0;
3772
3773     status = sys$getdviw
3774         (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3775
3776     if ($VMS_STATUS_SUCCESS(status)) {
3777         status = dvi_iosb[0];
3778     }
3779
3780     if (!$VMS_STATUS_SUCCESS(status)) {
3781         SETERRNO(EVMSERR, status);
3782         return -1;
3783     }
3784
3785     /* If it does, then for now assume that we are on a workstation */
3786     /* Now verify that SYS$COMMAND is a terminal */
3787     /* for creating the debugger DECTerm */
3788
3789     items[0].len = 4;
3790     items[0].code = DVI$_DEVCLASS;
3791     items[0].bufadr = &devclass;
3792     items[0].retadr = NULL;
3793     items[1].len = 0;
3794     items[1].code = 0;
3795
3796     status = sys$getdviw
3797         (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3798
3799     if ($VMS_STATUS_SUCCESS(status)) {
3800         status = dvi_iosb[0];
3801     }
3802
3803     if (!$VMS_STATUS_SUCCESS(status)) {
3804         SETERRNO(EVMSERR, status);
3805         return -1;
3806     }
3807     else {
3808         if (devclass == DC$_TERM) {
3809             return 0;
3810         }
3811     }
3812     return -1;
3813 }
3814
3815 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3816 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3817 {
3818     int status;
3819     int ret_stat;
3820     char * ret_char;
3821     char device_name[65];
3822     unsigned short device_name_len;
3823     struct dsc$descriptor_s customization_dsc;
3824     struct dsc$descriptor_s device_name_dsc;
3825     const char * cptr;
3826     char * tptr;
3827     char customization[200];
3828     char title[40];
3829     pInfo info = NULL;
3830     char mbx1[64];
3831     unsigned short p_chan;
3832     int n;
3833     unsigned short iosb[4];
3834     struct item_list_3 items[2];
3835     const char * cust_str =
3836         "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3837     struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3838                                           DSC$K_CLASS_S, mbx1};
3839
3840     ret_char = strstr(cmd," xterm ");
3841     if (ret_char == NULL)
3842         return NULL;
3843     cptr = ret_char + 7;
3844     ret_char = strstr(cmd,"tty");
3845     if (ret_char == NULL)
3846         return NULL;
3847     ret_char = strstr(cmd,"sleep");
3848     if (ret_char == NULL)
3849         return NULL;
3850
3851     /* Are we on a workstation? */
3852     /* to do: capture the rows / columns and pass their properties */
3853     ret_stat = vms_is_syscommand_xterm();
3854     if (ret_stat < 0)
3855         return NULL;
3856
3857     /* Make the title: */
3858     ret_char = strstr(cptr,"-title");
3859     if (ret_char != NULL) {
3860         while ((*cptr != 0) && (*cptr != '\"')) {
3861             cptr++;
3862         }
3863         if (*cptr == '\"')
3864             cptr++;
3865         n = 0;
3866         while ((*cptr != 0) && (*cptr != '\"')) {
3867             title[n] = *cptr;
3868             n++;
3869             if (n == 39) {
3870                 title[39] == 0;
3871                 break;
3872             }
3873             cptr++;
3874         }
3875         title[n] = 0;
3876     }
3877     else {
3878             /* Default title */
3879             strcpy(title,"Perl Debug DECTerm");
3880     }
3881     sprintf(customization, cust_str, title);
3882
3883     customization_dsc.dsc$a_pointer = customization;
3884     customization_dsc.dsc$w_length = strlen(customization);
3885     customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3886     customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3887
3888     device_name_dsc.dsc$a_pointer = device_name;
3889     device_name_dsc.dsc$w_length = sizeof device_name -1;
3890     device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3891     device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3892
3893     device_name_len = 0;
3894
3895     /* Try to create the window */
3896      status = decw$term_port
3897        (NULL,
3898         NULL,
3899         &customization_dsc,
3900         &device_name_dsc,
3901         &device_name_len,
3902         NULL,
3903         NULL,
3904         NULL);
3905     if (!$VMS_STATUS_SUCCESS(status)) {
3906         SETERRNO(EVMSERR, status);
3907         return NULL;
3908     }
3909
3910     device_name[device_name_len] = '\0';
3911
3912     /* Need to set this up to look like a pipe for cleanup */
3913     n = sizeof(Info);
3914     status = lib$get_vm(&n, &info);
3915     if (!$VMS_STATUS_SUCCESS(status)) {
3916         SETERRNO(ENOMEM, status);
3917         return NULL;
3918     }
3919
3920     info->mode = *mode;
3921     info->done = FALSE;
3922     info->completion = 0;
3923     info->closing    = FALSE;
3924     info->in         = 0;
3925     info->out        = 0;
3926     info->err        = 0;
3927     info->fp         = Nullfp;
3928     info->useFILE    = 0;
3929     info->waiting    = 0;
3930     info->in_done    = TRUE;
3931     info->out_done   = TRUE;
3932     info->err_done   = TRUE;
3933
3934     /* Assign a channel on this so that it will persist, and not login */
3935     /* We stash this channel in the info structure for reference. */
3936     /* The created xterm self destructs when the last channel is removed */
3937     /* and it appears that perl5db.pl (perl debugger) does this routinely */
3938     /* So leave this assigned. */
3939     device_name_dsc.dsc$w_length = device_name_len;
3940     status = sys$assign(&device_name_dsc,&info->xchan,0,0);
3941     if (!$VMS_STATUS_SUCCESS(status)) {
3942         SETERRNO(EVMSERR, status);
3943         return NULL;
3944     }
3945     info->xchan_valid = 1;
3946
3947     /* Now create a mailbox to be read by the application */
3948
3949     create_mbx(aTHX_ &p_chan, &d_mbx1);
3950
3951     /* write the name of the created terminal to the mailbox */
3952     status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
3953             iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
3954
3955     if (!$VMS_STATUS_SUCCESS(status)) {
3956         SETERRNO(EVMSERR, status);
3957         return NULL;
3958     }
3959
3960     info->fp  = PerlIO_open(mbx1, mode);
3961
3962     /* Done with this channel */
3963     sys$dassgn(p_chan);
3964
3965     /* If any errors, then clean up */
3966     if (!info->fp) {
3967         n = sizeof(Info);
3968         _ckvmssts(lib$free_vm(&n, &info));
3969         return NULL;
3970         }
3971
3972     /* All done */
3973     return info->fp;
3974 }
3975 #endif
3976
3977 static PerlIO *
3978 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3979 {
3980     static int handler_set_up = FALSE;
3981     unsigned long int sts, flags = CLI$M_NOWAIT;
3982     /* The use of a GLOBAL table (as was done previously) rendered
3983      * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3984      * environment.  Hence we've switched to LOCAL symbol table.
3985      */
3986     unsigned int table = LIB$K_CLI_LOCAL_SYM;
3987     int j, wait = 0, n;
3988     char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3989     char *in, *out, *err, mbx[512];
3990     FILE *tpipe = 0;
3991     char tfilebuf[NAM$C_MAXRSS+1];
3992     pInfo info = NULL;
3993     char cmd_sym_name[20];
3994     struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3995                                       DSC$K_CLASS_S, symbol};
3996     struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3997                                       DSC$K_CLASS_S, 0};
3998     struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3999                                       DSC$K_CLASS_S, cmd_sym_name};
4000     struct dsc$descriptor_s *vmscmd;
4001     $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4002     $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4003     $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4004
4005 #ifdef USE_VMS_DECTERM
4006     /* Check here for Xterm create request.  This means looking for
4007      * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4008      *  is possible to create an xterm.
4009      */
4010     if (*in_mode == 'r') {
4011         PerlIO * xterm_fd;
4012
4013         xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4014         if (xterm_fd != Nullfp)
4015             return xterm_fd;
4016     }
4017 #endif
4018
4019     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */
4020
4021     /* once-per-program initialization...
4022        note that the SETAST calls and the dual test of pipe_ef
4023        makes sure that only the FIRST thread through here does
4024        the initialization...all other threads wait until it's
4025        done.
4026
4027        Yeah, uglier than a pthread call, it's got all the stuff inline
4028        rather than in a separate routine.
4029     */
4030
4031     if (!pipe_ef) {
4032         _ckvmssts(sys$setast(0));
4033         if (!pipe_ef) {
4034             unsigned long int pidcode = JPI$_PID;
4035             $DESCRIPTOR(d_delay, RETRY_DELAY);
4036             _ckvmssts(lib$get_ef(&pipe_ef));
4037             _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4038             _ckvmssts(sys$bintim(&d_delay, delaytime));
4039         }
4040         if (!handler_set_up) {
4041           _ckvmssts(sys$dclexh(&pipe_exitblock));
4042           handler_set_up = TRUE;
4043         }
4044         _ckvmssts(sys$setast(1));
4045     }
4046
4047     /* see if we can find a VMSPIPE.COM */
4048
4049     tfilebuf[0] = '@';
4050     vmspipe = find_vmspipe(aTHX);
4051     if (vmspipe) {
4052         strcpy(tfilebuf+1,vmspipe);
4053     } else {        /* uh, oh...we're in tempfile hell */
4054         tpipe = vmspipe_tempfile(aTHX);
4055         if (!tpipe) {       /* a fish popular in Boston */
4056             if (ckWARN(WARN_PIPE)) {
4057                 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4058             }
4059         return Nullfp;
4060         }
4061         fgetname(tpipe,tfilebuf+1,1);
4062     }
4063     vmspipedsc.dsc$a_pointer = tfilebuf;
4064     vmspipedsc.dsc$w_length  = strlen(tfilebuf);
4065
4066     sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4067     if (!(sts & 1)) {
4068       switch (sts) {
4069         case RMS$_FNF:  case RMS$_DNF:
4070           set_errno(ENOENT); break;
4071         case RMS$_DIR:
4072           set_errno(ENOTDIR); break;
4073         case RMS$_DEV:
4074           set_errno(ENODEV); break;
4075         case RMS$_PRV:
4076           set_errno(EACCES); break;
4077         case RMS$_SYN:
4078           set_errno(EINVAL); break;
4079         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4080           set_errno(E2BIG); break;
4081         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4082           _ckvmssts(sts); /* fall through */
4083         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4084           set_errno(EVMSERR);
4085       }
4086       set_vaxc_errno(sts);
4087       if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4088         Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4089       }
4090       *psts = sts;
4091       return Nullfp;
4092     }
4093     n = sizeof(Info);
4094     _ckvmssts(lib$get_vm(&n, &info));
4095
4096     strcpy(mode,in_mode);
4097     info->mode = *mode;
4098     info->done = FALSE;
4099     info->completion = 0;
4100     info->closing    = FALSE;
4101     info->in         = 0;
4102     info->out        = 0;
4103     info->err        = 0;
4104     info->fp         = Nullfp;
4105     info->useFILE    = 0;
4106     info->waiting    = 0;
4107     info->in_done    = TRUE;
4108     info->out_done   = TRUE;
4109     info->err_done   = TRUE;
4110     info->xchan      = 0;
4111     info->xchan_valid = 0;
4112
4113     in = PerlMem_malloc(VMS_MAXRSS);
4114     if (in == NULL) _ckvmssts(SS$_INSFMEM);
4115     out = PerlMem_malloc(VMS_MAXRSS);
4116     if (out == NULL) _ckvmssts(SS$_INSFMEM);
4117     err = PerlMem_malloc(VMS_MAXRSS);
4118     if (err == NULL) _ckvmssts(SS$_INSFMEM);
4119
4120     in[0] = out[0] = err[0] = '\0';
4121
4122     if ((p = strchr(mode,'F')) != NULL) {   /* F -> use FILE* */
4123         info->useFILE = 1;
4124         strcpy(p,p+1);
4125     }
4126     if ((p = strchr(mode,'W')) != NULL) {   /* W -> wait for completion */
4127         wait = 1;
4128         strcpy(p,p+1);
4129     }
4130
4131     if (*mode == 'r') {             /* piping from subroutine */
4132
4133         info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4134         if (info->out) {
4135             info->out->pipe_done = &info->out_done;
4136             info->out_done = FALSE;
4137             info->out->info = info;
4138         }
4139         if (!info->useFILE) {
4140             info->fp  = PerlIO_open(mbx, mode);
4141         } else {
4142             info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4143             Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4144         }
4145
4146         if (!info->fp && info->out) {
4147             sys$cancel(info->out->chan_out);
4148
4149             while (!info->out_done) {
4150                 int done;
4151                 _ckvmssts(sys$setast(0));
4152                 done = info->out_done;
4153                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4154                 _ckvmssts(sys$setast(1));
4155                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4156             }
4157
4158             if (info->out->buf) {
4159                 n = info->out->bufsize * sizeof(char);
4160                 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4161             }
4162             n = sizeof(Pipe);
4163             _ckvmssts(lib$free_vm(&n, &info->out));
4164             n = sizeof(Info);
4165             _ckvmssts(lib$free_vm(&n, &info));
4166             *psts = RMS$_FNF;
4167             return Nullfp;
4168         }
4169
4170         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4171         if (info->err) {
4172             info->err->pipe_done = &info->err_done;
4173             info->err_done = FALSE;
4174             info->err->info = info;
4175         }
4176
4177     } else if (*mode == 'w') {      /* piping to subroutine */
4178
4179         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4180         if (info->out) {
4181             info->out->pipe_done = &info->out_done;
4182             info->out_done = FALSE;
4183             info->out->info = info;
4184         }
4185
4186         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4187         if (info->err) {
4188             info->err->pipe_done = &info->err_done;
4189             info->err_done = FALSE;
4190             info->err->info = info;
4191         }
4192
4193         info->in = pipe_tochild_setup(aTHX_ in,mbx);
4194         if (!info->useFILE) {
4195             info->fp  = PerlIO_open(mbx, mode);
4196         } else {
4197             info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4198             Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4199         }
4200
4201         if (info->in) {
4202             info->in->pipe_done = &info->in_done;
4203             info->in_done = FALSE;
4204             info->in->info = info;
4205         }
4206
4207         /* error cleanup */
4208         if (!info->fp && info->in) {
4209             info->done = TRUE;
4210             _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4211                               0, 0, 0, 0, 0, 0, 0, 0));
4212
4213             while (!info->in_done) {
4214                 int done;
4215                 _ckvmssts(sys$setast(0));
4216                 done = info->in_done;
4217                 if (!done) _ckvmssts(sys$clref(pipe_ef));
4218                 _ckvmssts(sys$setast(1));
4219                 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4220             }
4221
4222             if (info->in->buf) {
4223                 n = info->in->bufsize * sizeof(char);
4224                 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4225             }
4226             n = sizeof(Pipe);
4227             _ckvmssts(lib$free_vm(&n, &info->in));
4228             n = sizeof(Info);
4229             _ckvmssts(lib$free_vm(&n, &info));
4230             *psts = RMS$_FNF;
4231             return Nullfp;
4232         }
4233
4234
4235     } else if (*mode == 'n') {       /* separate subprocess, no Perl i/o */
4236         info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4237         if (info->out) {
4238             info->out->pipe_done = &info->out_done;
4239             info->out_done = FALSE;
4240             info->out->info = info;
4241         }
4242
4243         info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4244         if (info->err) {
4245             info->err->pipe_done = &info->err_done;
4246             info->err_done = FALSE;
4247             info->err->info = info;
4248         }
4249     }
4250
4251     symbol[MAX_DCL_SYMBOL] = '\0';
4252
4253     strncpy(symbol, in, MAX_DCL_SYMBOL);
4254     d_symbol.dsc$w_length = strlen(symbol);
4255     _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4256
4257     strncpy(symbol, err, MAX_DCL_SYMBOL);
4258     d_symbol.dsc$w_length = strlen(symbol);
4259     _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4260
4261     strncpy(symbol, out, MAX_DCL_SYMBOL);
4262     d_symbol.dsc$w_length = strlen(symbol);
4263     _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4264
4265     /* Done with the names for the pipes */
4266     PerlMem_free(err);
4267     PerlMem_free(out);
4268     PerlMem_free(in);
4269
4270     p = vmscmd->dsc$a_pointer;
4271     while (*p == ' ' || *p == '\t') p++;        /* remove leading whitespace */
4272     if (*p == '$') p++;                         /* remove leading $ */
4273     while (*p == ' ' || *p == '\t') p++;
4274
4275     for (j = 0; j < 4; j++) {
4276         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4277         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4278
4279     strncpy(symbol, p, MAX_DCL_SYMBOL);
4280     d_symbol.dsc$w_length = strlen(symbol);
4281     _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4282
4283         if (strlen(p) > MAX_DCL_SYMBOL) {
4284             p += MAX_DCL_SYMBOL;
4285         } else {
4286             p += strlen(p);
4287         }
4288     }
4289     _ckvmssts(sys$setast(0));
4290     info->next=open_pipes;  /* prepend to list */
4291     open_pipes=info;
4292     _ckvmssts(sys$setast(1));
4293     /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4294      * and SYS$COMMAND.  vmspipe.com will redefine SYS$INPUT, but we'll still
4295      * have SYS$COMMAND if we need it.
4296      */
4297     _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4298                       0, &info->pid, &info->completion,
4299                       0, popen_completion_ast,info,0,0,0));
4300
4301     /* if we were using a tempfile, close it now */
4302
4303     if (tpipe) fclose(tpipe);
4304
4305     /* once the subprocess is spawned, it has copied the symbols and
4306        we can get rid of ours */
4307
4308     for (j = 0; j < 4; j++) {
4309         sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4310         d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4311     _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4312     }
4313     _ckvmssts(lib$delete_symbol(&d_sym_in,  &table));
4314     _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4315     _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4316     vms_execfree(vmscmd);
4317
4318 #ifdef PERL_IMPLICIT_CONTEXT
4319     if (aTHX)
4320 #endif
4321     PL_forkprocess = info->pid;
4322
4323     if (wait) {
4324          int done = 0;
4325          while (!done) {
4326              _ckvmssts(sys$setast(0));
4327              done = info->done;
4328              if (!done) _ckvmssts(sys$clref(pipe_ef));
4329              _ckvmssts(sys$setast(1));
4330              if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4331          }
4332         *psts = info->completion;
4333 /* Caller thinks it is open and tries to close it. */
4334 /* This causes some problems, as it changes the error status */
4335 /*        my_pclose(info->fp); */
4336     } else {
4337         *psts = SS$_NORMAL;
4338     }
4339     return info->fp;
4340 }  /* end of safe_popen */
4341
4342
4343 /*{{{  PerlIO *my_popen(char *cmd, char *mode)*/
4344 PerlIO *
4345 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4346 {
4347     int sts;
4348     TAINT_ENV();
4349     TAINT_PROPER("popen");
4350     PERL_FLUSHALL_FOR_CHILD;
4351     return safe_popen(aTHX_ cmd,mode,&sts);
4352 }
4353
4354 /*}}}*/
4355
4356 /*{{{  I32 my_pclose(PerlIO *fp)*/
4357 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4358 {
4359     pInfo info, last = NULL;
4360     unsigned long int retsts;
4361     int done, iss, n;
4362     int status;
4363
4364     for (info = open_pipes; info != NULL; last = info, info = info->next)
4365         if (info->fp == fp) break;
4366
4367     if (info == NULL) {  /* no such pipe open */
4368       set_errno(ECHILD); /* quoth POSIX */
4369       set_vaxc_errno(SS$_NONEXPR);
4370       return -1;
4371     }
4372
4373     /* If we were writing to a subprocess, insure that someone reading from
4374      * the mailbox gets an EOF.  It looks like a simple fclose() doesn't
4375      * produce an EOF record in the mailbox.
4376      *
4377      *  well, at least sometimes it *does*, so we have to watch out for
4378      *  the first EOF closing the pipe (and DASSGN'ing the channel)...
4379      */
4380      if (info->fp) {
4381         if (!info->useFILE)
4382             PerlIO_flush(info->fp);   /* first, flush data */
4383         else
4384             fflush((FILE *)info->fp);
4385     }
4386
4387     _ckvmssts(sys$setast(0));
4388      info->closing = TRUE;
4389      done = info->done && info->in_done && info->out_done && info->err_done;
4390      /* hanging on write to Perl's input? cancel it */
4391      if (info->mode == 'r' && info->out && !info->out_done) {
4392         if (info->out->chan_out) {
4393             _ckvmssts(sys$cancel(info->out->chan_out));
4394             if (!info->out->chan_in) {   /* EOF generation, need AST */
4395                 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4396             }
4397         }
4398      }
4399      if (info->in && !info->in_done && !info->in->shut_on_empty)  /* EOF if hasn't had one yet */
4400          _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4401                            0, 0, 0, 0, 0, 0));
4402     _ckvmssts(sys$setast(1));
4403     if (info->fp) {
4404      if (!info->useFILE)
4405         PerlIO_close(info->fp);
4406      else
4407         fclose((FILE *)info->fp);
4408     }
4409      /*
4410         we have to wait until subprocess completes, but ALSO wait until all
4411         the i/o completes...otherwise we'll be freeing the "info" structure
4412         that the i/o ASTs could still be using...
4413      */
4414
4415      while (!done) {
4416          _ckvmssts(sys$setast(0));
4417          done = info->done && info->in_done && info->out_done && info->err_done;
4418          if (!done) _ckvmssts(sys$clref(pipe_ef));
4419          _ckvmssts(sys$setast(1));
4420          if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4421      }
4422      retsts = info->completion;
4423
4424     /* remove from list of open pipes */
4425     _ckvmssts(sys$setast(0));
4426     if (last) last->next = info->next;
4427     else open_pipes = info->next;
4428     _ckvmssts(sys$setast(1));
4429
4430     /* free buffers and structures */
4431
4432     if (info->in) {
4433         if (info->in->buf) {
4434             n = info->in->bufsize * sizeof(char);
4435             _ckvmssts(lib$free_vm(&n, &info->in->buf));
4436         }
4437         n = sizeof(Pipe);
4438         _ckvmssts(lib$free_vm(&n, &info->in));
4439     }
4440     if (info->out) {
4441         if (info->out->buf) {
4442             n = info->out->bufsize * sizeof(char);
4443             _ckvmssts(lib$free_vm(&n, &info->out->buf));
4444         }
4445         n = sizeof(Pipe);
4446         _ckvmssts(lib$free_vm(&n, &info->out));
4447     }
4448     if (info->err) {
4449         if (info->err->buf) {
4450             n = info->err->bufsize * sizeof(char);
4451             _ckvmssts(lib$free_vm(&n, &info->err->buf));
4452         }
4453         n = sizeof(Pipe);
4454         _ckvmssts(lib$free_vm(&n, &info->err));
4455     }
4456     n = sizeof(Info);
4457     _ckvmssts(lib$free_vm(&n, &info));
4458
4459     return retsts;
4460
4461 }  /* end of my_pclose() */
4462
4463 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4464   /* Roll our own prototype because we want this regardless of whether
4465    * _VMS_WAIT is defined.
4466    */
4467   __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4468 #endif
4469 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4470    created with popen(); otherwise partially emulate waitpid() unless
4471    we have a suitable one from the CRTL that came with VMS 7.2 and later.
4472    Also check processes not considered by the CRTL waitpid().
4473  */
4474 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4475 Pid_t
4476 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4477 {
4478     pInfo info;
4479     int done;
4480     int sts;
4481     int j;
4482
4483     if (statusp) *statusp = 0;
4484
4485     for (info = open_pipes; info != NULL; info = info->next)
4486         if (info->pid == pid) break;
4487
4488     if (info != NULL) {  /* we know about this child */
4489       while (!info->done) {
4490           _ckvmssts(sys$setast(0));
4491           done = info->done;
4492           if (!done) _ckvmssts(sys$clref(pipe_ef));
4493           _ckvmssts(sys$setast(1));
4494           if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4495       }
4496
4497       if (statusp) *statusp = info->completion;
4498       return pid;
4499     }
4500
4501     /* child that already terminated? */
4502
4503     for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4504         if (closed_list[j].pid == pid) {
4505             if (statusp) *statusp = closed_list[j].completion;
4506             return pid;
4507         }
4508     }
4509
4510     /* fall through if this child is not one of our own pipe children */
4511
4512 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4513
4514       /* waitpid() became available in the CRTL as of VMS 7.0, but only
4515        * in 7.2 did we get a version that fills in the VMS completion
4516        * status as Perl has always tried to do.
4517        */
4518
4519       sts = __vms_waitpid( pid, statusp, flags );
4520
4521       if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4522          return sts;
4523
4524       /* If the real waitpid tells us the child does not exist, we
4525        * fall through here to implement waiting for a child that
4526        * was created by some means other than exec() (say, spawned
4527        * from DCL) or to wait for a process that is not a subprocess
4528        * of the current process.
4529        */
4530
4531 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4532
4533     {
4534       $DESCRIPTOR(intdsc,"0 00:00:01");
4535       unsigned long int ownercode = JPI$_OWNER, ownerpid;
4536       unsigned long int pidcode = JPI$_PID, mypid;
4537       unsigned long int interval[2];
4538       unsigned int jpi_iosb[2];
4539       struct itmlst_3 jpilist[2] = {
4540           {sizeof(ownerpid),        JPI$_OWNER, &ownerpid,        0},
4541           {                      0,         0,                 0, 0}
4542       };
4543
4544       if (pid <= 0) {
4545         /* Sorry folks, we don't presently implement rooting around for
4546            the first child we can find, and we definitely don't want to
4547            pass a pid of -1 to $getjpi, where it is a wildcard operation.
4548          */
4549         set_errno(ENOTSUP);
4550         return -1;
4551       }
4552
4553       /* Get the owner of the child so I can warn if it's not mine. If the
4554        * process doesn't exist or I don't have the privs to look at it,
4555        * I can go home early.
4556        */
4557       sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4558       if (sts & 1) sts = jpi_iosb[0];
4559       if (!(sts & 1)) {
4560         switch (sts) {
4561             case SS$_NONEXPR:
4562                 set_errno(ECHILD);
4563                 break;
4564             case SS$_NOPRIV:
4565                 set_errno(EACCES);
4566                 break;
4567             default:
4568                 _ckvmssts(sts);
4569         }
4570         set_vaxc_errno(sts);
4571         return -1;
4572       }
4573
4574       if (ckWARN(WARN_EXEC)) {
4575         /* remind folks they are asking for non-standard waitpid behavior */
4576         _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4577         if (ownerpid != mypid)
4578           Perl_warner(aTHX_ packWARN(WARN_EXEC),
4579                       "waitpid: process %x is not a child of process %x",
4580                       pid,mypid);
4581       }
4582
4583       /* simply check on it once a second until it's not there anymore. */
4584
4585       _ckvmssts(sys$bintim(&intdsc,interval));
4586       while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4587             _ckvmssts(sys$schdwk(0,0,interval,0));
4588             _ckvmssts(sys$hiber());
4589       }
4590       if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4591
4592       _ckvmssts(sts);
4593       return pid;
4594     }
4595 }  /* end of waitpid() */
4596 /*}}}*/
4597 /*}}}*/
4598 /*}}}*/
4599
4600 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4601 char *
4602 my_gconvert(double val, int ndig, int trail, char *buf)
4603 {
4604   static char __gcvtbuf[DBL_DIG+1];
4605   char *loc;
4606
4607   loc = buf ? buf : __gcvtbuf;
4608
4609 #ifndef __DECC  /* VAXCRTL gcvt uses E format for numbers < 1 */
4610   if (val < 1) {
4611     sprintf(loc,"%.*g",ndig,val);
4612     return loc;
4613   }
4614 #endif
4615
4616   if (val) {
4617     if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4618     return gcvt(val,ndig,loc);
4619   }
4620   else {
4621     loc[0] = '0'; loc[1] = '\0';
4622     return loc;
4623   }
4624
4625 }
4626 /*}}}*/
4627
4628 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4629 static int rms_free_search_context(struct FAB * fab)
4630 {
4631 struct NAM * nam;
4632
4633     nam = fab->fab$l_nam;
4634     nam->nam$b_nop |= NAM$M_SYNCHK;
4635     nam->nam$l_rlf = NULL;
4636     fab->fab$b_dns = 0;
4637     return sys$parse(fab, NULL, NULL);
4638 }
4639
4640 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4641 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4642 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4643 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4644 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4645 #define rms_nam_esll(nam) nam.nam$b_esl
4646 #define rms_nam_esl(nam) nam.nam$b_esl
4647 #define rms_nam_name(nam) nam.nam$l_name
4648 #define rms_nam_namel(nam) nam.nam$l_name
4649 #define rms_nam_type(nam) nam.nam$l_type
4650 #define rms_nam_typel(nam) nam.nam$l_type
4651 #define rms_nam_ver(nam) nam.nam$l_ver
4652 #define rms_nam_verl(nam) nam.nam$l_ver
4653 #define rms_nam_rsll(nam) nam.nam$b_rsl
4654 #define rms_nam_rsl(nam) nam.nam$b_rsl
4655 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4656 #define rms_set_fna(fab, nam, name, size) \
4657         { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4658 #define rms_get_fna(fab, nam) fab.fab$l_fna
4659 #define rms_set_dna(fab, nam, name, size) \
4660         { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4661 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4662 #define rms_set_esa(fab, nam, name, size) \
4663         { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4664 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4665         { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4666 #define rms_set_rsa(nam, name, size) \
4667         { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4668 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4669         { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4670 #define rms_nam_name_type_l_size(nam) \
4671         (nam.nam$b_name + nam.nam$b_type)
4672 #else
4673 static int rms_free_search_context(struct FAB * fab)
4674 {
4675 struct NAML * nam;
4676
4677     nam = fab->fab$l_naml;
4678     nam->naml$b_nop |= NAM$M_SYNCHK;
4679     nam->naml$l_rlf = NULL;
4680     nam->naml$l_long_defname_size = 0;
4681
4682     fab->fab$b_dns = 0;
4683     return sys$parse(fab, NULL, NULL);
4684 }
4685
4686 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4687 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4688 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4689 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4690 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4691 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4692 #define rms_nam_esl(nam) nam.naml$b_esl
4693 #define rms_nam_name(nam) nam.naml$l_name
4694 #define rms_nam_namel(nam) nam.naml$l_long_name
4695 #define rms_nam_type(nam) nam.naml$l_type
4696 #define rms_nam_typel(nam) nam.naml$l_long_type
4697 #define rms_nam_ver(nam) nam.naml$l_ver
4698 #define rms_nam_verl(nam) nam.naml$l_long_ver
4699 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4700 #define rms_nam_rsl(nam) nam.naml$b_rsl
4701 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4702 #define rms_set_fna(fab, nam, name, size) \
4703         { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4704         nam.naml$l_long_filename_size = size; \
4705         nam.naml$l_long_filename = name;}
4706 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4707 #define rms_set_dna(fab, nam, name, size) \
4708         { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4709         nam.naml$l_long_defname_size = size; \
4710         nam.naml$l_long_defname = name; }
4711 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4712 #define rms_set_esa(fab, nam, name, size) \
4713         { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4714         nam.naml$l_long_expand_alloc = size; \
4715         nam.naml$l_long_expand = name; }
4716 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4717         { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4718         nam.naml$l_long_expand = l_name; \
4719         nam.naml$l_long_expand_alloc = l_size; }
4720 #define rms_set_rsa(nam, name, size) \
4721         { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4722         nam.naml$l_long_result = name; \
4723         nam.naml$l_long_result_alloc = size; }
4724 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4725         { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4726         nam.naml$l_long_result = l_name; \
4727         nam.naml$l_long_result_alloc = l_size; }
4728 #define rms_nam_name_type_l_size(nam) \
4729         (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4730 #endif
4731
4732
4733 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4734 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4735  * to expand file specification.  Allows for a single default file
4736  * specification and a simple mask of options.  If outbuf is non-NULL,
4737  * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4738  * the resultant file specification is placed.  If outbuf is NULL, the
4739  * resultant file specification is placed into a static buffer.
4740  * The third argument, if non-NULL, is taken to be a default file
4741  * specification string.  The fourth argument is unused at present.
4742  * rmesexpand() returns the address of the resultant string if
4743  * successful, and NULL on error.
4744  *
4745  * New functionality for previously unused opts value:
4746  *  PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4747  *  PERL_RMSEXPAND_M_LONG - Want output in long formst
4748  *  PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4749  */
4750 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4751
4752 static char *
4753 mp_do_rmsexpand
4754    (pTHX_ const char *filespec,
4755     char *outbuf,
4756     int ts,
4757     const char *defspec,
4758     unsigned opts,
4759     int * fs_utf8,
4760     int * dfs_utf8)
4761 {
4762   static char __rmsexpand_retbuf[VMS_MAXRSS];
4763   char * vmsfspec, *tmpfspec;
4764   char * esa, *cp, *out = NULL;
4765   char * tbuf;
4766   char * esal = NULL;
4767   char * outbufl;
4768   struct FAB myfab = cc$rms_fab;
4769   rms_setup_nam(mynam);
4770   STRLEN speclen;
4771   unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4772   int sts;
4773
4774   /* temp hack until UTF8 is actually implemented */
4775   if (fs_utf8 != NULL)
4776     *fs_utf8 = 0;
4777
4778   if (!filespec || !*filespec) {
4779     set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4780     return NULL;
4781   }
4782   if (!outbuf) {
4783     if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4784     else    outbuf = __rmsexpand_retbuf;
4785   }
4786
4787   vmsfspec = NULL;
4788   tmpfspec = NULL;
4789   outbufl = NULL;
4790
4791   isunix = 0;
4792   if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4793     isunix = is_unix_filespec(filespec);
4794     if (isunix) {
4795       vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4796       if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4797       if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4798         PerlMem_free(vmsfspec);
4799         if (out)
4800            Safefree(out);
4801         return NULL;
4802       }
4803       filespec = vmsfspec;
4804
4805       /* Unless we are forcing to VMS format, a UNIX input means
4806        * UNIX output, and that requires long names to be used
4807        */
4808       if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4809         opts |= PERL_RMSEXPAND_M_LONG;
4810       else {
4811         isunix = 0;
4812       }
4813     }
4814   }
4815
4816   rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4817   rms_bind_fab_nam(myfab, mynam);
4818
4819   if (defspec && *defspec) {
4820     int t_isunix;
4821     t_isunix = is_unix_filespec(defspec);
4822     if (t_isunix) {
4823       tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4824       if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4825       if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4826         PerlMem_free(tmpfspec);
4827         if (vmsfspec != NULL)
4828             PerlMem_free(vmsfspec);
4829         if (out)
4830            Safefree(out);
4831         return NULL;
4832       }
4833       defspec = tmpfspec;
4834     }
4835     rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4836   }
4837
4838   esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4839   if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4840 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4841   esal = PerlMem_malloc(VMS_MAXRSS);
4842   if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4843 #endif
4844   rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4845
4846   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4847     rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4848   }
4849   else {
4850 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4851     outbufl = PerlMem_malloc(VMS_MAXRSS);
4852     if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4853     rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4854 #else
4855     rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4856 #endif
4857   }
4858
4859 #ifdef NAM$M_NO_SHORT_UPCASE
4860   if (decc_efs_case_preserve)
4861     rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4862 #endif
4863
4864   /* First attempt to parse as an existing file */
4865   retsts = sys$parse(&myfab,0,0);
4866   if (!(retsts & STS$K_SUCCESS)) {
4867
4868     /* Could not find the file, try as syntax only if error is not fatal */
4869     rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4870     if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4871       retsts = sys$parse(&myfab,0,0);
4872       if (retsts & STS$K_SUCCESS) goto expanded;
4873     }
4874
4875      /* Still could not parse the file specification */
4876     /*----------------------------------------------*/
4877     sts = rms_free_search_context(&myfab); /* Free search context */
4878     if (out) Safefree(out);
4879     if (tmpfspec != NULL)
4880         PerlMem_free(tmpfspec);
4881     if (vmsfspec != NULL)
4882         PerlMem_free(vmsfspec);
4883     if (outbufl != NULL)
4884         PerlMem_free(outbufl);
4885     PerlMem_free(esa);
4886     if (esal != NULL)
4887         PerlMem_free(esal);
4888     set_vaxc_errno(retsts);
4889     if      (retsts == RMS$_PRV) set_errno(EACCES);
4890     else if (retsts == RMS$_DEV) set_errno(ENODEV);
4891     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4892     else                         set_errno(EVMSERR);
4893     return NULL;
4894   }
4895   retsts = sys$search(&myfab,0,0);
4896   if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4897     sts = rms_free_search_context(&myfab); /* Free search context */
4898     if (out) Safefree(out);
4899     if (tmpfspec != NULL)
4900         PerlMem_free(tmpfspec);
4901     if (vmsfspec != NULL)
4902         PerlMem_free(vmsfspec);
4903     if (outbufl != NULL)
4904         PerlMem_free(outbufl);
4905     PerlMem_free(esa);
4906     if (esal != NULL)
4907         PerlMem_free(esal);
4908     set_vaxc_errno(retsts);
4909     if      (retsts == RMS$_PRV) set_errno(EACCES);
4910     else                         set_errno(EVMSERR);
4911     return NULL;
4912   }
4913
4914   /* If the input filespec contained any lowercase characters,
4915    * downcase the result for compatibility with Unix-minded code. */
4916   expanded:
4917   if (!decc_efs_case_preserve) {
4918     for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4919       if (islower(*tbuf)) { haslower = 1; break; }
4920   }
4921
4922    /* Is a long or a short name expected */
4923   /*------------------------------------*/
4924   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4925     if (rms_nam_rsll(mynam)) {
4926         tbuf = outbuf;
4927         speclen = rms_nam_rsll(mynam);
4928     }
4929     else {
4930         tbuf = esal; /* Not esa */
4931         speclen = rms_nam_esll(mynam);
4932     }
4933   }
4934   else {
4935     if (rms_nam_rsl(mynam)) {
4936         tbuf = outbuf;
4937         speclen = rms_nam_rsl(mynam);
4938     }
4939     else {
4940         tbuf = esa; /* Not esal */
4941         speclen = rms_nam_esl(mynam);
4942     }
4943   }
4944   tbuf[speclen] = '\0';
4945
4946   /* Trim off null fields added by $PARSE
4947    * If type > 1 char, must have been specified in original or default spec
4948    * (not true for version; $SEARCH may have added version of existing file).
4949    */
4950   trimver  = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4951   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4952     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4953              ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4954   }
4955   else {
4956     trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4957              ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4958   }
4959   if (trimver || trimtype) {
4960     if (defspec && *defspec) {
4961       char *defesal = NULL;
4962       defesal = PerlMem_malloc(VMS_MAXRSS + 1);
4963       if (defesal != NULL) {
4964         struct FAB deffab = cc$rms_fab;
4965         rms_setup_nam(defnam);
4966
4967         rms_bind_fab_nam(deffab, defnam);
4968
4969         /* Cast ok */
4970         rms_set_fna
4971             (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4972
4973         rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4974
4975         rms_clear_nam_nop(defnam);
4976         rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4977 #ifdef NAM$M_NO_SHORT_UPCASE
4978         if (decc_efs_case_preserve)
4979           rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4980 #endif
4981         if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4982           if (trimver) {
4983              trimver  = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4984           }
4985           if (trimtype) {
4986             trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4987           }
4988         }
4989         PerlMem_free(defesal);
4990       }
4991     }
4992     if (trimver) {
4993       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4994         if (*(rms_nam_verl(mynam)) != '\"')
4995           speclen = rms_nam_verl(mynam) - tbuf;
4996       }
4997       else {
4998         if (*(rms_nam_ver(mynam)) != '\"')
4999           speclen = rms_nam_ver(mynam) - tbuf;
5000       }
5001     }
5002     if (trimtype) {
5003       /* If we didn't already trim version, copy down */
5004       if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5005         if (speclen > rms_nam_verl(mynam) - tbuf)
5006           memmove
5007            (rms_nam_typel(mynam),
5008             rms_nam_verl(mynam),
5009             speclen - (rms_nam_verl(mynam) - tbuf));
5010           speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5011       }
5012       else {
5013         if (speclen > rms_nam_ver(mynam) - tbuf)
5014           memmove
5015            (rms_nam_type(mynam),
5016             rms_nam_ver(mynam),
5017             speclen - (rms_nam_ver(mynam) - tbuf));
5018           speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5019       }
5020     }
5021   }
5022
5023    /* Done with these copies of the input files */
5024   /*-------------------------------------------*/
5025   if (vmsfspec != NULL)
5026         PerlMem_free(vmsfspec);
5027   if (tmpfspec != NULL)
5028         PerlMem_free(tmpfspec);
5029
5030   /* If we just had a directory spec on input, $PARSE "helpfully"
5031    * adds an empty name and type for us */
5032   if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5033     if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5034         rms_nam_verl(mynam)  == rms_nam_typel(mynam) + 1 &&
5035         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5036       speclen = rms_nam_namel(mynam) - tbuf;
5037   }
5038   else {
5039     if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5040         rms_nam_ver(mynam)  == rms_nam_ver(mynam) + 1 &&
5041         !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5042       speclen = rms_nam_name(mynam) - tbuf;
5043   }
5044
5045   /* Posix format specifications must have matching quotes */
5046   if (speclen < (VMS_MAXRSS - 1)) {
5047     if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5048       if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5049         tbuf[speclen] = '\"';
5050         speclen++;
5051       }
5052     }
5053   }
5054   tbuf[speclen] = '\0';
5055   if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5056
5057   /* Have we been working with an expanded, but not resultant, spec? */
5058   /* Also, convert back to Unix syntax if necessary. */
5059
5060   if (!rms_nam_rsll(mynam)) {
5061     if (isunix) {
5062       if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
5063         if (out) Safefree(out);
5064         if (esal != NULL)
5065             PerlMem_free(esal);
5066         PerlMem_free(esa);
5067         if (outbufl != NULL)
5068             PerlMem_free(outbufl);
5069         return NULL;
5070       }
5071     }
5072     else strcpy(outbuf,esa);
5073   }
5074   else if (isunix) {
5075     tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5076     if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5077     if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
5078         if (out) Safefree(out);
5079         PerlMem_free(esa);
5080         if (esal != NULL)
5081             PerlMem_free(esal);
5082         PerlMem_free(tmpfspec);
5083         if (outbufl != NULL)
5084             PerlMem_free(outbufl);
5085         return NULL;
5086     }
5087     strcpy(outbuf,tmpfspec);
5088     PerlMem_free(tmpfspec);
5089   }
5090
5091   rms_set_rsal(mynam, NULL, 0, NULL, 0);
5092   sts = rms_free_search_context(&myfab); /* Free search context */
5093   PerlMem_free(esa);
5094   if (esal != NULL)
5095      PerlMem_free(esal);
5096   if (outbufl != NULL)
5097      PerlMem_free(outbufl);
5098   return outbuf;
5099 }
5100 /*}}}*/
5101 /* External entry points */
5102 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5103 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5104 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5105 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5106 char *Perl_rmsexpand_utf8
5107   (pTHX_ const char *spec, char *buf, const char *def,
5108    unsigned opt, int * fs_utf8, int * dfs_utf8)
5109 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5110 char *Perl_rmsexpand_utf8_ts
5111   (pTHX_ const char *spec, char *buf, const char *def,
5112    unsigned opt, int * fs_utf8, int * dfs_utf8)
5113 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5114
5115
5116 /*
5117 ** The following routines are provided to make life easier when
5118 ** converting among VMS-style and Unix-style directory specifications.
5119 ** All will take input specifications in either VMS or Unix syntax. On
5120 ** failure, all return NULL.  If successful, the routines listed below
5121 ** return a pointer to a buffer containing the appropriately
5122 ** reformatted spec (and, therefore, subsequent calls to that routine
5123 ** will clobber the result), while the routines of the same names with
5124 ** a _ts suffix appended will return a pointer to a mallocd string
5125 ** containing the appropriately reformatted spec.
5126 ** In all cases, only explicit syntax is altered; no check is made that
5127 ** the resulting string is valid or that the directory in question
5128 ** actually exists.
5129 **
5130 **   fileify_dirspec() - convert a directory spec into the name of the
5131 **     directory file (i.e. what you can stat() to see if it's a dir).
5132 **     The style (VMS or Unix) of the result is the same as the style
5133 **     of the parameter passed in.
5134 **   pathify_dirspec() - convert a directory spec into a path (i.e.
5135 **     what you prepend to a filename to indicate what directory it's in).
5136 **     The style (VMS or Unix) of the result is the same as the style
5137 **     of the parameter passed in.
5138 **   tounixpath() - convert a directory spec into a Unix-style path.
5139 **   tovmspath() - convert a directory spec into a VMS-style path.
5140 **   tounixspec() - convert any file spec into a Unix-style file spec.
5141 **   tovmsspec() - convert any file spec into a VMS-style spec.
5142 **   xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5143 **
5144 ** Copyright 1996 by Charles Bailey  <bailey@newman.upenn.edu>
5145 ** Permission is given to distribute this code as part of the Perl
5146 ** standard distribution under the terms of the GNU General Public
5147 ** License or the Perl Artistic License.  Copies of each may be
5148 ** found in the Perl standard distribution.
5149  */
5150
5151 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5152 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5153 {
5154     static char __fileify_retbuf[VMS_MAXRSS];
5155     unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5156     char *retspec, *cp1, *cp2, *lastdir;
5157     char *trndir, *vmsdir;
5158     unsigned short int trnlnm_iter_count;
5159     int sts;
5160     if (utf8_fl != NULL)
5161         *utf8_fl = 0;
5162
5163     if (!dir || !*dir) {
5164       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5165     }
5166     dirlen = strlen(dir);
5167     while (dirlen && dir[dirlen-1] == '/') --dirlen;
5168     if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5169       if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5170         dir = "/sys$disk";
5171         dirlen = 9;
5172       }
5173       else
5174         dirlen = 1;
5175     }
5176     if (dirlen > (VMS_MAXRSS - 1)) {
5177       set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5178       return NULL;
5179     }
5180     trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5181     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5182     if (!strpbrk(dir+1,"/]>:")  &&
5183         (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5184       strcpy(trndir,*dir == '/' ? dir + 1: dir);
5185       trnlnm_iter_count = 0;
5186       while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
5187         trnlnm_iter_count++;
5188         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5189       }
5190       dirlen = strlen(trndir);
5191     }
5192     else {
5193       strncpy(trndir,dir,dirlen);
5194       trndir[dirlen] = '\0';
5195     }
5196
5197     /* At this point we are done with *dir and use *trndir which is a
5198      * copy that can be modified.  *dir must not be modified.
5199      */
5200
5201     /* If we were handed a rooted logical name or spec, treat it like a
5202      * simple directory, so that
5203      *    $ Define myroot dev:[dir.]
5204      *    ... do_fileify_dirspec("myroot",buf,1) ...
5205      * does something useful.
5206      */
5207     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5208       trndir[--dirlen] = '\0';
5209       trndir[dirlen-1] = ']';
5210     }
5211     if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5212       trndir[--dirlen] = '\0';
5213       trndir[dirlen-1] = '>';
5214     }
5215
5216     if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5217       /* If we've got an explicit filename, we can just shuffle the string. */
5218       if (*(cp1+1)) hasfilename = 1;
5219       /* Similarly, we can just back up a level if we've got multiple levels
5220          of explicit directories in a VMS spec which ends with directories. */
5221       else {
5222         for (cp2 = cp1; cp2 > trndir; cp2--) {
5223           if (*cp2 == '.') {
5224             if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5225 /* fix-me, can not scan EFS file specs backward like this */
5226               *cp2 = *cp1; *cp1 = '\0';
5227               hasfilename = 1;
5228               break;
5229             }
5230           }
5231           if (*cp2 == '[' || *cp2 == '<') break;
5232         }
5233       }
5234     }
5235
5236     vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5237     if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5238     cp1 = strpbrk(trndir,"]:>");
5239     if (hasfilename || !cp1) { /* Unix-style path or filename */
5240       if (trndir[0] == '.') {
5241         if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5242           PerlMem_free(trndir);
5243           PerlMem_free(vmsdir);
5244           return do_fileify_dirspec("[]",buf,ts,NULL);
5245         }
5246         else if (trndir[1] == '.' &&
5247                (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5248           PerlMem_free(trndir);
5249           PerlMem_free(vmsdir);
5250           return do_fileify_dirspec("[-]",buf,ts,NULL);
5251         }
5252       }
5253       if (dirlen && trndir[dirlen-1] == '/') {    /* path ends with '/'; just add .dir;1 */
5254         dirlen -= 1;                 /* to last element */
5255         lastdir = strrchr(trndir,'/');
5256       }
5257       else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5258         /* If we have "/." or "/..", VMSify it and let the VMS code
5259          * below expand it, rather than repeating the code to handle
5260          * relative components of a filespec here */
5261         do {
5262           if (*(cp1+2) == '.') cp1++;
5263           if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5264             char * ret_chr;
5265             if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5266                 PerlMem_free(trndir);
5267                 PerlMem_free(vmsdir);
5268                 return NULL;
5269             }
5270             if (strchr(vmsdir,'/') != NULL) {
5271               /* If do_tovmsspec() returned it, it must have VMS syntax
5272                * delimiters in it, so it's a mixed VMS/Unix spec.  We take
5273                * the time to check this here only so we avoid a recursion
5274                * loop; otherwise, gigo.
5275                */
5276               PerlMem_free(trndir);
5277               PerlMem_free(vmsdir);
5278               set_errno(EINVAL);  set_vaxc_errno(RMS$_SYN);
5279               return NULL;
5280             }
5281             if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5282                 PerlMem_free(trndir);
5283                 PerlMem_free(vmsdir);
5284                 return NULL;
5285             }
5286             ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5287             PerlMem_free(trndir);
5288             PerlMem_free(vmsdir);
5289             return ret_chr;
5290           }
5291           cp1++;
5292         } while ((cp1 = strstr(cp1,"/.")) != NULL);
5293         lastdir = strrchr(trndir,'/');
5294       }
5295       else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5296         char * ret_chr;
5297         /* Ditto for specs that end in an MFD -- let the VMS code
5298          * figure out whether it's a real device or a rooted logical. */
5299
5300         /* This should not happen any more.  Allowing the fake /000000
5301          * in a UNIX pathname causes all sorts of problems when trying
5302          * to run in UNIX emulation.  So the VMS to UNIX conversions
5303          * now remove the fake /000000 directories.
5304          */
5305
5306         trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5307         if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5308             PerlMem_free(trndir);
5309             PerlMem_free(vmsdir);
5310             return NULL;
5311         }
5312         if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5313             PerlMem_free(trndir);
5314             PerlMem_free(vmsdir);
5315             return NULL;
5316         }
5317         ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5318         PerlMem_free(trndir);
5319         PerlMem_free(vmsdir);
5320         return ret_chr;
5321       }
5322       else {
5323
5324         if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5325              !(lastdir = cp1 = strrchr(trndir,']')) &&
5326              !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5327         if ((cp2 = strchr(cp1,'.'))) {  /* look for explicit type */
5328           int ver; char *cp3;
5329
5330           /* For EFS or ODS-5 look for the last dot */
5331           if (decc_efs_charset) {
5332               cp2 = strrchr(cp1,'.');
5333           }
5334           if (vms_process_case_tolerant) {
5335               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5336                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5337                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5338                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5339                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5340                             (ver || *cp3)))))) {
5341                   PerlMem_free(trndir);
5342                   PerlMem_free(vmsdir);
5343                   set_errno(ENOTDIR);
5344                   set_vaxc_errno(RMS$_DIR);
5345                   return NULL;
5346               }
5347           }
5348           else {
5349               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5350                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5351                   !*(cp2+3) || *(cp2+3) != 'R' ||
5352                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5353                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5354                             (ver || *cp3)))))) {
5355                  PerlMem_free(trndir);
5356                  PerlMem_free(vmsdir);
5357                  set_errno(ENOTDIR);
5358                  set_vaxc_errno(RMS$_DIR);
5359                  return NULL;
5360               }
5361           }
5362           dirlen = cp2 - trndir;
5363         }
5364       }
5365
5366       retlen = dirlen + 6;
5367       if (buf) retspec = buf;
5368       else if (ts) Newx(retspec,retlen+1,char);
5369       else retspec = __fileify_retbuf;
5370       memcpy(retspec,trndir,dirlen);
5371       retspec[dirlen] = '\0';
5372
5373       /* We've picked up everything up to the directory file name.
5374          Now just add the type and version, and we're set. */
5375       if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5376         strcat(retspec,".dir;1");
5377       else
5378         strcat(retspec,".DIR;1");
5379       PerlMem_free(trndir);
5380       PerlMem_free(vmsdir);
5381       return retspec;
5382     }
5383     else {  /* VMS-style directory spec */
5384
5385       char *esa, term, *cp;
5386       unsigned long int sts, cmplen, haslower = 0;
5387       unsigned int nam_fnb;
5388       char * nam_type;
5389       struct FAB dirfab = cc$rms_fab;
5390       rms_setup_nam(savnam);
5391       rms_setup_nam(dirnam);
5392
5393       esa = PerlMem_malloc(VMS_MAXRSS + 1);
5394       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5395       rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5396       rms_bind_fab_nam(dirfab, dirnam);
5397       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5398       rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5399 #ifdef NAM$M_NO_SHORT_UPCASE
5400       if (decc_efs_case_preserve)
5401         rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5402 #endif
5403
5404       for (cp = trndir; *cp; cp++)
5405         if (islower(*cp)) { haslower = 1; break; }
5406       if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5407         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5408           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5409           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5410         }
5411         if (!sts) {
5412           PerlMem_free(esa);
5413           PerlMem_free(trndir);
5414           PerlMem_free(vmsdir);
5415           set_errno(EVMSERR);
5416           set_vaxc_errno(dirfab.fab$l_sts);
5417           return NULL;
5418         }
5419       }
5420       else {
5421         savnam = dirnam;
5422         /* Does the file really exist? */
5423         if (sys$search(&dirfab)& STS$K_SUCCESS) {
5424           /* Yes; fake the fnb bits so we'll check type below */
5425         rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5426         }
5427         else { /* No; just work with potential name */
5428           if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5429           else {
5430             int fab_sts;
5431             fab_sts = dirfab.fab$l_sts;
5432             sts = rms_free_search_context(&dirfab);
5433             PerlMem_free(esa);
5434             PerlMem_free(trndir);
5435             PerlMem_free(vmsdir);
5436             set_errno(EVMSERR);  set_vaxc_errno(fab_sts);
5437             return NULL;
5438           }
5439         }
5440       }
5441       esa[rms_nam_esll(dirnam)] = '\0';
5442       if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5443         cp1 = strchr(esa,']');
5444         if (!cp1) cp1 = strchr(esa,'>');
5445         if (cp1) {  /* Should always be true */
5446           rms_nam_esll(dirnam) -= cp1 - esa - 1;
5447           memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5448         }
5449       }
5450       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5451         /* Yep; check version while we're at it, if it's there. */
5452         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5453         if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5454           /* Something other than .DIR[;1].  Bzzt. */
5455           sts = rms_free_search_context(&dirfab);
5456           PerlMem_free(esa);
5457           PerlMem_free(trndir);
5458           PerlMem_free(vmsdir);
5459           set_errno(ENOTDIR);
5460           set_vaxc_errno(RMS$_DIR);
5461           return NULL;
5462         }
5463       }
5464
5465       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5466         /* They provided at least the name; we added the type, if necessary, */
5467         if (buf) retspec = buf;                            /* in sys$parse() */
5468         else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5469         else retspec = __fileify_retbuf;
5470         strcpy(retspec,esa);
5471         sts = rms_free_search_context(&dirfab);
5472         PerlMem_free(trndir);
5473         PerlMem_free(esa);
5474         PerlMem_free(vmsdir);
5475         return retspec;
5476       }
5477       if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5478         for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5479         *cp1 = '\0';
5480         rms_nam_esll(dirnam) -= 9;
5481       }
5482       if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5483       if (cp1 == NULL) { /* should never happen */
5484         sts = rms_free_search_context(&dirfab);
5485         PerlMem_free(trndir);
5486         PerlMem_free(esa);
5487         PerlMem_free(vmsdir);
5488         return NULL;
5489       }
5490       term = *cp1;
5491       *cp1 = '\0';
5492       retlen = strlen(esa);
5493       cp1 = strrchr(esa,'.');
5494       /* ODS-5 directory specifications can have extra "." in them. */
5495       /* Fix-me, can not scan EFS file specifications backwards */
5496       while (cp1 != NULL) {
5497         if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5498           break;
5499         else {
5500            cp1--;
5501            while ((cp1 > esa) && (*cp1 != '.'))
5502              cp1--;
5503         }
5504         if (cp1 == esa)
5505           cp1 = NULL;
5506       }
5507
5508       if ((cp1) != NULL) {
5509         /* There's more than one directory in the path.  Just roll back. */
5510         *cp1 = term;
5511         if (buf) retspec = buf;
5512         else if (ts) Newx(retspec,retlen+7,char);
5513         else retspec = __fileify_retbuf;
5514         strcpy(retspec,esa);
5515       }
5516       else {
5517         if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5518           /* Go back and expand rooted logical name */
5519           rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5520 #ifdef NAM$M_NO_SHORT_UPCASE
5521           if (decc_efs_case_preserve)
5522             rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5523 #endif
5524           if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5525             sts = rms_free_search_context(&dirfab);
5526             PerlMem_free(esa);
5527             PerlMem_free(trndir);
5528             PerlMem_free(vmsdir);
5529             set_errno(EVMSERR);
5530             set_vaxc_errno(dirfab.fab$l_sts);
5531             return NULL;
5532           }
5533           retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5534           if (buf) retspec = buf;
5535           else if (ts) Newx(retspec,retlen+16,char);
5536           else retspec = __fileify_retbuf;
5537           cp1 = strstr(esa,"][");
5538           if (!cp1) cp1 = strstr(esa,"]<");
5539           dirlen = cp1 - esa;
5540           memcpy(retspec,esa,dirlen);
5541           if (!strncmp(cp1+2,"000000]",7)) {
5542             retspec[dirlen-1] = '\0';
5543             /* fix-me Not full ODS-5, just extra dots in directories for now */
5544             cp1 = retspec + dirlen - 1;
5545             while (cp1 > retspec)
5546             {
5547               if (*cp1 == '[')
5548                 break;
5549               if (*cp1 == '.') {
5550                 if (*(cp1-1) != '^')
5551                   break;
5552               }
5553               cp1--;
5554             }
5555             if (*cp1 == '.') *cp1 = ']';
5556             else {
5557               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5558               memmove(cp1+1,"000000]",7);
5559             }
5560           }
5561           else {
5562             memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5563             retspec[retlen] = '\0';
5564             /* Convert last '.' to ']' */
5565             cp1 = retspec+retlen-1;
5566             while (*cp != '[') {
5567               cp1--;
5568               if (*cp1 == '.') {
5569                 /* Do not trip on extra dots in ODS-5 directories */
5570                 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5571                 break;
5572               }
5573             }
5574             if (*cp1 == '.') *cp1 = ']';
5575             else {
5576               memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5577               memmove(cp1+1,"000000]",7);
5578             }
5579           }
5580         }
5581         else {  /* This is a top-level dir.  Add the MFD to the path. */
5582           if (buf) retspec = buf;
5583           else if (ts) Newx(retspec,retlen+16,char);
5584           else retspec = __fileify_retbuf;
5585           cp1 = esa;
5586           cp2 = retspec;
5587           while ((*cp1 != ':')  && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5588           strcpy(cp2,":[000000]");
5589           cp1 += 2;
5590           strcpy(cp2+9,cp1);
5591         }
5592       }
5593       sts = rms_free_search_context(&dirfab);
5594       /* We've set up the string up through the filename.  Add the
5595          type and version, and we're done. */
5596       strcat(retspec,".DIR;1");
5597
5598       /* $PARSE may have upcased filespec, so convert output to lower
5599        * case if input contained any lowercase characters. */
5600       if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5601       PerlMem_free(trndir);
5602       PerlMem_free(esa);
5603       PerlMem_free(vmsdir);
5604       return retspec;
5605     }
5606 }  /* end of do_fileify_dirspec() */
5607 /*}}}*/
5608 /* External entry points */
5609 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5610 { return do_fileify_dirspec(dir,buf,0,NULL); }
5611 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5612 { return do_fileify_dirspec(dir,buf,1,NULL); }
5613 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5614 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5615 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5616 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5617
5618 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5619 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5620 {
5621     static char __pathify_retbuf[VMS_MAXRSS];
5622     unsigned long int retlen;
5623     char *retpath, *cp1, *cp2, *trndir;
5624     unsigned short int trnlnm_iter_count;
5625     STRLEN trnlen;
5626     int sts;
5627     if (utf8_fl != NULL)
5628         *utf8_fl = 0;
5629
5630     if (!dir || !*dir) {
5631       set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5632     }
5633
5634     trndir = PerlMem_malloc(VMS_MAXRSS);
5635     if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5636     if (*dir) strcpy(trndir,dir);
5637     else getcwd(trndir,VMS_MAXRSS - 1);
5638
5639     trnlnm_iter_count = 0;
5640     while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5641            && my_trnlnm(trndir,trndir,0)) {
5642       trnlnm_iter_count++;
5643       if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5644       trnlen = strlen(trndir);
5645
5646       /* Trap simple rooted lnms, and return lnm:[000000] */
5647       if (!strcmp(trndir+trnlen-2,".]")) {
5648         if (buf) retpath = buf;
5649         else if (ts) Newx(retpath,strlen(dir)+10,char);
5650         else retpath = __pathify_retbuf;
5651         strcpy(retpath,dir);
5652         strcat(retpath,":[000000]");
5653         PerlMem_free(trndir);
5654         return retpath;
5655       }
5656     }
5657
5658     /* At this point we do not work with *dir, but the copy in
5659      * *trndir that is modifiable.
5660      */
5661
5662     if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5663       if (*trndir == '.' && (*(trndir+1) == '\0' ||
5664                           (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5665         retlen = 2 + (*(trndir+1) != '\0');
5666       else {
5667         if ( !(cp1 = strrchr(trndir,'/')) &&
5668              !(cp1 = strrchr(trndir,']')) &&
5669              !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5670         if ((cp2 = strchr(cp1,'.')) != NULL &&
5671             (*(cp2-1) != '/' ||                /* Trailing '.', '..', */
5672              !(*(cp2+1) == '\0' ||             /* or '...' are dirs.  */
5673               (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5674               (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5675           int ver; char *cp3;
5676
5677           /* For EFS or ODS-5 look for the last dot */
5678           if (decc_efs_charset) {
5679             cp2 = strrchr(cp1,'.');
5680           }
5681           if (vms_process_case_tolerant) {
5682               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5683                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5684                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5685                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5686                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5687                             (ver || *cp3)))))) {
5688                 PerlMem_free(trndir);
5689                 set_errno(ENOTDIR);
5690                 set_vaxc_errno(RMS$_DIR);
5691                 return NULL;
5692               }
5693           }
5694           else {
5695               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5696                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5697                   !*(cp2+3) || *(cp2+3) != 'R' ||
5698                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5699                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5700                             (ver || *cp3)))))) {
5701                 PerlMem_free(trndir);
5702                 set_errno(ENOTDIR);
5703                 set_vaxc_errno(RMS$_DIR);
5704                 return NULL;
5705               }
5706           }
5707           retlen = cp2 - trndir + 1;
5708         }
5709         else {  /* No file type present.  Treat the filename as a directory. */
5710           retlen = strlen(trndir) + 1;
5711         }
5712       }
5713       if (buf) retpath = buf;
5714       else if (ts) Newx(retpath,retlen+1,char);
5715       else retpath = __pathify_retbuf;
5716       strncpy(retpath, trndir, retlen-1);
5717       if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5718         retpath[retlen-1] = '/';      /* with '/', add it. */
5719         retpath[retlen] = '\0';
5720       }
5721       else retpath[retlen-1] = '\0';
5722     }
5723     else {  /* VMS-style directory spec */
5724       char *esa, *cp;
5725       unsigned long int sts, cmplen, haslower;
5726       struct FAB dirfab = cc$rms_fab;
5727       int dirlen;
5728       rms_setup_nam(savnam);
5729       rms_setup_nam(dirnam);
5730
5731       /* If we've got an explicit filename, we can just shuffle the string. */
5732       if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5733              (cp1 = strrchr(trndir,'>')) != NULL     ) && *(cp1+1)) {
5734         if ((cp2 = strchr(cp1,'.')) != NULL) {
5735           int ver; char *cp3;
5736           if (vms_process_case_tolerant) {
5737               if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' ||  /* Wrong type. */
5738                   !*(cp2+2) || toupper(*(cp2+2)) != 'I' ||  /* Bzzt. */
5739                   !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5740                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5741                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5742                             (ver || *cp3)))))) {
5743                PerlMem_free(trndir);
5744                set_errno(ENOTDIR);
5745                set_vaxc_errno(RMS$_DIR);
5746                return NULL;
5747              }
5748           }
5749           else {
5750               if (!*(cp2+1) || *(cp2+1) != 'D' ||  /* Wrong type. */
5751                   !*(cp2+2) || *(cp2+2) != 'I' ||  /* Bzzt. */
5752                   !*(cp2+3) || *(cp2+3) != 'R' ||
5753                   (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.')  ||
5754                   (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5755                             (ver || *cp3)))))) {
5756                PerlMem_free(trndir);
5757                set_errno(ENOTDIR);
5758                set_vaxc_errno(RMS$_DIR);
5759                return NULL;
5760              }
5761           }
5762         }
5763         else {  /* No file type, so just draw name into directory part */
5764           for (cp2 = cp1; *cp2; cp2++) ;
5765         }
5766         *cp2 = *cp1;
5767         *(cp2+1) = '\0';  /* OK; trndir is guaranteed to be long enough */
5768         *cp1 = '.';
5769         /* We've now got a VMS 'path'; fall through */
5770       }
5771
5772       dirlen = strlen(trndir);
5773       if (trndir[dirlen-1] == ']' ||
5774           trndir[dirlen-1] == '>' ||
5775           trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5776         if (buf) retpath = buf;
5777         else if (ts) Newx(retpath,strlen(trndir)+1,char);
5778         else retpath = __pathify_retbuf;
5779         strcpy(retpath,trndir);
5780         PerlMem_free(trndir);
5781         return retpath;
5782       }
5783       rms_set_fna(dirfab, dirnam, trndir, dirlen);
5784       esa = PerlMem_malloc(VMS_MAXRSS);
5785       if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5786       rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5787       rms_bind_fab_nam(dirfab, dirnam);
5788       rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5789 #ifdef NAM$M_NO_SHORT_UPCASE
5790       if (decc_efs_case_preserve)
5791           rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5792 #endif
5793
5794       for (cp = trndir; *cp; cp++)
5795         if (islower(*cp)) { haslower = 1; break; }
5796
5797       if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5798         if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5799           rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5800           sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5801         }
5802         if (!sts) {
5803           PerlMem_free(trndir);
5804           PerlMem_free(esa);
5805           set_errno(EVMSERR);
5806           set_vaxc_errno(dirfab.fab$l_sts);
5807           return NULL;
5808         }
5809       }
5810       else {
5811         savnam = dirnam;
5812         /* Does the file really exist? */
5813         if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5814           if (dirfab.fab$l_sts != RMS$_FNF) {
5815             int sts1;
5816             sts1 = rms_free_search_context(&dirfab);
5817             PerlMem_free(trndir);
5818             PerlMem_free(esa);
5819             set_errno(EVMSERR);
5820             set_vaxc_errno(dirfab.fab$l_sts);
5821             return NULL;
5822           }
5823           dirnam = savnam; /* No; just work with potential name */
5824         }
5825       }
5826       if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) {  /* Was type specified? */
5827         /* Yep; check version while we're at it, if it's there. */
5828         cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5829         if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5830           int sts2;
5831           /* Something other than .DIR[;1].  Bzzt. */
5832           sts2 = rms_free_search_context(&dirfab);
5833           PerlMem_free(trndir);
5834           PerlMem_free(esa);
5835           set_errno(ENOTDIR);
5836           set_vaxc_errno(RMS$_DIR);
5837           return NULL;
5838         }
5839       }
5840       /* OK, the type was fine.  Now pull any file name into the
5841          directory path. */
5842       if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5843       else {
5844         cp1 = strrchr(esa,'>');
5845         *(rms_nam_typel(dirnam)) = '>';
5846       }
5847       *cp1 = '.';
5848       *(rms_nam_typel(dirnam) + 1) = '\0';
5849       retlen = (rms_nam_typel(dirnam)) - esa + 2;
5850       if (buf) retpath = buf;
5851       else if (ts) Newx(retpath,retlen,char);
5852       else retpath = __pathify_retbuf;
5853       strcpy(retpath,esa);
5854       PerlMem_free(esa);
5855       sts = rms_free_search_context(&dirfab);
5856       /* $PARSE may have upcased filespec, so convert output to lower
5857        * case if input contained any lowercase characters. */
5858       if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5859     }
5860
5861     PerlMem_free(trndir);
5862     return retpath;
5863 }  /* end of do_pathify_dirspec() */
5864 /*}}}*/
5865 /* External entry points */
5866 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5867 { return do_pathify_dirspec(dir,buf,0,NULL); }
5868 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5869 { return do_pathify_dirspec(dir,buf,1,NULL); }
5870 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5871 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5872 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5873 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5874
5875 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5876 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5877 {
5878   static char __tounixspec_retbuf[VMS_MAXRSS];
5879   char *dirend, *rslt, *cp1, *cp3, *tmp;
5880   const char *cp2;
5881   int devlen, dirlen, retlen = VMS_MAXRSS;
5882   int expand = 1; /* guarantee room for leading and trailing slashes */
5883   unsigned short int trnlnm_iter_count;
5884   int cmp_rslt;
5885   if (utf8_fl != NULL)
5886     *utf8_fl = 0;
5887
5888   if (spec == NULL) return NULL;
5889   if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5890   if (buf) rslt = buf;
5891   else if (ts) {
5892     Newx(rslt, VMS_MAXRSS, char);
5893   }
5894   else rslt = __tounixspec_retbuf;
5895
5896   /* New VMS specific format needs translation
5897    * glob passes filenames with trailing '\n' and expects this preserved.
5898    */
5899   if (decc_posix_compliant_pathnames) {
5900     if (strncmp(spec, "\"^UP^", 5) == 0) {
5901       char * uspec;
5902       char *tunix;
5903       int tunix_len;
5904       int nl_flag;
5905
5906       tunix = PerlMem_malloc(VMS_MAXRSS);
5907       if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5908       strcpy(tunix, spec);
5909       tunix_len = strlen(tunix);
5910       nl_flag = 0;
5911       if (tunix[tunix_len - 1] == '\n') {
5912         tunix[tunix_len - 1] = '\"';
5913         tunix[tunix_len] = '\0';
5914         tunix_len--;
5915         nl_flag = 1;
5916       }
5917       uspec = decc$translate_vms(tunix);
5918       PerlMem_free(tunix);
5919       if ((int)uspec > 0) {
5920         strcpy(rslt,uspec);
5921         if (nl_flag) {
5922           strcat(rslt,"\n");
5923         }
5924         else {
5925           /* If we can not translate it, makemaker wants as-is */
5926           strcpy(rslt, spec);
5927         }
5928         return rslt;
5929       }
5930     }
5931   }
5932
5933   cmp_rslt = 0; /* Presume VMS */
5934   cp1 = strchr(spec, '/');
5935   if (cp1 == NULL)
5936     cmp_rslt = 0;
5937
5938     /* Look for EFS ^/ */
5939     if (decc_efs_charset) {
5940       while (cp1 != NULL) {
5941         cp2 = cp1 - 1;
5942         if (*cp2 != '^') {
5943           /* Found illegal VMS, assume UNIX */
5944           cmp_rslt = 1;
5945           break;
5946         }
5947       cp1++;
5948       cp1 = strchr(cp1, '/');
5949     }
5950   }
5951
5952   /* Look for "." and ".." */
5953   if (decc_filename_unix_report) {
5954     if (spec[0] == '.') {
5955       if ((spec[1] == '\0') || (spec[1] == '\n')) {
5956         cmp_rslt = 1;
5957       }
5958       else {
5959         if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5960           cmp_rslt = 1;
5961         }
5962       }
5963     }
5964   }
5965   /* This is already UNIX or at least nothing VMS understands */
5966   if (cmp_rslt) {
5967     strcpy(rslt,spec);
5968     return rslt;
5969   }
5970
5971   cp1 = rslt;
5972   cp2 = spec;
5973   dirend = strrchr(spec,']');
5974   if (dirend == NULL) dirend = strrchr(spec,'>');
5975   if (dirend == NULL) dirend = strchr(spec,':');
5976   if (dirend == NULL) {
5977     strcpy(rslt,spec);
5978     return rslt;
5979   }
5980
5981   /* Special case 1 - sys$posix_root = / */
5982 #if __CRTL_VER >= 70000000
5983   if (!decc_disable_posix_root) {
5984     if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5985       *cp1 = '/';
5986       cp1++;
5987       cp2 = cp2 + 15;
5988       }
5989   }
5990 #endif
5991
5992   /* Special case 2 - Convert NLA0: to /dev/null */
5993 #if __CRTL_VER < 70000000
5994   cmp_rslt = strncmp(spec,"NLA0:", 5);
5995   if (cmp_rslt != 0)
5996      cmp_rslt = strncmp(spec,"nla0:", 5);
5997 #else
5998   cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5999 #endif
6000   if (cmp_rslt == 0) {
6001     strcpy(rslt, "/dev/null");
6002     cp1 = cp1 + 9;
6003     cp2 = cp2 + 5;
6004     if (spec[6] != '\0') {
6005       cp1[9] == '/';
6006       cp1++;
6007       cp2++;
6008     }
6009   }
6010
6011    /* Also handle special case "SYS$SCRATCH:" */
6012 #if __CRTL_VER < 70000000
6013   cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6014   if (cmp_rslt != 0)
6015      cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6016 #else
6017   cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6018 #endif
6019   tmp = PerlMem_malloc(VMS_MAXRSS);
6020   if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6021   if (cmp_rslt == 0) {
6022   int islnm;
6023
6024     islnm = my_trnlnm(tmp, "TMP", 0);
6025     if (!islnm) {
6026       strcpy(rslt, "/tmp");
6027       cp1 = cp1 + 4;
6028       cp2 = cp2 + 12;
6029       if (spec[12] != '\0') {
6030         cp1[4] == '/';
6031         cp1++;
6032         cp2++;
6033       }
6034     }
6035   }
6036
6037   if (*cp2 != '[' && *cp2 != '<') {
6038     *(cp1++) = '/';
6039   }
6040   else {  /* the VMS spec begins with directories */
6041     cp2++;
6042     if (*cp2 == ']' || *cp2 == '>') {
6043       *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6044       PerlMem_free(tmp);
6045       return rslt;
6046     }
6047     else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6048       if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6049         if (ts) Safefree(rslt);
6050         PerlMem_free(tmp);
6051         return NULL;
6052       }
6053       trnlnm_iter_count = 0;
6054       do {
6055         cp3 = tmp;
6056         while (*cp3 != ':' && *cp3) cp3++;
6057         *(cp3++) = '\0';
6058         if (strchr(cp3,']') != NULL) break;
6059         trnlnm_iter_count++;
6060         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6061       } while (vmstrnenv(tmp,tmp,0,fildev,0));
6062       if (ts && !buf &&
6063           ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6064         retlen = devlen + dirlen;
6065         Renew(rslt,retlen+1+2*expand,char);
6066         cp1 = rslt;
6067       }
6068       cp3 = tmp;
6069       *(cp1++) = '/';
6070       while (*cp3) {
6071         *(cp1++) = *(cp3++);
6072         if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6073             PerlMem_free(tmp);
6074             return NULL; /* No room */
6075         }
6076       }
6077       *(cp1++) = '/';
6078     }
6079     if ((*cp2 == '^')) {
6080         /* EFS file escape, pass the next character as is */
6081         /* Fix me: HEX encoding for UNICODE not implemented */
6082         cp2++;
6083     }
6084     else if ( *cp2 == '.') {
6085       if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6086         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6087         cp2 += 3;
6088       }
6089       else cp2++;
6090     }
6091   }
6092   PerlMem_free(tmp);
6093   for (; cp2 <= dirend; cp2++) {
6094     if ((*cp2 == '^')) {
6095         /* EFS file escape, pass the next character as is */
6096         /* Fix me: HEX encoding for UNICODE not implemented */
6097         *(cp1++) = *(++cp2);
6098         /* An escaped dot stays as is -- don't convert to slash */
6099         if (*cp2 == '.') cp2++;
6100     }
6101     if (*cp2 == ':') {
6102       *(cp1++) = '/';
6103       if (*(cp2+1) == '[') cp2++;
6104     }
6105     else if (*cp2 == ']' || *cp2 == '>') {
6106       if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6107     }
6108     else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6109       *(cp1++) = '/';
6110       if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6111         while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6112                *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6113         if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6114             *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6115       }
6116       else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6117         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6118         cp2 += 2;
6119       }
6120     }
6121     else if (*cp2 == '-') {
6122       if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6123         while (*cp2 == '-') {
6124           cp2++;
6125           *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6126         }
6127         if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6128           if (ts) Safefree(rslt);                        /* filespecs like */
6129           set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);   /* [fred.--foo.bar] */
6130           return NULL;
6131         }
6132       }
6133       else *(cp1++) = *cp2;
6134     }
6135     else *(cp1++) = *cp2;
6136   }
6137   while (*cp2) {
6138     if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++;  /* '^.' --> '.' */
6139     *(cp1++) = *(cp2++);
6140   }
6141   *cp1 = '\0';
6142
6143   /* This still leaves /000000/ when working with a
6144    * VMS device root or concealed root.
6145    */
6146   {
6147   int ulen;
6148   char * zeros;
6149
6150       ulen = strlen(rslt);
6151
6152       /* Get rid of "000000/ in rooted filespecs */
6153       if (ulen > 7) {
6154         zeros = strstr(rslt, "/000000/");
6155         if (zeros != NULL) {
6156           int mlen;
6157           mlen = ulen - (zeros - rslt) - 7;
6158           memmove(zeros, &zeros[7], mlen);
6159           ulen = ulen - 7;
6160           rslt[ulen] = '\0';
6161         }
6162       }
6163   }
6164
6165   return rslt;
6166
6167 }  /* end of do_tounixspec() */
6168 /*}}}*/
6169 /* External entry points */
6170 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6171   { return do_tounixspec(spec,buf,0, NULL); }
6172 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6173   { return do_tounixspec(spec,buf,1, NULL); }
6174 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6175   { return do_tounixspec(spec,buf,0, utf8_fl); }
6176 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6177   { return do_tounixspec(spec,buf,1, utf8_fl); }
6178
6179 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6180
6181 /*
6182  This procedure is used to identify if a path is based in either
6183  the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6184  it returns the OpenVMS format directory for it.
6185
6186  It is expecting specifications of only '/' or '/xxxx/'
6187
6188  If a posix root does not exist, or 'xxxx' is not a directory
6189  in the posix root, it returns a failure.
6190
6191  FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6192
6193  It is used only internally by posix_to_vmsspec_hardway().
6194  */
6195
6196 static int posix_root_to_vms
6197   (char *vmspath, int vmspath_len,
6198    const char *unixpath,
6199    const int * utf8_fl) {
6200 int sts;
6201 struct FAB myfab = cc$rms_fab;
6202 struct NAML mynam = cc$rms_naml;
6203 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6204  struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6205 char *esa;
6206 char *vms_delim;
6207 int dir_flag;
6208 int unixlen;
6209
6210     dir_flag = 0;
6211     unixlen = strlen(unixpath);
6212     if (unixlen == 0) {
6213       vmspath[0] = '\0';
6214       return RMS$_FNF;
6215     }
6216
6217 #if __CRTL_VER >= 80200000
6218   /* If not a posix spec already, convert it */
6219   if (decc_posix_compliant_pathnames) {
6220     if (strncmp(unixpath,"\"^UP^",5) != 0) {
6221       sprintf(vmspath,"\"^UP^%s\"",unixpath);
6222     }
6223     else {
6224       /* This is already a VMS specification, no conversion */
6225       unixlen--;
6226       strncpy(vmspath,unixpath, vmspath_len);
6227     }
6228   }
6229   else
6230 #endif
6231   {
6232   int path_len;
6233   int i,j;
6234
6235      /* Check to see if this is under the POSIX root */
6236      if (decc_disable_posix_root) {
6237         return RMS$_FNF;
6238      }
6239
6240      /* Skip leading / */
6241      if (unixpath[0] == '/') {
6242         unixpath++;
6243         unixlen--;
6244      }
6245
6246
6247      strcpy(vmspath,"SYS$POSIX_ROOT:");
6248
6249      /* If this is only the / , or blank, then... */
6250      if (unixpath[0] == '\0') {
6251         /* by definition, this is the answer */
6252         return SS$_NORMAL;
6253      }
6254
6255      /* Need to look up a directory */
6256      vmspath[15] = '[';
6257      vmspath[16] = '\0';
6258
6259      /* Copy and add '^' escape characters as needed */
6260      j = 16;
6261      i = 0;
6262      while (unixpath[i] != 0) {
6263      int k;
6264
6265         j += copy_expand_unix_filename_escape
6266             (&vmspath[j], &unixpath[i], &k, utf8_fl);
6267         i += k;
6268      }
6269
6270      path_len = strlen(vmspath);
6271      if (vmspath[path_len - 1] == '/')
6272         path_len--;
6273      vmspath[path_len] = ']';
6274      path_len++;
6275      vmspath[path_len] = '\0';
6276
6277   }
6278   vmspath[vmspath_len] = 0;
6279   if (unixpath[unixlen - 1] == '/')
6280   dir_flag = 1;
6281   esa = PerlMem_malloc(VMS_MAXRSS);
6282   if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6283   myfab.fab$l_fna = vmspath;
6284   myfab.fab$b_fns = strlen(vmspath);
6285   myfab.fab$l_naml = &mynam;
6286   mynam.naml$l_esa = NULL;
6287   mynam.naml$b_ess = 0;
6288   mynam.naml$l_long_expand = esa;
6289   mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6290   mynam.naml$l_rsa = NULL;
6291   mynam.naml$b_rss = 0;
6292   if (decc_efs_case_preserve)
6293     mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6294 #ifdef NAML$M_OPEN_SPECIAL
6295   mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6296 #endif
6297
6298   /* Set up the remaining naml fields */
6299   sts = sys$parse(&myfab);
6300
6301   /* It failed! Try again as a UNIX filespec */
6302   if (!(sts & 1)) {
6303     PerlMem_free(esa);
6304     return sts;
6305   }
6306
6307    /* get the Device ID and the FID */
6308    sts = sys$search(&myfab);
6309    /* on any failure, returned the POSIX ^UP^ filespec */
6310    if (!(sts & 1)) {
6311       PerlMem_free(esa);
6312       return sts;
6313    }
6314    specdsc.dsc$a_pointer = vmspath;
6315    specdsc.dsc$w_length = vmspath_len;
6316
6317    dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6318    dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6319    sts = lib$fid_to_name
6320       (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6321
6322   /* on any failure, returned the POSIX ^UP^ filespec */
6323   if (!(sts & 1)) {
6324      /* This can happen if user does not have permission to read directories */
6325      if (strncmp(unixpath,"\"^UP^",5) != 0)
6326        sprintf(vmspath,"\"^UP^%s\"",unixpath);
6327      else
6328        strcpy(vmspath, unixpath);
6329   }
6330   else {
6331     vmspath[specdsc.dsc$w_length] = 0;
6332
6333     /* Are we expecting a directory? */
6334     if (dir_flag != 0) {
6335     int i;
6336     char *eptr;
6337
6338       eptr = NULL;
6339
6340       i = specdsc.dsc$w_length - 1;
6341       while (i > 0) {
6342       int zercnt;
6343         zercnt = 0;
6344         /* Version must be '1' */
6345         if (vmspath[i--] != '1')
6346           break;
6347         /* Version delimiter is one of ".;" */
6348         if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6349           break;
6350         i--;
6351         if (vmspath[i--] != 'R')
6352           break;
6353         if (vmspath[i--] != 'I')
6354           break;
6355         if (vmspath[i--] != 'D')
6356           break;
6357         if (vmspath[i--] != '.')
6358           break;
6359         eptr = &vmspath[i+1];
6360         while (i > 0) {
6361           if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6362             if (vmspath[i-1] != '^') {
6363               if (zercnt != 6) {
6364                 *eptr = vmspath[i];
6365                 eptr[1] = '\0';
6366                 vmspath[i] = '.';
6367                 break;
6368               }
6369               else {
6370                 /* Get rid of 6 imaginary zero directory filename */
6371                 vmspath[i+1] = '\0';
6372               }
6373             }
6374           }
6375           if (vmspath[i] == '0')
6376             zercnt++;
6377           else
6378             zercnt = 10;
6379           i--;
6380         }
6381         break;
6382       }
6383     }
6384   }
6385   PerlMem_free(esa);
6386   return sts;
6387 }
6388
6389 /* /dev/mumble needs to be handled special.
6390    /dev/null becomes NLA0:, And there is the potential for other stuff
6391    like /dev/tty which may need to be mapped to something.
6392 */
6393
6394 static int
6395 slash_dev_special_to_vms
6396    (const char * unixptr,
6397     char * vmspath,
6398     int vmspath_len)
6399 {
6400 char * nextslash;
6401 int len;
6402 int cmp;
6403 int islnm;
6404
6405     unixptr += 4;
6406     nextslash = strchr(unixptr, '/');
6407     len = strlen(unixptr);
6408     if (nextslash != NULL)
6409         len = nextslash - unixptr;
6410     cmp = strncmp("null", unixptr, 5);
6411     if (cmp == 0) {
6412         if (vmspath_len >= 6) {
6413             strcpy(vmspath, "_NLA0:");
6414             return SS$_NORMAL;
6415         }
6416     }
6417 }
6418
6419
6420 /* The built in routines do not understand perl's special needs, so
6421     doing a manual conversion from UNIX to VMS
6422
6423     If the utf8_fl is not null and points to a non-zero value, then
6424     treat 8 bit characters as UTF-8.
6425
6426     The sequence starting with '$(' and ending with ')' will be passed
6427     through with out interpretation instead of being escaped.
6428
6429   */
6430 static int posix_to_vmsspec_hardway
6431   (char *vmspath, int vmspath_len,
6432    const char *unixpath,
6433    int dir_flag,
6434    int * utf8_fl) {
6435
6436 char *esa;
6437 const char *unixptr;
6438 const char *unixend;
6439 char *vmsptr;
6440 const char *lastslash;
6441 const char *lastdot;
6442 int unixlen;
6443 int vmslen;
6444 int dir_start;
6445 int dir_dot;
6446 int quoted;
6447 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6448 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6449
6450   if (utf8_fl != NULL)
6451     *utf8_fl = 0;
6452
6453   unixptr = unixpath;
6454   dir_dot = 0;
6455
6456   /* Ignore leading "/" characters */
6457   while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6458     unixptr++;
6459   }
6460   unixlen = strlen(unixptr);
6461
6462   /* Do nothing with blank paths */
6463   if (unixlen == 0) {
6464     vmspath[0] = '\0';
6465     return SS$_NORMAL;
6466   }
6467
6468   quoted = 0;
6469   /* This could have a "^UP^ on the front */
6470   if (strncmp(unixptr,"\"^UP^",5) == 0) {
6471     quoted = 1;
6472     unixptr+= 5;
6473     unixlen-= 5;
6474   }
6475
6476   lastslash = strrchr(unixptr,'/');
6477   lastdot = strrchr(unixptr,'.');
6478   unixend = strrchr(unixptr,'\"');
6479   if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6480     unixend = unixptr + unixlen;
6481   }
6482
6483   /* last dot is last dot or past end of string */
6484   if (lastdot == NULL)
6485     lastdot = unixptr + unixlen;
6486
6487   /* if no directories, set last slash to beginning of string */
6488   if (lastslash == NULL) {
6489     lastslash = unixptr;
6490   }
6491   else {
6492     /* Watch out for trailing "." after last slash, still a directory */
6493     if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6494       lastslash = unixptr + unixlen;
6495     }
6496
6497     /* Watch out for traiing ".." after last slash, still a directory */
6498     if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6499       lastslash = unixptr + unixlen;
6500     }
6501
6502     /* dots in directories are aways escaped */
6503     if (lastdot < lastslash)
6504       lastdot = unixptr + unixlen;
6505   }
6506
6507   /* if (unixptr < lastslash) then we are in a directory */
6508
6509   dir_start = 0;
6510
6511   vmsptr = vmspath;
6512   vmslen = 0;
6513
6514   /* Start with the UNIX path */
6515   if (*unixptr != '/') {
6516     /* relative paths */
6517
6518     /* If allowing logical names on relative pathnames, then handle here */
6519     if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6520         !decc_posix_compliant_pathnames) {
6521     char * nextslash;
6522     int seg_len;
6523     char * trn;
6524     int islnm;
6525
6526         /* Find the next slash */
6527         nextslash = strchr(unixptr,'/');
6528
6529         esa = PerlMem_malloc(vmspath_len);
6530         if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6531
6532         trn = PerlMem_malloc(VMS_MAXRSS);
6533         if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6534
6535         if (nextslash != NULL) {
6536
6537             seg_len = nextslash - unixptr;
6538             strncpy(esa, unixptr, seg_len);
6539             esa[seg_len] = 0;
6540         }
6541         else {
6542             strcpy(esa, unixptr);
6543             seg_len = strlen(unixptr);
6544         }
6545         /* trnlnm(section) */
6546         islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6547
6548         if (islnm) {
6549             /* Now fix up the directory */
6550
6551             /* Split up the path to find the components */
6552             sts = vms_split_path
6553                   (trn,
6554                    &v_spec,
6555                    &v_len,
6556                    &r_spec,
6557                    &r_len,
6558                    &d_spec,
6559                    &d_len,
6560                    &n_spec,
6561                    &n_len,
6562                    &e_spec,
6563                    &e_len,
6564                    &vs_spec,
6565                    &vs_len);
6566
6567             while (sts == 0) {
6568             char * strt;
6569             int cmp;
6570
6571                 /* A logical name must be a directory  or the full
6572                    specification.  It is only a full specification if
6573                    it is the only component */
6574                 if ((unixptr[seg_len] == '\0') ||
6575                     (unixptr[seg_len+1] == '\0')) {
6576
6577                     /* Is a directory being required? */
6578                     if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6579                         /* Not a logical name */
6580                         break;
6581                     }
6582
6583
6584                     if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6585                         /* This must be a directory */
6586                         if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6587                             strcpy(vmsptr, esa);
6588                             vmslen=strlen(vmsptr);
6589                             vmsptr[vmslen] = ':';
6590                             vmslen++;
6591                             vmsptr[vmslen] = '\0';
6592                             return SS$_NORMAL;
6593                         }
6594                     }
6595
6596                 }
6597
6598
6599                 /* must be dev/directory - ignore version */
6600                 if ((n_len + e_len) != 0)
6601                     break;
6602
6603                 /* transfer the volume */
6604                 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6605                     strncpy(vmsptr, v_spec, v_len);
6606                     vmsptr += v_len;
6607                     vmsptr[0] = '\0';
6608                     vmslen += v_len;
6609                 }
6610
6611                 /* unroot the rooted directory */
6612                 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6613                     r_spec[0] = '[';
6614                     r_spec[r_len - 1] = ']';
6615
6616                     /* This should not be there, but nothing is perfect */
6617                     if (r_len > 9) {
6618                         cmp = strcmp(&r_spec[1], "000000.");
6619                         if (cmp == 0) {
6620                             r_spec += 7;
6621                             r_spec[7] = '[';
6622                             r_len -= 7;
6623                             if (r_len == 2)
6624                                 r_len = 0;
6625                         }
6626                     }
6627                     if (r_len > 0) {
6628                         strncpy(vmsptr, r_spec, r_len);
6629                         vmsptr += r_len;
6630                         vmslen += r_len;
6631                         vmsptr[0] = '\0';
6632                     }
6633                 }
6634                 /* Bring over the directory. */
6635                 if ((d_len > 0) &&
6636                     ((d_len + vmslen) < vmspath_len)) {
6637                     d_spec[0] = '[';
6638                     d_spec[d_len - 1] = ']';
6639                     if (d_len > 9) {
6640                         cmp = strcmp(&d_spec[1], "000000.");
6641                         if (cmp == 0) {
6642                             d_spec += 7;
6643                             d_spec[7] = '[';
6644                             d_len -= 7;
6645                             if (d_len == 2)
6646                                 d_len = 0;
6647                         }
6648                     }
6649
6650                     if (r_len > 0) {
6651                         /* Remove the redundant root */
6652                         if (r_len > 0) {
6653                             /* remove the ][ */
6654                             vmsptr--;
6655                             vmslen--;
6656                             d_spec++;
6657                             d_len--;
6658                         }
6659                         strncpy(vmsptr, d_spec, d_len);
6660                             vmsptr += d_len;
6661                             vmslen += d_len;
6662                             vmsptr[0] = '\0';
6663                     }
6664                 }
6665                 break;
6666             }
6667         }
6668
6669         PerlMem_free(esa);
6670         PerlMem_free(trn);
6671     }
6672
6673     if (lastslash > unixptr) {
6674     int dotdir_seen;
6675
6676       /* skip leading ./ */
6677       dotdir_seen = 0;
6678       while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6679         dotdir_seen = 1;
6680         unixptr++;
6681         unixptr++;
6682       }
6683
6684       /* Are we still in a directory? */
6685       if (unixptr <= lastslash) {
6686         *vmsptr++ = '[';
6687         vmslen = 1;
6688         dir_start = 1;
6689
6690         /* if not backing up, then it is relative forward. */
6691         if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6692               ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6693           *vmsptr++ = '.';
6694           vmslen++;
6695           dir_dot = 1;
6696           }
6697        }
6698        else {
6699          if (dotdir_seen) {
6700            /* Perl wants an empty directory here to tell the difference
6701             * between a DCL commmand and a filename
6702             */
6703           *vmsptr++ = '[';
6704           *vmsptr++ = ']';
6705           vmslen = 2;
6706         }
6707       }
6708     }
6709     else {
6710       /* Handle two special files . and .. */
6711       if (unixptr[0] == '.') {
6712         if (&unixptr[1] == unixend) {
6713           *vmsptr++ = '[';
6714           *vmsptr++ = ']';
6715           vmslen += 2;
6716           *vmsptr++ = '\0';
6717           return SS$_NORMAL;
6718         }
6719         if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6720           *vmsptr++ = '[';
6721           *vmsptr++ = '-';
6722           *vmsptr++ = ']';
6723           vmslen += 3;
6724           *vmsptr++ = '\0';
6725           return SS$_NORMAL;
6726         }
6727       }
6728     }
6729   }
6730   else {        /* Absolute PATH handling */
6731   int sts;
6732   char * nextslash;
6733   int seg_len;
6734     /* Need to find out where root is */
6735
6736     /* In theory, this procedure should never get an absolute POSIX pathname
6737      * that can not be found on the POSIX root.
6738      * In practice, that can not be relied on, and things will show up
6739      * here that are a VMS device name or concealed logical name instead.
6740      * So to make things work, this procedure must be tolerant.
6741      */
6742     esa = PerlMem_malloc(vmspath_len);
6743     if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6744
6745     sts = SS$_NORMAL;
6746     nextslash = strchr(&unixptr[1],'/');
6747     seg_len = 0;
6748     if (nextslash != NULL) {
6749     int cmp;
6750       seg_len = nextslash - &unixptr[1];
6751       strncpy(vmspath, unixptr, seg_len + 1);
6752       vmspath[seg_len+1] = 0;
6753       cmp = 1;
6754       if (seg_len == 3) {
6755         cmp = strncmp(vmspath, "dev", 4);
6756         if (cmp == 0) {
6757             sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6758             if (sts = SS$_NORMAL)
6759                 return SS$_NORMAL;
6760         }
6761       }
6762       sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6763     }
6764
6765     if ($VMS_STATUS_SUCCESS(sts)) {
6766       /* This is verified to be a real path */
6767
6768       sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6769       if ($VMS_STATUS_SUCCESS(sts)) {
6770         strcpy(vmspath, esa);
6771         vmslen = strlen(vmspath);
6772         vmsptr = vmspath + vmslen;
6773         unixptr++;
6774         if (unixptr < lastslash) {
6775         char * rptr;
6776           vmsptr--;
6777           *vmsptr++ = '.';
6778           dir_start = 1;
6779           dir_dot = 1;
6780           if (vmslen > 7) {
6781           int cmp;
6782             rptr = vmsptr - 7;
6783             cmp = strcmp(rptr,"000000.");
6784             if (cmp == 0) {
6785               vmslen -= 7;
6786               vmsptr -= 7;
6787               vmsptr[1] = '\0';
6788             } /* removing 6 zeros */
6789           } /* vmslen < 7, no 6 zeros possible */
6790         } /* Not in a directory */
6791       } /* Posix root found */
6792       else {
6793         /* No posix root, fall back to default directory */
6794         strcpy(vmspath, "SYS$DISK:[");
6795         vmsptr = &vmspath[10];
6796         vmslen = 10;
6797         if (unixptr > lastslash) {
6798            *vmsptr = ']';
6799            vmsptr++;
6800            vmslen++;
6801         }
6802         else {
6803            dir_start = 1;
6804         }
6805       }
6806     } /* end of verified real path handling */
6807     else {
6808     int add_6zero;
6809     int islnm;
6810
6811       /* Ok, we have a device or a concealed root that is not in POSIX
6812        * or we have garbage.  Make the best of it.
6813        */
6814
6815       /* Posix to VMS destroyed this, so copy it again */
6816       strncpy(vmspath, &unixptr[1], seg_len);
6817       vmspath[seg_len] = 0;
6818       vmslen = seg_len;
6819       vmsptr = &vmsptr[vmslen];
6820       islnm = 0;
6821
6822       /* Now do we need to add the fake 6 zero directory to it? */
6823       add_6zero = 1;
6824       if ((*lastslash == '/') && (nextslash < lastslash)) {
6825         /* No there is another directory */
6826         add_6zero = 0;
6827       }
6828       else {
6829       int trnend;
6830       int cmp;
6831
6832         /* now we have foo:bar or foo:[000000]bar to decide from */
6833         islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6834
6835         if (!islnm && !decc_posix_compliant_pathnames) {
6836
6837             cmp = strncmp("bin", vmspath, 4);
6838             if (cmp == 0) {
6839                 /* bin => SYS$SYSTEM: */
6840                 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6841             }
6842             else {
6843                 /* tmp => SYS$SCRATCH: */
6844                 cmp = strncmp("tmp", vmspath, 4);
6845                 if (cmp == 0) {
6846                     islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6847                 }
6848             }
6849         }
6850
6851         trnend = islnm ? islnm - 1 : 0;
6852
6853         /* if this was a logical name, ']' or '>' must be present */
6854         /* if not a logical name, then assume a device and hope. */
6855         islnm =  trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6856
6857         /* if log name and trailing '.' then rooted - treat as device */
6858         add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6859
6860         /* Fix me, if not a logical name, a device lookup should be
6861          * done to see if the device is file structured.  If the device
6862          * is not file structured, the 6 zeros should not be put on.
6863          *
6864          * As it is, perl is occasionally looking for dev:[000000]tty.
6865          * which looks a little strange.
6866          *
6867          * Not that easy to detect as "/dev" may be file structured with
6868          * special device files.
6869          */
6870
6871         if ((add_6zero == 0) && (*nextslash == '/') &&
6872             (&nextslash[1] == unixend)) {
6873           /* No real directory present */
6874           add_6zero = 1;
6875         }
6876       }
6877
6878       /* Put the device delimiter on */
6879       *vmsptr++ = ':';
6880       vmslen++;
6881       unixptr = nextslash;
6882       unixptr++;
6883
6884       /* Start directory if needed */
6885       if (!islnm || add_6zero) {
6886         *vmsptr++ = '[';
6887         vmslen++;
6888         dir_start = 1;
6889       }
6890
6891       /* add fake 000000] if needed */
6892       if (add_6zero) {
6893         *vmsptr++ = '0';
6894         *vmsptr++ = '0';
6895         *vmsptr++ = '0';
6896         *vmsptr++ = '0';
6897         *vmsptr++ = '0';
6898         *vmsptr++ = '0';
6899         *vmsptr++ = ']';
6900         vmslen += 7;
6901         dir_start = 0;
6902       }
6903
6904     } /* non-POSIX translation */
6905     PerlMem_free(esa);
6906   } /* End of relative/absolute path handling */
6907
6908   while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6909   int dash_flag;
6910   int in_cnt;
6911   int out_cnt;
6912
6913     dash_flag = 0;
6914
6915     if (dir_start != 0) {
6916
6917       /* First characters in a directory are handled special */
6918       while ((*unixptr == '/') ||
6919              ((*unixptr == '.') &&
6920               ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6921                 (&unixptr[1]==unixend)))) {
6922       int loop_flag;
6923
6924         loop_flag = 0;
6925
6926         /* Skip redundant / in specification */
6927         while ((*unixptr == '/') && (dir_start != 0)) {
6928           loop_flag = 1;
6929           unixptr++;
6930           if (unixptr == lastslash)
6931             break;
6932         }
6933         if (unixptr == lastslash)
6934           break;
6935
6936         /* Skip redundant ./ characters */
6937         while ((*unixptr == '.') &&
6938                ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6939           loop_flag = 1;
6940           unixptr++;
6941           if (unixptr == lastslash)
6942             break;
6943           if (*unixptr == '/')
6944             unixptr++;
6945         }
6946         if (unixptr == lastslash)
6947           break;
6948
6949         /* Skip redundant ../ characters */
6950         while ((*unixptr == '.') && (unixptr[1] == '.') &&
6951              ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6952           /* Set the backing up flag */
6953           loop_flag = 1;
6954           dir_dot = 0;
6955           dash_flag = 1;
6956           *vmsptr++ = '-';
6957           vmslen++;
6958           unixptr++; /* first . */
6959           unixptr++; /* second . */
6960           if (unixptr == lastslash)
6961             break;
6962           if (*unixptr == '/') /* The slash */
6963             unixptr++;
6964         }
6965         if (unixptr == lastslash)
6966           break;
6967
6968         /* To do: Perl expects /.../ to be translated to [...] on VMS */
6969         /* Not needed when VMS is pretending to be UNIX. */
6970
6971         /* Is this loop stuck because of too many dots? */
6972         if (loop_flag == 0) {
6973           /* Exit the loop and pass the rest through */
6974           break;
6975         }
6976       }
6977
6978       /* Are we done with directories yet? */
6979       if (unixptr >= lastslash) {
6980
6981         /* Watch out for trailing dots */
6982         if (dir_dot != 0) {
6983             vmslen --;
6984             vmsptr--;
6985         }
6986         *vmsptr++ = ']';
6987         vmslen++;
6988         dash_flag = 0;
6989         dir_start = 0;
6990         if (*unixptr == '/')
6991           unixptr++;
6992       }
6993       else {
6994         /* Have we stopped backing up? */
6995         if (dash_flag) {
6996           *vmsptr++ = '.';
6997           vmslen++;
6998           dash_flag = 0;
6999           /* dir_start continues to be = 1 */
7000         }
7001         if (*unixptr == '-') {
7002           *vmsptr++ = '^';
7003           *vmsptr++ = *unixptr++;
7004           vmslen += 2;
7005           dir_start = 0;
7006
7007           /* Now are we done with directories yet? */
7008           if (unixptr >= lastslash) {
7009
7010             /* Watch out for trailing dots */
7011             if (dir_dot != 0) {
7012               vmslen --;
7013               vmsptr--;
7014             }
7015
7016             *vmsptr++ = ']';
7017             vmslen++;
7018             dash_flag = 0;
7019             dir_start = 0;
7020           }
7021         }
7022       }
7023     }
7024
7025     /* All done? */
7026     if (unixptr >= unixend)
7027       break;
7028
7029     /* Normal characters - More EFS work probably needed */
7030     dir_start = 0;
7031     dir_dot = 0;
7032
7033     switch(*unixptr) {
7034     case '/':
7035         /* remove multiple / */
7036         while (unixptr[1] == '/') {
7037            unixptr++;
7038         }
7039         if (unixptr == lastslash) {
7040           /* Watch out for trailing dots */
7041           if (dir_dot != 0) {
7042             vmslen --;
7043             vmsptr--;
7044           }
7045           *vmsptr++ = ']';
7046         }
7047         else {
7048           dir_start = 1;
7049           *vmsptr++ = '.';
7050           dir_dot = 1;
7051
7052           /* To do: Perl expects /.../ to be translated to [...] on VMS */
7053           /* Not needed when VMS is pretending to be UNIX. */
7054
7055         }
7056         dash_flag = 0;
7057         if (unixptr != unixend)
7058           unixptr++;
7059         vmslen++;
7060         break;
7061     case '.':
7062         if ((unixptr < lastdot) || (unixptr < lastslash) ||
7063             (&unixptr[1] == unixend)) {
7064           *vmsptr++ = '^';
7065           *vmsptr++ = '.';
7066           vmslen += 2;
7067           unixptr++;
7068
7069           /* trailing dot ==> '^..' on VMS */
7070           if (unixptr == unixend) {
7071             *vmsptr++ = '.';
7072             vmslen++;
7073             unixptr++;
7074           }
7075           break;
7076         }
7077
7078         *vmsptr++ = *unixptr++;
7079         vmslen ++;
7080         break;
7081     case '"':
7082         if (quoted && (&unixptr[1] == unixend)) {
7083             unixptr++;
7084             break;
7085         }
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     case '~':
7092     case ';':
7093     case '\\':
7094     case '?':
7095     case ' ':
7096     default:
7097         in_cnt = copy_expand_unix_filename_escape
7098                 (vmsptr, unixptr, &out_cnt, utf8_fl);
7099         vmsptr += out_cnt;
7100         unixptr += in_cnt;
7101         break;
7102     }
7103   }
7104
7105   /* Make sure directory is closed */
7106   if (unixptr == lastslash) {
7107     char *vmsptr2;
7108     vmsptr2 = vmsptr - 1;
7109
7110     if (*vmsptr2 != ']') {
7111       *vmsptr2--;
7112
7113       /* directories do not end in a dot bracket */
7114       if (*vmsptr2 == '.') {
7115         vmsptr2--;
7116
7117         /* ^. is allowed */
7118         if (*vmsptr2 != '^') {
7119           vmsptr--; /* back up over the dot */
7120         }
7121       }
7122       *vmsptr++ = ']';
7123     }
7124   }
7125   else {
7126     char *vmsptr2;
7127     /* Add a trailing dot if a file with no extension */
7128     vmsptr2 = vmsptr - 1;
7129     if ((vmslen > 1) &&
7130         (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7131         (*vmsptr2 != ')') && (*lastdot != '.')) {
7132         *vmsptr++ = '.';
7133         vmslen++;
7134     }
7135   }
7136
7137   *vmsptr = '\0';
7138   return SS$_NORMAL;
7139 }
7140 #endif
7141
7142  /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7143 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7144 {
7145 char * result;
7146 int utf8_flag;
7147
7148    /* If a UTF8 flag is being passed, honor it */
7149    utf8_flag = 0;
7150    if (utf8_fl != NULL) {
7151      utf8_flag = *utf8_fl;
7152     *utf8_fl = 0;
7153    }
7154
7155    if (utf8_flag) {
7156      /* If there is a possibility of UTF8, then if any UTF8 characters
7157         are present, then they must be converted to VTF-7
7158       */
7159      result = strcpy(rslt, path); /* FIX-ME */
7160    }
7161    else
7162      result = strcpy(rslt, path);
7163
7164    return result;
7165 }
7166
7167
7168 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7169 static char *mp_do_tovmsspec
7170    (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7171   static char __tovmsspec_retbuf[VMS_MAXRSS];
7172   char *rslt, *dirend;
7173   char *lastdot;
7174   char *vms_delim;
7175   register char *cp1;
7176   const char *cp2;
7177   unsigned long int infront = 0, hasdir = 1;
7178   int rslt_len;
7179   int no_type_seen;
7180   char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7181   int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7182
7183   if (path == NULL) return NULL;
7184   rslt_len = VMS_MAXRSS-1;
7185   if (buf) rslt = buf;
7186   else if (ts) Newx(rslt, VMS_MAXRSS, char);
7187   else rslt = __tovmsspec_retbuf;
7188
7189   /* '.' and '..' are "[]" and "[-]" for a quick check */
7190   if (path[0] == '.') {
7191     if (path[1] == '\0') {
7192       strcpy(rslt,"[]");
7193       if (utf8_flag != NULL)
7194         *utf8_flag = 0;
7195       return rslt;
7196     }
7197     else {
7198       if (path[1] == '.' && path[2] == '\0') {
7199         strcpy(rslt,"[-]");
7200         if (utf8_flag != NULL)
7201            *utf8_flag = 0;
7202         return rslt;
7203       }
7204     }
7205   }
7206
7207    /* Posix specifications are now a native VMS format */
7208   /*--------------------------------------------------*/
7209 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7210   if (decc_posix_compliant_pathnames) {
7211     if (strncmp(path,"\"^UP^",5) == 0) {
7212       posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7213       return rslt;
7214     }
7215   }
7216 #endif
7217
7218   /* This is really the only way to see if this is already in VMS format */
7219   sts = vms_split_path
7220        (path,
7221         &v_spec,
7222         &v_len,
7223         &r_spec,
7224         &r_len,
7225         &d_spec,
7226         &d_len,
7227         &n_spec,
7228         &n_len,
7229         &e_spec,
7230         &e_len,
7231         &vs_spec,
7232         &vs_len);
7233   if (sts == 0) {
7234     /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7235        replacement, because the above parse just took care of most of
7236        what is needed to do vmspath when the specification is already
7237        in VMS format.
7238
7239        And if it is not already, it is easier to do the conversion as
7240        part of this routine than to call this routine and then work on
7241        the result.
7242      */
7243
7244     /* If VMS punctuation was found, it is already VMS format */
7245     if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7246       if (utf8_flag != NULL)
7247         *utf8_flag = 0;
7248       strcpy(rslt, path);
7249       return rslt;
7250     }
7251     /* Now, what to do with trailing "." cases where there is no
7252        extension?  If this is a UNIX specification, and EFS characters
7253        are enabled, then the trailing "." should be converted to a "^.".
7254        But if this was already a VMS specification, then it should be
7255        left alone.
7256
7257        So in the case of ambiguity, leave the specification alone.
7258      */
7259
7260
7261     /* If there is a possibility of UTF8, then if any UTF8 characters
7262         are present, then they must be converted to VTF-7
7263      */
7264     if (utf8_flag != NULL)
7265       *utf8_flag = 0;
7266     strcpy(rslt, path);
7267     return rslt;
7268   }
7269
7270   dirend = strrchr(path,'/');
7271
7272   if (dirend == NULL) {
7273      /* If we get here with no UNIX directory delimiters, then this is
7274         not a complete file specification, either garbage a UNIX glob
7275         specification that can not be converted to a VMS wildcard, or
7276         it a UNIX shell macro.  MakeMaker wants these passed through AS-IS,
7277         so apparently other programs expect this also.
7278
7279         utf8 flag setting needs to be preserved.
7280       */
7281       strcpy(rslt, path);
7282       return rslt;
7283   }
7284
7285 /* If POSIX mode active, handle the conversion */
7286 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7287   if (decc_efs_charset) {
7288     posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7289     return rslt;
7290   }
7291 #endif
7292
7293   if (*(dirend+1) == '.') {  /* do we have trailing "/." or "/.." or "/..."? */
7294     if (!*(dirend+2)) dirend +=2;
7295     if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7296     if (decc_efs_charset == 0) {
7297       if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7298     }
7299   }
7300
7301   cp1 = rslt;
7302   cp2 = path;
7303   lastdot = strrchr(cp2,'.');
7304   if (*cp2 == '/') {
7305     char *trndev;
7306     int islnm, rooted;
7307     STRLEN trnend;
7308
7309     while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7310     if (!*(cp2+1)) {
7311       if (decc_disable_posix_root) {
7312         strcpy(rslt,"sys$disk:[000000]");
7313       }
7314       else {
7315         strcpy(rslt,"sys$posix_root:[000000]");
7316       }
7317       if (utf8_flag != NULL)
7318         *utf8_flag = 0;
7319       return rslt;
7320     }
7321     while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7322     *cp1 = '\0';
7323     trndev = PerlMem_malloc(VMS_MAXRSS);
7324     if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7325     islnm =  my_trnlnm(rslt,trndev,0);
7326
7327      /* DECC special handling */
7328     if (!islnm) {
7329       if (strcmp(rslt,"bin") == 0) {
7330         strcpy(rslt,"sys$system");
7331         cp1 = rslt + 10;
7332         *cp1 = 0;
7333         islnm =  my_trnlnm(rslt,trndev,0);
7334       }
7335       else if (strcmp(rslt,"tmp") == 0) {
7336         strcpy(rslt,"sys$scratch");
7337         cp1 = rslt + 11;
7338         *cp1 = 0;
7339         islnm =  my_trnlnm(rslt,trndev,0);
7340       }
7341       else if (!decc_disable_posix_root) {
7342         strcpy(rslt, "sys$posix_root");
7343         cp1 = rslt + 13;
7344         *cp1 = 0;
7345         cp2 = path;
7346         while (*(cp2+1) == '/') cp2++;  /* Skip multiple /s */
7347         islnm =  my_trnlnm(rslt,trndev,0);
7348       }
7349       else if (strcmp(rslt,"dev") == 0) {
7350         if (strncmp(cp2,"/null", 5) == 0) {
7351           if ((cp2[5] == 0) || (cp2[5] == '/')) {
7352             strcpy(rslt,"NLA0");
7353             cp1 = rslt + 4;
7354             *cp1 = 0;
7355             cp2 = cp2 + 5;
7356             islnm =  my_trnlnm(rslt,trndev,0);
7357           }
7358         }
7359       }
7360     }
7361
7362     trnend = islnm ? strlen(trndev) - 1 : 0;
7363     islnm =  trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7364     rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7365     /* If the first element of the path is a logical name, determine
7366      * whether it has to be translated so we can add more directories. */
7367     if (!islnm || rooted) {
7368       *(cp1++) = ':';
7369       *(cp1++) = '[';
7370       if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7371       else cp2++;
7372     }
7373     else {
7374       if (cp2 != dirend) {
7375         strcpy(rslt,trndev);
7376         cp1 = rslt + trnend;
7377         if (*cp2 != 0) {
7378           *(cp1++) = '.';
7379           cp2++;
7380         }
7381       }
7382       else {
7383         if (decc_disable_posix_root) {
7384           *(cp1++) = ':';
7385           hasdir = 0;
7386         }
7387       }
7388     }
7389     PerlMem_free(trndev);
7390   }
7391   else {
7392     *(cp1++) = '[';
7393     if (*cp2 == '.') {
7394       if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7395         cp2 += 2;         /* skip over "./" - it's redundant */
7396         *(cp1++) = '.';   /* but it does indicate a relative dirspec */
7397       }
7398       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7399         *(cp1++) = '-';                                 /* "../" --> "-" */
7400         cp2 += 3;
7401       }
7402       else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7403                (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7404         *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7405         if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7406         cp2 += 4;
7407       }
7408       else if ((cp2 != lastdot) || (lastdot < dirend)) {
7409         /* Escape the extra dots in EFS file specifications */
7410         *(cp1++) = '^';
7411       }
7412       if (cp2 > dirend) cp2 = dirend;
7413     }
7414     else *(cp1++) = '.';
7415   }
7416   for (; cp2 < dirend; cp2++) {
7417     if (*cp2 == '/') {
7418       if (*(cp2-1) == '/') continue;
7419       if (*(cp1-1) != '.') *(cp1++) = '.';
7420       infront = 0;
7421     }
7422     else if (!infront && *cp2 == '.') {
7423       if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7424       else if (*(cp2+1) == '/') cp2++;   /* skip over "./" - it's redundant */
7425       else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7426         if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7427         else if (*(cp1-2) == '[') *(cp1-1) = '-';
7428         else {  /* back up over previous directory name */
7429           cp1--;
7430           while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7431           if (*(cp1-1) == '[') {
7432             memcpy(cp1,"000000.",7);
7433             cp1 += 7;
7434           }
7435         }
7436         cp2 += 2;
7437         if (cp2 == dirend) break;
7438       }
7439       else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7440                 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7441         if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7442         *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7443         if (!*(cp2+3)) {
7444           *(cp1++) = '.';  /* Simulate trailing '/' */
7445           cp2 += 2;  /* for loop will incr this to == dirend */
7446         }
7447         else cp2 += 3;  /* Trailing '/' was there, so skip it, too */
7448       }
7449       else {
7450         if (decc_efs_charset == 0)
7451           *(cp1++) = '_';  /* fix up syntax - '.' in name not allowed */
7452         else {
7453           *(cp1++) = '^';  /* fix up syntax - '.' in name is allowed */
7454           *(cp1++) = '.';
7455         }
7456       }
7457     }
7458     else {
7459       if (!infront && *(cp1-1) == '-')  *(cp1++) = '.';
7460       if (*cp2 == '.') {
7461         if (decc_efs_charset == 0)
7462           *(cp1++) = '_';
7463         else {
7464           *(cp1++) = '^';
7465           *(cp1++) = '.';
7466         }
7467       }
7468       else                  *(cp1++) =  *cp2;
7469       infront = 1;
7470     }
7471   }
7472   if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7473   if (hasdir) *(cp1++) = ']';
7474   if (*cp2) cp2++;  /* check in case we ended with trailing '..' */
7475   /* fixme for ODS5 */
7476   no_type_seen = 0;
7477   if (cp2 > lastdot)
7478     no_type_seen = 1;
7479   while (*cp2) {
7480     switch(*cp2) {
7481     case '?':
7482         if (decc_efs_charset == 0)
7483           *(cp1++) = '%';
7484         else
7485           *(cp1++) = '?';
7486         cp2++;
7487     case ' ':
7488         *(cp1)++ = '^';
7489         *(cp1)++ = '_';
7490         cp2++;
7491         break;
7492     case '.':
7493         if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7494             decc_readdir_dropdotnotype) {
7495           *(cp1)++ = '^';
7496           *(cp1)++ = '.';
7497           cp2++;
7498
7499           /* trailing dot ==> '^..' on VMS */
7500           if (*cp2 == '\0') {
7501             *(cp1++) = '.';
7502             no_type_seen = 0;
7503           }
7504         }
7505         else {
7506           *(cp1++) = *(cp2++);
7507           no_type_seen = 0;
7508         }
7509         break;
7510     case '$':
7511          /* This could be a macro to be passed through */
7512         *(cp1++) = *(cp2++);
7513         if (*cp2 == '(') {
7514         const char * save_cp2;
7515         char * save_cp1;
7516         int is_macro;
7517
7518             /* paranoid check */
7519             save_cp2 = cp2;
7520             save_cp1 = cp1;
7521             is_macro = 0;
7522
7523             /* Test through */
7524             *(cp1++) = *(cp2++);
7525             if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7526                 *(cp1++) = *(cp2++);
7527                 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7528                     *(cp1++) = *(cp2++);
7529                 }
7530                 if (*cp2 == ')') {
7531                     *(cp1++) = *(cp2++);
7532                     is_macro = 1;
7533                 }
7534             }
7535             if (is_macro == 0) {
7536                 /* Not really a macro - never mind */
7537                 cp2 = save_cp2;
7538                 cp1 = save_cp1;
7539             }
7540         }
7541         break;
7542     case '\"':
7543     case '~':
7544     case '`':
7545     case '!':
7546     case '#':
7547     case '%':
7548     case '^':
7549     case '&':
7550     case '(':
7551     case ')':
7552     case '=':
7553     case '+':
7554     case '\'':
7555     case '@':
7556     case '[':
7557     case ']':
7558     case '{':
7559     case '}':
7560     case ':':
7561     case '\\':
7562     case '|':
7563     case '<':
7564     case '>':
7565         *(cp1++) = '^';
7566         *(cp1++) = *(cp2++);
7567         break;
7568     case ';':
7569         /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7570          * which is wrong.  UNIX notation should be ".dir." unless
7571          * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7572          * changing this behavior could break more things at this time.
7573          * efs character set effectively does not allow "." to be a version
7574          * delimiter as a further complication about changing this.
7575          */
7576         if (decc_filename_unix_report != 0) {
7577           *(cp1++) = '^';
7578         }
7579         *(cp1++) = *(cp2++);
7580         break;
7581     default:
7582         *(cp1++) = *(cp2++);
7583     }
7584   }
7585   if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7586   char *lcp1;
7587     lcp1 = cp1;
7588     lcp1--;
7589      /* Fix me for "^]", but that requires making sure that you do
7590       * not back up past the start of the filename
7591       */
7592     if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7593       *cp1++ = '.';
7594   }
7595   *cp1 = '\0';
7596
7597   if (utf8_flag != NULL)
7598     *utf8_flag = 0;
7599   return rslt;
7600
7601 }  /* end of do_tovmsspec() */
7602 /*}}}*/
7603 /* External entry points */
7604 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7605   { return do_tovmsspec(path,buf,0,NULL); }
7606 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7607   { return do_tovmsspec(path,buf,1,NULL); }
7608 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7609   { return do_tovmsspec(path,buf,0,utf8_fl); }
7610 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7611   { return do_tovmsspec(path,buf,1,utf8_fl); }
7612
7613 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7614 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7615   static char __tovmspath_retbuf[VMS_MAXRSS];
7616   int vmslen;
7617   char *pathified, *vmsified, *cp;
7618
7619   if (path == NULL) return NULL;
7620   pathified = PerlMem_malloc(VMS_MAXRSS);
7621   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7622   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7623     PerlMem_free(pathified);
7624     return NULL;
7625   }
7626
7627   vmsified = NULL;
7628   if (buf == NULL)
7629      Newx(vmsified, VMS_MAXRSS, char);
7630   if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7631     PerlMem_free(pathified);
7632     if (vmsified) Safefree(vmsified);
7633     return NULL;
7634   }
7635   PerlMem_free(pathified);
7636   if (buf) {
7637     return buf;
7638   }
7639   else if (ts) {
7640     vmslen = strlen(vmsified);
7641     Newx(cp,vmslen+1,char);
7642     memcpy(cp,vmsified,vmslen);
7643     cp[vmslen] = '\0';
7644     Safefree(vmsified);
7645     return cp;
7646   }
7647   else {
7648     strcpy(__tovmspath_retbuf,vmsified);
7649     Safefree(vmsified);
7650     return __tovmspath_retbuf;
7651   }
7652
7653 }  /* end of do_tovmspath() */
7654 /*}}}*/
7655 /* External entry points */
7656 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7657   { return do_tovmspath(path,buf,0, NULL); }
7658 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7659   { return do_tovmspath(path,buf,1, NULL); }
7660 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7661   { return do_tovmspath(path,buf,0,utf8_fl); }
7662 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7663   { return do_tovmspath(path,buf,1,utf8_fl); }
7664
7665
7666 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7667 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7668   static char __tounixpath_retbuf[VMS_MAXRSS];
7669   int unixlen;
7670   char *pathified, *unixified, *cp;
7671
7672   if (path == NULL) return NULL;
7673   pathified = PerlMem_malloc(VMS_MAXRSS);
7674   if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7675   if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7676     PerlMem_free(pathified);
7677     return NULL;
7678   }
7679
7680   unixified = NULL;
7681   if (buf == NULL) {
7682       Newx(unixified, VMS_MAXRSS, char);
7683   }
7684   if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7685     PerlMem_free(pathified);
7686     if (unixified) Safefree(unixified);
7687     return NULL;
7688   }
7689   PerlMem_free(pathified);
7690   if (buf) {
7691     return buf;
7692   }
7693   else if (ts) {
7694     unixlen = strlen(unixified);
7695     Newx(cp,unixlen+1,char);
7696     memcpy(cp,unixified,unixlen);
7697     cp[unixlen] = '\0';
7698     Safefree(unixified);
7699     return cp;
7700   }
7701   else {
7702     strcpy(__tounixpath_retbuf,unixified);
7703     Safefree(unixified);
7704     return __tounixpath_retbuf;
7705   }
7706
7707 }  /* end of do_tounixpath() */
7708 /*}}}*/
7709 /* External entry points */
7710 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7711   { return do_tounixpath(path,buf,0,NULL); }
7712 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7713   { return do_tounixpath(path,buf,1,NULL); }
7714 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7715   { return do_tounixpath(path,buf,0,utf8_fl); }
7716 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7717   { return do_tounixpath(path,buf,1,utf8_fl); }
7718
7719 /*
7720  * @(#)argproc.c 2.2 94/08/16   Mark Pizzolato (mark@infocomm.com)
7721  *
7722  *****************************************************************************
7723  *                                                                           *
7724  *  Copyright (C) 1989-1994 by                                               *
7725  *  Mark Pizzolato - INFO COMM, Danville, California  (510) 837-5600         *
7726  *                                                                           *
7727  *  Permission is hereby  granted for the reproduction of this software,     *
7728  *  on condition that this copyright notice is included in the reproduction, *
7729  *  and that such reproduction is not for purposes of profit or material     *
7730  *  gain.                                                                    *
7731  *                                                                           *
7732  *  27-Aug-1994 Modified for inclusion in perl5                              *
7733  *              by Charles Bailey  bailey@newman.upenn.edu                   *
7734  *****************************************************************************
7735  */
7736
7737 /*
7738  * getredirection() is intended to aid in porting C programs
7739  * to VMS (Vax-11 C).  The native VMS environment does not support
7740  * '>' and '<' I/O redirection, or command line wild card expansion,
7741  * or a command line pipe mechanism using the '|' AND background
7742  * command execution '&'.  All of these capabilities are provided to any
7743  * C program which calls this procedure as the first thing in the
7744  * main program.
7745  * The piping mechanism will probably work with almost any 'filter' type
7746  * of program.  With suitable modification, it may useful for other
7747  * portability problems as well.
7748  *
7749  * Author:  Mark Pizzolato      mark@infocomm.com
7750  */
7751 struct list_item
7752     {
7753     struct list_item *next;
7754     char *value;
7755     };
7756
7757 static void add_item(struct list_item **head,
7758                      struct list_item **tail,
7759                      char *value,
7760                      int *count);
7761
7762 static void mp_expand_wild_cards(pTHX_ char *item,
7763                                 struct list_item **head,
7764                                 struct list_item **tail,
7765                                 int *count);
7766
7767 static int background_process(pTHX_ int argc, char **argv);
7768
7769 static void pipe_and_fork(pTHX_ char **cmargv);
7770
7771 /*{{{ void getredirection(int *ac, char ***av)*/
7772 static void
7773 mp_getredirection(pTHX_ int *ac, char ***av)
7774 /*
7775  * Process vms redirection arg's.  Exit if any error is seen.
7776  * If getredirection() processes an argument, it is erased
7777  * from the vector.  getredirection() returns a new argc and argv value.
7778  * In the event that a background command is requested (by a trailing "&"),
7779  * this routine creates a background subprocess, and simply exits the program.
7780  *
7781  * Warning: do not try to simplify the code for vms.  The code
7782  * presupposes that getredirection() is called before any data is
7783  * read from stdin or written to stdout.
7784  *
7785  * Normal usage is as follows:
7786  *
7787  *      main(argc, argv)
7788  *      int             argc;
7789  *      char            *argv[];
7790  *      {
7791  *              getredirection(&argc, &argv);
7792  *      }
7793  */
7794 {
7795     int                 argc = *ac;     /* Argument Count         */
7796     char                **argv = *av;   /* Argument Vector        */
7797     char                *ap;            /* Argument pointer       */
7798     int                 j;              /* argv[] index           */
7799     int                 item_count = 0; /* Count of Items in List */
7800     struct list_item    *list_head = 0; /* First Item in List       */
7801     struct list_item    *list_tail;     /* Last Item in List        */
7802     char                *in = NULL;     /* Input File Name          */
7803     char                *out = NULL;    /* Output File Name         */
7804     char                *outmode = "w"; /* Mode to Open Output File */
7805     char                *err = NULL;    /* Error File Name          */
7806     char                *errmode = "w"; /* Mode to Open Error File  */
7807     int                 cmargc = 0;     /* Piped Command Arg Count  */
7808     char                **cmargv = NULL;/* Piped Command Arg Vector */
7809
7810     /*
7811      * First handle the case where the last thing on the line ends with
7812      * a '&'.  This indicates the desire for the command to be run in a
7813      * subprocess, so we satisfy that desire.
7814      */
7815     ap = argv[argc-1];
7816     if (0 == strcmp("&", ap))
7817        exit(background_process(aTHX_ --argc, argv));
7818     if (*ap && '&' == ap[strlen(ap)-1])
7819         {
7820         ap[strlen(ap)-1] = '\0';
7821        exit(background_process(aTHX_ argc, argv));
7822         }
7823     /*
7824      * Now we handle the general redirection cases that involve '>', '>>',
7825      * '<', and pipes '|'.
7826      */
7827     for (j = 0; j < argc; ++j)
7828         {
7829         if (0 == strcmp("<", argv[j]))
7830             {
7831             if (j+1 >= argc)
7832                 {
7833                 fprintf(stderr,"No input file after < on command line");
7834                 exit(LIB$_WRONUMARG);
7835                 }
7836             in = argv[++j];
7837             continue;
7838             }
7839         if ('<' == *(ap = argv[j]))
7840             {
7841             in = 1 + ap;
7842             continue;
7843             }
7844         if (0 == strcmp(">", ap))
7845             {
7846             if (j+1 >= argc)
7847                 {
7848                 fprintf(stderr,"No output file after > on command line");
7849                 exit(LIB$_WRONUMARG);
7850                 }
7851             out = argv[++j];
7852             continue;
7853             }
7854         if ('>' == *ap)
7855             {
7856             if ('>' == ap[1])
7857                 {
7858                 outmode = "a";
7859                 if ('\0' == ap[2])
7860                     out = argv[++j];
7861                 else
7862                     out = 2 + ap;
7863                 }
7864             else
7865                 out = 1 + ap;
7866             if (j >= argc)
7867                 {
7868                 fprintf(stderr,"No output file after > or >> on command line");
7869                 exit(LIB$_WRONUMARG);
7870                 }
7871             continue;
7872             }
7873         if (('2' == *ap) && ('>' == ap[1]))
7874             {
7875             if ('>' == ap[2])
7876                 {
7877                 errmode = "a";
7878                 if ('\0' == ap[3])
7879                     err = argv[++j];
7880                 else
7881                     err = 3 + ap;
7882                 }
7883             else
7884                 if ('\0' == ap[2])
7885                     err = argv[++j];
7886                 else
7887                     err = 2 + ap;
7888             if (j >= argc)
7889                 {
7890                 fprintf(stderr,"No output file after 2> or 2>> on command line");
7891                 exit(LIB$_WRONUMARG);
7892                 }
7893             continue;
7894             }
7895         if (0 == strcmp("|", argv[j]))
7896             {
7897             if (j+1 >= argc)
7898                 {
7899                 fprintf(stderr,"No command into which to pipe on command line");
7900                 exit(LIB$_WRONUMARG);
7901                 }
7902             cmargc = argc-(j+1);
7903             cmargv = &argv[j+1];
7904             argc = j;
7905             continue;
7906             }
7907         if ('|' == *(ap = argv[j]))
7908             {
7909             ++argv[j];
7910             cmargc = argc-j;
7911             cmargv = &argv[j];
7912             argc = j;
7913             continue;
7914             }
7915         expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7916         }
7917     /*
7918      * Allocate and fill in the new argument vector, Some Unix's terminate
7919      * the list with an extra null pointer.
7920      */
7921     argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7922     if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7923     *av = argv;
7924     for (j = 0; j < item_count; ++j, list_head = list_head->next)
7925         argv[j] = list_head->value;
7926     *ac = item_count;
7927     if (cmargv != NULL)
7928         {
7929         if (out != NULL)
7930             {
7931             fprintf(stderr,"'|' and '>' may not both be specified on command line");
7932             exit(LIB$_INVARGORD);
7933             }
7934         pipe_and_fork(aTHX_ cmargv);
7935         }
7936
7937     /* Check for input from a pipe (mailbox) */
7938
7939     if (in == NULL && 1 == isapipe(0))
7940         {
7941         char mbxname[L_tmpnam];
7942         long int bufsize;
7943         long int dvi_item = DVI$_DEVBUFSIZ;
7944         $DESCRIPTOR(mbxnam, "");
7945         $DESCRIPTOR(mbxdevnam, "");
7946
7947         /* Input from a pipe, reopen it in binary mode to disable       */
7948         /* carriage control processing.                                 */
7949
7950         fgetname(stdin, mbxname);
7951         mbxnam.dsc$a_pointer = mbxname;
7952         mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7953         lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7954         mbxdevnam.dsc$a_pointer = mbxname;
7955         mbxdevnam.dsc$w_length = sizeof(mbxname);
7956         dvi_item = DVI$_DEVNAM;
7957         lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7958         mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7959         set_errno(0);
7960         set_vaxc_errno(1);
7961         freopen(mbxname, "rb", stdin);
7962         if (errno != 0)
7963             {
7964             fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7965             exit(vaxc$errno);
7966             }
7967         }
7968     if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7969         {
7970         fprintf(stderr,"Can't open input file %s as stdin",in);
7971         exit(vaxc$errno);
7972         }
7973     if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7974         {
7975         fprintf(stderr,"Can't open output file %s as stdout",out);
7976         exit(vaxc$errno);
7977         }
7978         if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7979
7980     if (err != NULL) {
7981         if (strcmp(err,"&1") == 0) {
7982             dup2(fileno(stdout), fileno(stderr));
7983             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7984         } else {
7985         FILE *tmperr;
7986         if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7987             {
7988             fprintf(stderr,"Can't open error file %s as stderr",err);
7989             exit(vaxc$errno);
7990             }
7991             fclose(tmperr);
7992            if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7993                 {
7994                 exit(vaxc$errno);
7995                 }
7996             Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7997         }
7998         }
7999 #ifdef ARGPROC_DEBUG
8000     PerlIO_printf(Perl_debug_log, "Arglist:\n");
8001     for (j = 0; j < *ac;  ++j)
8002         PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8003 #endif
8004    /* Clear errors we may have hit expanding wildcards, so they don't
8005       show up in Perl's $! later */
8006    set_errno(0); set_vaxc_errno(1);
8007 }  /* end of getredirection() */
8008 /*}}}*/
8009
8010 static void add_item(struct list_item **head,
8011                      struct list_item **tail,
8012                      char *value,
8013                      int *count)
8014 {
8015     if (*head == 0)
8016         {
8017         *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8018         if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8019         *tail = *head;
8020         }
8021     else {
8022         (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8023         if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8024         *tail = (*tail)->next;
8025         }
8026     (*tail)->value = value;
8027     ++(*count);
8028 }
8029
8030 static void mp_expand_wild_cards(pTHX_ char *item,
8031                               struct list_item **head,
8032                               struct list_item **tail,
8033                               int *count)
8034 {
8035 int expcount = 0;
8036 unsigned long int context = 0;
8037 int isunix = 0;
8038 int item_len = 0;
8039 char *had_version;
8040 char *had_device;
8041 int had_directory;
8042 char *devdir,*cp;
8043 char *vmsspec;
8044 $DESCRIPTOR(filespec, "");
8045 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8046 $DESCRIPTOR(resultspec, "");
8047 unsigned long int lff_flags = 0;
8048 int sts;
8049 int rms_sts;
8050
8051 #ifdef VMS_LONGNAME_SUPPORT
8052     lff_flags = LIB$M_FIL_LONG_NAMES;
8053 #endif
8054
8055     for (cp = item; *cp; cp++) {
8056         if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8057         if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8058     }
8059     if (!*cp || isspace(*cp))
8060         {
8061         add_item(head, tail, item, count);
8062         return;
8063         }
8064     else
8065         {
8066      /* "double quoted" wild card expressions pass as is */
8067      /* From DCL that means using e.g.:                  */
8068      /* perl program """perl.*"""                        */
8069      item_len = strlen(item);
8070      if ( '"' == *item && '"' == item[item_len-1] )
8071        {
8072        item++;
8073        item[item_len-2] = '\0';
8074        add_item(head, tail, item, count);
8075        return;
8076        }
8077      }
8078     resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8079     resultspec.dsc$b_class = DSC$K_CLASS_D;
8080     resultspec.dsc$a_pointer = NULL;
8081     vmsspec = PerlMem_malloc(VMS_MAXRSS);
8082     if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8083     if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8084       filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8085     if (!isunix || !filespec.dsc$a_pointer)
8086       filespec.dsc$a_pointer = item;
8087     filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8088     /*
8089      * Only return version specs, if the caller specified a version
8090      */
8091     had_version = strchr(item, ';');
8092     /*
8093      * Only return device and directory specs, if the caller specifed either.
8094      */
8095     had_device = strchr(item, ':');
8096     had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8097
8098     while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8099                                  (&filespec, &resultspec, &context,
8100                                   &defaultspec, 0, &rms_sts, &lff_flags)))
8101         {
8102         char *string;
8103         char *c;
8104
8105         string = PerlMem_malloc(resultspec.dsc$w_length+1);
8106         if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8107         strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8108         string[resultspec.dsc$w_length] = '\0';
8109         if (NULL == had_version)
8110             *(strrchr(string, ';')) = '\0';
8111         if ((!had_directory) && (had_device == NULL))
8112             {
8113             if (NULL == (devdir = strrchr(string, ']')))
8114                 devdir = strrchr(string, '>');
8115             strcpy(string, devdir + 1);
8116             }
8117         /*
8118          * Be consistent with what the C RTL has already done to the rest of
8119          * the argv items and lowercase all of these names.
8120          */
8121         if (!decc_efs_case_preserve) {
8122             for (c = string; *c; ++c)
8123             if (isupper(*c))
8124                 *c = tolower(*c);
8125         }
8126         if (isunix) trim_unixpath(string,item,1);
8127         add_item(head, tail, string, count);
8128         ++expcount;
8129     }
8130     PerlMem_free(vmsspec);
8131     if (sts != RMS$_NMF)
8132         {
8133         set_vaxc_errno(sts);
8134         switch (sts)
8135             {
8136             case RMS$_FNF: case RMS$_DNF:
8137                 set_errno(ENOENT); break;
8138             case RMS$_DIR:
8139                 set_errno(ENOTDIR); break;
8140             case RMS$_DEV:
8141                 set_errno(ENODEV); break;
8142             case RMS$_FNM: case RMS$_SYN:
8143                 set_errno(EINVAL); break;
8144             case RMS$_PRV:
8145                 set_errno(EACCES); break;
8146             default:
8147                 _ckvmssts_noperl(sts);
8148             }
8149         }
8150     if (expcount == 0)
8151         add_item(head, tail, item, count);
8152     _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8153     _ckvmssts_noperl(lib$find_file_end(&context));
8154 }
8155
8156 static int child_st[2];/* Event Flag set when child process completes   */
8157
8158 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox                */
8159
8160 static unsigned long int exit_handler(int *status)
8161 {
8162 short iosb[4];
8163
8164     if (0 == child_st[0])
8165         {
8166 #ifdef ARGPROC_DEBUG
8167         PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8168 #endif
8169         fflush(stdout);     /* Have to flush pipe for binary data to    */
8170                             /* terminate properly -- <tp@mccall.com>    */
8171         sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8172         sys$dassgn(child_chan);
8173         fclose(stdout);
8174         sys$synch(0, child_st);
8175         }
8176     return(1);
8177 }
8178
8179 static void sig_child(int chan)
8180 {
8181 #ifdef ARGPROC_DEBUG
8182     PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8183 #endif
8184     if (child_st[0] == 0)
8185         child_st[0] = 1;
8186 }
8187
8188 static struct exit_control_block exit_block =
8189     {
8190     0,
8191     exit_handler,
8192     1,
8193     &exit_block.exit_status,
8194     0
8195     };
8196
8197 static void
8198 pipe_and_fork(pTHX_ char **cmargv)
8199 {
8200     PerlIO *fp;
8201     struct dsc$descriptor_s *vmscmd;
8202     char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8203     int sts, j, l, ismcr, quote, tquote = 0;
8204
8205     sts = setup_cmddsc(aTHX_ cmargv[0],0,&quote,&vmscmd);
8206     vms_execfree(vmscmd);
8207
8208     j = l = 0;
8209     p = subcmd;
8210     q = cmargv[0];
8211     ismcr = q && toupper(*q) == 'M'     && toupper(*(q+1)) == 'C'
8212               && toupper(*(q+2)) == 'R' && !*(q+3);
8213
8214     while (q && l < MAX_DCL_LINE_LENGTH) {
8215         if (!*q) {
8216             if (j > 0 && quote) {
8217                 *p++ = '"';
8218                 l++;
8219             }
8220             q = cmargv[++j];
8221             if (q) {
8222                 if (ismcr && j > 1) quote = 1;
8223                 tquote =  (strchr(q,' ')) != NULL || *q == '\0';
8224                 *p++ = ' ';
8225                 l++;
8226                 if (quote || tquote) {
8227                     *p++ = '"';
8228                     l++;
8229                 }
8230             }
8231         } else {
8232             if ((quote||tquote) && *q == '"') {
8233                 *p++ = '"';
8234                 l++;
8235             }
8236             *p++ = *q++;
8237             l++;
8238         }
8239     }
8240     *p = '\0';
8241
8242     fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8243     if (fp == Nullfp) {
8244         PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8245     }
8246 }
8247
8248 static int background_process(pTHX_ int argc, char **argv)
8249 {
8250 char command[MAX_DCL_SYMBOL + 1] = "$";
8251 $DESCRIPTOR(value, "");
8252 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8253 static $DESCRIPTOR(null, "NLA0:");
8254 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8255 char pidstring[80];
8256 $DESCRIPTOR(pidstr, "");
8257 int pid;
8258 unsigned long int flags = 17, one = 1, retsts;
8259 int len;
8260
8261     strcat(command, argv[0]);
8262     len = strlen(command);
8263     while (--argc && (len < MAX_DCL_SYMBOL))
8264         {
8265         strcat(command, " \"");
8266         strcat(command, *(++argv));
8267         strcat(command, "\"");
8268         len = strlen(command);
8269         }
8270     value.dsc$a_pointer = command;
8271     value.dsc$w_length = strlen(value.dsc$a_pointer);
8272     _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8273     retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8274     if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8275         _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8276     }
8277     else {
8278         _ckvmssts_noperl(retsts);
8279     }
8280 #ifdef ARGPROC_DEBUG
8281     PerlIO_printf(Perl_debug_log, "%s\n", command);
8282 #endif
8283     sprintf(pidstring, "%08X", pid);
8284     PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8285     pidstr.dsc$a_pointer = pidstring;
8286     pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8287     lib$set_symbol(&pidsymbol, &pidstr);
8288     return(SS$_NORMAL);
8289 }
8290 /*}}}*/
8291 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8292
8293
8294 /* OS-specific initialization at image activation (not thread startup) */
8295 /* Older VAXC header files lack these constants */
8296 #ifndef JPI$_RIGHTS_SIZE
8297 #  define JPI$_RIGHTS_SIZE 817
8298 #endif
8299 #ifndef KGB$M_SUBSYSTEM
8300 #  define KGB$M_SUBSYSTEM 0x8
8301 #endif
8302
8303 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8304
8305 /*{{{void vms_image_init(int *, char ***)*/
8306 void
8307 vms_image_init(int *argcp, char ***argvp)
8308 {
8309   char eqv[LNM$C_NAMLENGTH+1] = "";
8310   unsigned int len, tabct = 8, tabidx = 0;
8311   unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8312   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8313   unsigned short int dummy, rlen;
8314   struct dsc$descriptor_s **tabvec;
8315 #if defined(PERL_IMPLICIT_CONTEXT)
8316   pTHX = NULL;
8317 #endif
8318   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
8319                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
8320                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8321                                  {          0,                0,    0,      0} };
8322
8323 #ifdef KILL_BY_SIGPRC
8324     Perl_csighandler_init();
8325 #endif
8326
8327   _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8328   _ckvmssts_noperl(iosb[0]);
8329   for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8330     if (iprv[i]) {           /* Running image installed with privs? */
8331       _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL));       /* Turn 'em off. */
8332       will_taint = TRUE;
8333       break;
8334     }
8335   }
8336   /* Rights identifiers might trigger tainting as well. */
8337   if (!will_taint && (rlen || rsz)) {
8338     while (rlen < rsz) {
8339       /* We didn't get all the identifiers on the first pass.  Allocate a
8340        * buffer much larger than $GETJPI wants (rsz is size in bytes that
8341        * were needed to hold all identifiers at time of last call; we'll
8342        * allocate that many unsigned long ints), and go back and get 'em.
8343        * If it gave us less than it wanted to despite ample buffer space,
8344        * something's broken.  Is your system missing a system identifier?
8345        */
8346       if (rsz <= jpilist[1].buflen) {
8347          /* Perl_croak accvios when used this early in startup. */
8348          fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8349                          rsz, (unsigned long) jpilist[1].buflen,
8350                          "Check your rights database for corruption.\n");
8351          exit(SS$_ABORT);
8352       }
8353       if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8354       jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8355       if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8356       jpilist[1].buflen = rsz * sizeof(unsigned long int);
8357       _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8358       _ckvmssts_noperl(iosb[0]);
8359     }
8360     mask = jpilist[1].bufadr;
8361     /* Check attribute flags for each identifier (2nd longword); protected
8362      * subsystem identifiers trigger tainting.
8363      */
8364     for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8365       if (mask[i] & KGB$M_SUBSYSTEM) {
8366         will_taint = TRUE;
8367         break;
8368       }
8369     }
8370     if (mask != rlst) PerlMem_free(mask);
8371   }
8372
8373   /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8374    * logical, some versions of the CRTL will add a phanthom /000000/
8375    * directory.  This needs to be removed.
8376    */
8377   if (decc_filename_unix_report) {
8378   char * zeros;
8379   int ulen;
8380     ulen = strlen(argvp[0][0]);
8381     if (ulen > 7) {
8382       zeros = strstr(argvp[0][0], "/000000/");
8383       if (zeros != NULL) {
8384         int mlen;
8385         mlen = ulen - (zeros - argvp[0][0]) - 7;
8386         memmove(zeros, &zeros[7], mlen);
8387         ulen = ulen - 7;
8388         argvp[0][0][ulen] = '\0';
8389       }
8390     }
8391     /* It also may have a trailing dot that needs to be removed otherwise
8392      * it will be converted to VMS mode incorrectly.
8393      */
8394     ulen--;
8395     if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8396       argvp[0][0][ulen] = '\0';
8397   }
8398
8399   /* We need to use this hack to tell Perl it should run with tainting,
8400    * since its tainting flag may be part of the PL_curinterp struct, which
8401    * hasn't been allocated when vms_image_init() is called.
8402    */
8403   if (will_taint) {
8404     char **newargv, **oldargv;
8405     oldargv = *argvp;
8406     newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8407     if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8408     newargv[0] = oldargv[0];
8409     newargv[1] = PerlMem_malloc(3 * sizeof(char));
8410     if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8411     strcpy(newargv[1], "-T");
8412     Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8413     (*argcp)++;
8414     newargv[*argcp] = NULL;
8415     /* We orphan the old argv, since we don't know where it's come from,
8416      * so we don't know how to free it.
8417      */
8418     *argvp = newargv;
8419   }
8420   else {  /* Did user explicitly request tainting? */
8421     int i;
8422     char *cp, **av = *argvp;
8423     for (i = 1; i < *argcp; i++) {
8424       if (*av[i] != '-') break;
8425       for (cp = av[i]+1; *cp; cp++) {
8426         if (*cp == 'T') { will_taint = 1; break; }
8427         else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8428                   strchr("DFIiMmx",*cp)) break;
8429       }
8430       if (will_taint) break;
8431     }
8432   }
8433
8434   for (tabidx = 0;
8435        len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8436        tabidx++) {
8437     if (!tabidx) {
8438       tabvec = (struct dsc$descriptor_s **)
8439             PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8440       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8441     }
8442     else if (tabidx >= tabct) {
8443       tabct += 8;
8444       tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8445       if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8446     }
8447     tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8448     if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8449     tabvec[tabidx]->dsc$w_length  = 0;
8450     tabvec[tabidx]->dsc$b_dtype   = DSC$K_DTYPE_T;
8451     tabvec[tabidx]->dsc$b_class   = DSC$K_CLASS_D;
8452     tabvec[tabidx]->dsc$a_pointer = NULL;
8453     _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8454   }
8455   if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8456
8457   getredirection(argcp,argvp);
8458 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8459   {
8460 # include <reentrancy.h>
8461   decc$set_reentrancy(C$C_MULTITHREAD);
8462   }
8463 #endif
8464   return;
8465 }
8466 /*}}}*/
8467
8468
8469 /* trim_unixpath()
8470  * Trim Unix-style prefix off filespec, so it looks like what a shell
8471  * glob expansion would return (i.e. from specified prefix on, not
8472  * full path).  Note that returned filespec is Unix-style, regardless
8473  * of whether input filespec was VMS-style or Unix-style.
8474  *
8475  * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8476  * determine prefix (both may be in VMS or Unix syntax).  opts is a bit
8477  * vector of options; at present, only bit 0 is used, and if set tells
8478  * trim unixpath to try the current default directory as a prefix when
8479  * presented with a possibly ambiguous ... wildcard.
8480  *
8481  * Returns !=0 on success, with trimmed filespec replacing contents of
8482  * fspec, and 0 on failure, with contents of fpsec unchanged.
8483  */
8484 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8485 int
8486 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8487 {
8488   char *unixified, *unixwild,
8489        *template, *base, *end, *cp1, *cp2;
8490   register int tmplen, reslen = 0, dirs = 0;
8491
8492   unixwild = PerlMem_malloc(VMS_MAXRSS);
8493   if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8494   if (!wildspec || !fspec) return 0;
8495   template = unixwild;
8496   if (strpbrk(wildspec,"]>:") != NULL) {
8497     if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8498         PerlMem_free(unixwild);
8499         return 0;
8500     }
8501   }
8502   else {
8503     strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8504     unixwild[VMS_MAXRSS-1] = 0;
8505   }
8506   unixified = PerlMem_malloc(VMS_MAXRSS);
8507   if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8508   if (strpbrk(fspec,"]>:") != NULL) {
8509     if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8510         PerlMem_free(unixwild);
8511         PerlMem_free(unixified);
8512         return 0;
8513     }
8514     else base = unixified;
8515     /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8516      * check to see that final result fits into (isn't longer than) fspec */
8517     reslen = strlen(fspec);
8518   }
8519   else base = fspec;
8520
8521   /* No prefix or absolute path on wildcard, so nothing to remove */
8522   if (!*template || *template == '/') {
8523     PerlMem_free(unixwild);
8524     if (base == fspec) {
8525         PerlMem_free(unixified);
8526         return 1;
8527     }
8528     tmplen = strlen(unixified);
8529     if (tmplen > reslen) {
8530         PerlMem_free(unixified);
8531         return 0;  /* not enough space */
8532     }
8533     /* Copy unixified resultant, including trailing NUL */
8534     memmove(fspec,unixified,tmplen+1);
8535     PerlMem_free(unixified);
8536     return 1;
8537   }
8538
8539   for (end = base; *end; end++) ;  /* Find end of resultant filespec */
8540   if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8541     for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8542     for (cp1 = end ;cp1 >= base; cp1--)
8543       if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8544         { cp1++; break; }
8545     if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8546     PerlMem_free(unixified);
8547     PerlMem_free(unixwild);
8548     return 1;
8549   }
8550   else {
8551     char *tpl, *lcres;
8552     char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8553     int ells = 1, totells, segdirs, match;
8554     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8555                             resdsc =  {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8556
8557     while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8558     totells = ells;
8559     for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8560     tpl = PerlMem_malloc(VMS_MAXRSS);
8561     if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8562     if (ellipsis == template && opts & 1) {
8563       /* Template begins with an ellipsis.  Since we can't tell how many
8564        * directory names at the front of the resultant to keep for an
8565        * arbitrary starting point, we arbitrarily choose the current
8566        * default directory as a starting point.  If it's there as a prefix,
8567        * clip it off.  If not, fall through and act as if the leading
8568        * ellipsis weren't there (i.e. return shortest possible path that
8569        * could match template).
8570        */
8571       if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8572           PerlMem_free(tpl);
8573           PerlMem_free(unixified);
8574           PerlMem_free(unixwild);
8575           return 0;
8576       }
8577       if (!decc_efs_case_preserve) {
8578         for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8579           if (_tolower(*cp1) != _tolower(*cp2)) break;
8580       }
8581       segdirs = dirs - totells;  /* Min # of dirs we must have left */
8582       for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8583       if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8584         memmove(fspec,cp2+1,end - cp2);
8585         PerlMem_free(tpl);
8586         PerlMem_free(unixified);
8587         PerlMem_free(unixwild);
8588         return 1;
8589       }
8590     }
8591     /* First off, back up over constant elements at end of path */
8592     if (dirs) {
8593       for (front = end ; front >= base; front--)
8594          if (*front == '/' && !dirs--) { front++; break; }
8595     }
8596     lcres = PerlMem_malloc(VMS_MAXRSS);
8597     if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8598     for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8599          cp1++,cp2++) {
8600             if (!decc_efs_case_preserve) {
8601                 *cp2 = _tolower(*cp1);  /* Make lc copy for match */
8602             }
8603             else {
8604                 *cp2 = *cp1;
8605             }
8606     }
8607     if (cp1 != '\0') {
8608         PerlMem_free(tpl);
8609         PerlMem_free(unixified);
8610         PerlMem_free(unixwild);
8611         PerlMem_free(lcres);
8612         return 0;  /* Path too long. */
8613     }
8614     lcend = cp2;
8615     *cp2 = '\0';  /* Pick up with memcpy later */
8616     lcfront = lcres + (front - base);
8617     /* Now skip over each ellipsis and try to match the path in front of it. */
8618     while (ells--) {
8619       for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8620         if (*(cp1)   == '.' && *(cp1+1) == '.' &&
8621             *(cp1+2) == '.' && *(cp1+3) == '/'    ) break;
8622       if (cp1 < template) break; /* template started with an ellipsis */
8623       if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8624         ellipsis = cp1; continue;
8625       }
8626       wilddsc.dsc$a_pointer = tpl;
8627       wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8628       nextell = cp1;
8629       for (segdirs = 0, cp2 = tpl;
8630            cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8631            cp1++, cp2++) {
8632          if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8633          else {
8634             if (!decc_efs_case_preserve) {
8635               *cp2 = _tolower(*cp1);  /* else lowercase for match */
8636             }
8637             else {
8638               *cp2 = *cp1;  /* else preserve case for match */
8639             }
8640          }
8641          if (*cp2 == '/') segdirs++;
8642       }
8643       if (cp1 != ellipsis - 1) {
8644           PerlMem_free(tpl);
8645           PerlMem_free(unixified);
8646           PerlMem_free(unixwild);
8647           PerlMem_free(lcres);
8648           return 0; /* Path too long */
8649       }
8650       /* Back up at least as many dirs as in template before matching */
8651       for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8652         if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8653       for (match = 0; cp1 > lcres;) {
8654         resdsc.dsc$a_pointer = cp1;
8655         if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8656           match++;
8657           if (match == 1) lcfront = cp1;
8658         }
8659         for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8660       }
8661       if (!match) {
8662         PerlMem_free(tpl);
8663         PerlMem_free(unixified);
8664         PerlMem_free(unixwild);
8665         PerlMem_free(lcres);
8666         return 0;  /* Can't find prefix ??? */
8667       }
8668       if (match > 1 && opts & 1) {
8669         /* This ... wildcard could cover more than one set of dirs (i.e.
8670          * a set of similar dir names is repeated).  If the template
8671          * contains more than 1 ..., upstream elements could resolve the
8672          * ambiguity, but it's not worth a full backtracking setup here.
8673          * As a quick heuristic, clip off the current default directory
8674          * if it's present to find the trimmed spec, else use the
8675          * shortest string that this ... could cover.
8676          */
8677         char def[NAM$C_MAXRSS+1], *st;
8678
8679         if (getcwd(def, sizeof def,0) == NULL) {
8680             Safefree(unixified);
8681             Safefree(unixwild);
8682             Safefree(lcres);
8683             Safefree(tpl);
8684             return 0;
8685         }
8686         if (!decc_efs_case_preserve) {
8687           for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8688             if (_tolower(*cp1) != _tolower(*cp2)) break;
8689         }
8690         segdirs = dirs - totells;  /* Min # of dirs we must have left */
8691         for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8692         if (*cp1 == '\0' && *cp2 == '/') {
8693           memmove(fspec,cp2+1,end - cp2);
8694           PerlMem_free(tpl);
8695           PerlMem_free(unixified);
8696           PerlMem_free(unixwild);
8697           PerlMem_free(lcres);
8698           return 1;
8699         }
8700         /* Nope -- stick with lcfront from above and keep going. */
8701       }
8702     }
8703     memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8704     PerlMem_free(tpl);
8705     PerlMem_free(unixified);
8706     PerlMem_free(unixwild);
8707     PerlMem_free(lcres);
8708     return 1;
8709     ellipsis = nextell;
8710   }
8711
8712 }  /* end of trim_unixpath() */
8713 /*}}}*/
8714
8715
8716 /*
8717  *  VMS readdir() routines.
8718  *  Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8719  *
8720  *  21-Jul-1994  Charles Bailey  bailey@newman.upenn.edu
8721  *  Minor modifications to original routines.
8722  */
8723
8724 /* readdir may have been redefined by reentr.h, so make sure we get
8725  * the local version for what we do here.
8726  */
8727 #ifdef readdir
8728 # undef readdir
8729 #endif
8730 #if !defined(PERL_IMPLICIT_CONTEXT)
8731 # define readdir Perl_readdir
8732 #else
8733 # define readdir(a) Perl_readdir(aTHX_ a)
8734 #endif
8735
8736     /* Number of elements in vms_versions array */
8737 #define VERSIZE(e)      (sizeof e->vms_versions / sizeof e->vms_versions[0])
8738
8739 /*
8740  *  Open a directory, return a handle for later use.
8741  */
8742 /*{{{ DIR *opendir(char*name) */
8743 DIR *
8744 Perl_opendir(pTHX_ const char *name)
8745 {
8746     DIR *dd;
8747     char *dir;
8748     Stat_t sb;
8749     int unix_flag;
8750
8751     unix_flag = 0;
8752     if (decc_efs_charset) {
8753         unix_flag = is_unix_filespec(name);
8754     }
8755
8756     Newx(dir, VMS_MAXRSS, char);
8757     if (do_tovmspath(name,dir,0,NULL) == NULL) {
8758       Safefree(dir);
8759       return NULL;
8760     }
8761     /* Check access before stat; otherwise stat does not
8762      * accurately report whether it's a directory.
8763      */
8764     if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8765       /* cando_by_name has already set errno */
8766       Safefree(dir);
8767       return NULL;
8768     }
8769     if (flex_stat(dir,&sb) == -1) return NULL;
8770     if (!S_ISDIR(sb.st_mode)) {
8771       Safefree(dir);
8772       set_errno(ENOTDIR);  set_vaxc_errno(RMS$_DIR);
8773       return NULL;
8774     }
8775     /* Get memory for the handle, and the pattern. */
8776     Newx(dd,1,DIR);
8777     Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8778
8779     /* Fill in the fields; mainly playing with the descriptor. */
8780     sprintf(dd->pattern, "%s*.*",dir);
8781     Safefree(dir);
8782     dd->context = 0;
8783     dd->count = 0;
8784     dd->flags = 0;
8785     if (unix_flag)
8786         dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8787     dd->pat.dsc$a_pointer = dd->pattern;
8788     dd->pat.dsc$w_length = strlen(dd->pattern);
8789     dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8790     dd->pat.dsc$b_class = DSC$K_CLASS_S;
8791 #if defined(USE_ITHREADS)
8792     Newx(dd->mutex,1,perl_mutex);
8793     MUTEX_INIT( (perl_mutex *) dd->mutex );
8794 #else
8795     dd->mutex = NULL;
8796 #endif
8797
8798     return dd;
8799 }  /* end of opendir() */
8800 /*}}}*/
8801
8802 /*
8803  *  Set the flag to indicate we want versions or not.
8804  */
8805 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8806 void
8807 vmsreaddirversions(DIR *dd, int flag)
8808 {
8809     if (flag)
8810         dd->flags |= PERL_VMSDIR_M_VERSIONS;
8811     else
8812         dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8813 }
8814 /*}}}*/
8815
8816 /*
8817  *  Free up an opened directory.
8818  */
8819 /*{{{ void closedir(DIR *dd)*/
8820 void
8821 Perl_closedir(DIR *dd)
8822 {
8823     int sts;
8824
8825     sts = lib$find_file_end(&dd->context);
8826     Safefree(dd->pattern);
8827 #if defined(USE_ITHREADS)
8828     MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8829     Safefree(dd->mutex);
8830 #endif
8831     Safefree(dd);
8832 }
8833 /*}}}*/
8834
8835 /*
8836  *  Collect all the version numbers for the current file.
8837  */
8838 static void
8839 collectversions(pTHX_ DIR *dd)
8840 {
8841     struct dsc$descriptor_s     pat;
8842     struct dsc$descriptor_s     res;
8843     struct dirent *e;
8844     char *p, *text, *buff;
8845     int i;
8846     unsigned long context, tmpsts;
8847
8848     /* Convenient shorthand. */
8849     e = &dd->entry;
8850
8851     /* Add the version wildcard, ignoring the "*.*" put on before */
8852     i = strlen(dd->pattern);
8853     Newx(text,i + e->d_namlen + 3,char);
8854     strcpy(text, dd->pattern);
8855     sprintf(&text[i - 3], "%s;*", e->d_name);
8856
8857     /* Set up the pattern descriptor. */
8858     pat.dsc$a_pointer = text;
8859     pat.dsc$w_length = i + e->d_namlen - 1;
8860     pat.dsc$b_dtype = DSC$K_DTYPE_T;
8861     pat.dsc$b_class = DSC$K_CLASS_S;
8862
8863     /* Set up result descriptor. */
8864     Newx(buff, VMS_MAXRSS, char);
8865     res.dsc$a_pointer = buff;
8866     res.dsc$w_length = VMS_MAXRSS - 1;
8867     res.dsc$b_dtype = DSC$K_DTYPE_T;
8868     res.dsc$b_class = DSC$K_CLASS_S;
8869
8870     /* Read files, collecting versions. */
8871     for (context = 0, e->vms_verscount = 0;
8872          e->vms_verscount < VERSIZE(e);
8873          e->vms_verscount++) {
8874         unsigned long rsts;
8875         unsigned long flags = 0;
8876
8877 #ifdef VMS_LONGNAME_SUPPORT
8878         flags = LIB$M_FIL_LONG_NAMES;
8879 #endif
8880         tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8881         if (tmpsts == RMS$_NMF || context == 0) break;
8882         _ckvmssts(tmpsts);
8883         buff[VMS_MAXRSS - 1] = '\0';
8884         if ((p = strchr(buff, ';')))
8885             e->vms_versions[e->vms_verscount] = atoi(p + 1);
8886         else
8887             e->vms_versions[e->vms_verscount] = -1;
8888     }
8889
8890     _ckvmssts(lib$find_file_end(&context));
8891     Safefree(text);
8892     Safefree(buff);
8893
8894 }  /* end of collectversions() */
8895
8896 /*
8897  *  Read the next entry from the directory.
8898  */
8899 /*{{{ struct dirent *readdir(DIR *dd)*/
8900 struct dirent *
8901 Perl_readdir(pTHX_ DIR *dd)
8902 {
8903     struct dsc$descriptor_s     res;
8904     char *p, *buff;
8905     unsigned long int tmpsts;
8906     unsigned long rsts;
8907     unsigned long flags = 0;
8908     char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8909     int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8910
8911     /* Set up result descriptor, and get next file. */
8912     Newx(buff, VMS_MAXRSS, char);
8913     res.dsc$a_pointer = buff;
8914     res.dsc$w_length = VMS_MAXRSS - 1;
8915     res.dsc$b_dtype = DSC$K_DTYPE_T;
8916     res.dsc$b_class = DSC$K_CLASS_S;
8917
8918 #ifdef VMS_LONGNAME_SUPPORT
8919     flags = LIB$M_FIL_LONG_NAMES;
8920 #endif
8921
8922     tmpsts = lib$find_file
8923         (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8924     if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL;  /* None left. */
8925     if (!(tmpsts & 1)) {
8926       set_vaxc_errno(tmpsts);
8927       switch (tmpsts) {
8928         case RMS$_PRV:
8929           set_errno(EACCES); break;
8930         case RMS$_DEV:
8931           set_errno(ENODEV); break;
8932         case RMS$_DIR:
8933           set_errno(ENOTDIR); break;
8934         case RMS$_FNF: case RMS$_DNF:
8935           set_errno(ENOENT); break;
8936         default:
8937           set_errno(EVMSERR);
8938       }
8939       Safefree(buff);
8940       return NULL;
8941     }
8942     dd->count++;
8943     /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8944     if (!decc_efs_case_preserve) {
8945       buff[VMS_MAXRSS - 1] = '\0';
8946       for (p = buff; *p; p++) *p = _tolower(*p);
8947     }
8948     else {
8949       /* we don't want to force to lowercase, just null terminate */
8950       buff[res.dsc$w_length] = '\0';
8951     }
8952     while (--p >= buff) if (!isspace(*p)) break;  /* Do we really need this? */
8953     *p = '\0';
8954
8955     /* Skip any directory component and just copy the name. */
8956     sts = vms_split_path
8957        (buff,
8958         &v_spec,
8959         &v_len,
8960         &r_spec,
8961         &r_len,
8962         &d_spec,
8963         &d_len,
8964         &n_spec,
8965         &n_len,
8966         &e_spec,
8967         &e_len,
8968         &vs_spec,
8969         &vs_len);
8970
8971     /* Drop NULL extensions on UNIX file specification */
8972     if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8973         (e_len == 1) && decc_readdir_dropdotnotype)) {
8974         e_len = 0;
8975         e_spec[0] = '\0';
8976     }
8977
8978     strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8979     dd->entry.d_name[n_len + e_len] = '\0';
8980     dd->entry.d_namlen = strlen(dd->entry.d_name);
8981
8982     /* Convert the filename to UNIX format if needed */
8983     if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8984
8985         /* Translate the encoded characters. */
8986         /* Fixme: unicode handling could result in embedded 0 characters */
8987         if (strchr(dd->entry.d_name, '^') != NULL) {
8988             char new_name[256];
8989             char * q;
8990             int cnt;
8991             p = dd->entry.d_name;
8992             q = new_name;
8993             while (*p != 0) {
8994                 int x, y;
8995                 x = copy_expand_vms_filename_escape(q, p, &y);
8996                 p += x;
8997                 q += y;
8998                 /* fix-me */
8999                 /* if y > 1, then this is a wide file specification */
9000                 /* Wide file specifications need to be passed in Perl */
9001                 /* counted strings apparently with a unicode flag */
9002             }
9003             *q = 0;
9004             strcpy(dd->entry.d_name, new_name);
9005         }
9006     }
9007
9008     dd->entry.vms_verscount = 0;
9009     if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9010     Safefree(buff);
9011     return &dd->entry;
9012
9013 }  /* end of readdir() */
9014 /*}}}*/
9015
9016 /*
9017  *  Read the next entry from the directory -- thread-safe version.
9018  */
9019 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9020 int
9021 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9022 {
9023     int retval;
9024
9025     MUTEX_LOCK( (perl_mutex *) dd->mutex );
9026
9027     entry = readdir(dd);
9028     *result = entry;
9029     retval = ( *result == NULL ? errno : 0 );
9030
9031     MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9032
9033     return retval;
9034
9035 }  /* end of readdir_r() */
9036 /*}}}*/
9037
9038 /*
9039  *  Return something that can be used in a seekdir later.
9040  */
9041 /*{{{ long telldir(DIR *dd)*/
9042 long
9043 Perl_telldir(DIR *dd)
9044 {
9045     return dd->count;
9046 }
9047 /*}}}*/
9048
9049 /*
9050  *  Return to a spot where we used to be.  Brute force.
9051  */
9052 /*{{{ void seekdir(DIR *dd,long count)*/
9053 void
9054 Perl_seekdir(pTHX_ DIR *dd, long count)
9055 {
9056     int old_flags;
9057
9058     /* If we haven't done anything yet... */
9059     if (dd->count == 0)
9060         return;
9061
9062     /* Remember some state, and clear it. */
9063     old_flags = dd->flags;
9064     dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9065     _ckvmssts(lib$find_file_end(&dd->context));
9066     dd->context = 0;
9067
9068     /* The increment is in readdir(). */
9069     for (dd->count = 0; dd->count < count; )
9070         readdir(dd);
9071
9072     dd->flags = old_flags;
9073
9074 }  /* end of seekdir() */
9075 /*}}}*/
9076
9077 /* VMS subprocess management
9078  *
9079  * my_vfork() - just a vfork(), after setting a flag to record that
9080  * the current script is trying a Unix-style fork/exec.
9081  *
9082  * vms_do_aexec() and vms_do_exec() are called in response to the
9083  * perl 'exec' function.  If this follows a vfork call, then they
9084  * call out the regular perl routines in doio.c which do an
9085  * execvp (for those who really want to try this under VMS).
9086  * Otherwise, they do exactly what the perl docs say exec should
9087  * do - terminate the current script and invoke a new command
9088  * (See below for notes on command syntax.)
9089  *
9090  * do_aspawn() and do_spawn() implement the VMS side of the perl
9091  * 'system' function.
9092  *
9093  * Note on command arguments to perl 'exec' and 'system': When handled
9094  * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9095  * are concatenated to form a DCL command string.  If the first arg
9096  * begins with '$' (i.e. the perl script had "\$ Type" or some such),
9097  * the command string is handed off to DCL directly.  Otherwise,
9098  * the first token of the command is taken as the filespec of an image
9099  * to run.  The filespec is expanded using a default type of '.EXE' and
9100  * the process defaults for device, directory, etc., and if found, the resultant
9101  * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9102  * the command string as parameters.  This is perhaps a bit complicated,
9103  * but I hope it will form a happy medium between what VMS folks expect
9104  * from lib$spawn and what Unix folks expect from exec.
9105  */
9106
9107 static int vfork_called;
9108
9109 /*{{{int my_vfork()*/
9110 int
9111 my_vfork()
9112 {
9113   vfork_called++;
9114   return vfork();
9115 }
9116 /*}}}*/
9117
9118
9119 static void
9120 vms_execfree(struct dsc$descriptor_s *vmscmd)
9121 {
9122   if (vmscmd) {
9123       if (vmscmd->dsc$a_pointer) {
9124           PerlMem_free(vmscmd->dsc$a_pointer);
9125       }
9126       PerlMem_free(vmscmd);
9127   }
9128 }
9129
9130 static char *
9131 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9132 {
9133   char *junk, *tmps = Nullch;
9134   register size_t cmdlen = 0;
9135   size_t rlen;
9136   register SV **idx;
9137   STRLEN n_a;
9138
9139   idx = mark;
9140   if (really) {
9141     tmps = SvPV(really,rlen);
9142     if (*tmps) {
9143       cmdlen += rlen + 1;
9144       idx++;
9145     }
9146   }
9147
9148   for (idx++; idx <= sp; idx++) {
9149     if (*idx) {
9150       junk = SvPVx(*idx,rlen);
9151       cmdlen += rlen ? rlen + 1 : 0;
9152     }
9153   }
9154   Newx(PL_Cmd, cmdlen+1, char);
9155
9156   if (tmps && *tmps) {
9157     strcpy(PL_Cmd,tmps);
9158     mark++;
9159   }
9160   else *PL_Cmd = '\0';
9161   while (++mark <= sp) {
9162     if (*mark) {
9163       char *s = SvPVx(*mark,n_a);
9164       if (!*s) continue;
9165       if (*PL_Cmd) strcat(PL_Cmd," ");
9166       strcat(PL_Cmd,s);
9167     }
9168   }
9169   return PL_Cmd;
9170
9171 }  /* end of setup_argstr() */
9172
9173
9174 static unsigned long int
9175 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9176                    struct dsc$descriptor_s **pvmscmd)
9177 {
9178   char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9179   char image_name[NAM$C_MAXRSS+1];
9180   char image_argv[NAM$C_MAXRSS+1];
9181   $DESCRIPTOR(defdsc,".EXE");
9182   $DESCRIPTOR(defdsc2,".");
9183   $DESCRIPTOR(resdsc,resspec);
9184   struct dsc$descriptor_s *vmscmd;
9185   struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9186   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9187   register char *s, *rest, *cp, *wordbreak;
9188   char * cmd;
9189   int cmdlen;
9190   register int isdcl;
9191
9192   vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9193   if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9194
9195   /* Make a copy for modification */
9196   cmdlen = strlen(incmd);
9197   cmd = PerlMem_malloc(cmdlen+1);
9198   if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9199   strncpy(cmd, incmd, cmdlen);
9200   cmd[cmdlen] = 0;
9201   image_name[0] = 0;
9202   image_argv[0] = 0;
9203
9204   vmscmd->dsc$a_pointer = NULL;
9205   vmscmd->dsc$b_dtype  = DSC$K_DTYPE_T;
9206   vmscmd->dsc$b_class  = DSC$K_CLASS_S;
9207   vmscmd->dsc$w_length = 0;
9208   if (pvmscmd) *pvmscmd = vmscmd;
9209
9210   if (suggest_quote) *suggest_quote = 0;
9211
9212   if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9213     PerlMem_free(cmd);
9214     return CLI$_BUFOVF;                /* continuation lines currently unsupported */
9215   }
9216
9217   s = cmd;
9218
9219   while (*s && isspace(*s)) s++;
9220
9221   if (*s == '@' || *s == '$') {
9222     vmsspec[0] = *s;  rest = s + 1;
9223     for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9224   }
9225   else { cp = vmsspec; rest = s; }
9226   if (*rest == '.' || *rest == '/') {
9227     char *cp2;
9228     for (cp2 = resspec;
9229          *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9230          rest++, cp2++) *cp2 = *rest;
9231     *cp2 = '\0';
9232     if (do_tovmsspec(resspec,cp,0,NULL)) {
9233       s = vmsspec;
9234       if (*rest) {
9235         for (cp2 = vmsspec + strlen(vmsspec);
9236              *rest && cp2 - vmsspec < sizeof vmsspec;
9237              rest++, cp2++) *cp2 = *rest;
9238         *cp2 = '\0';
9239       }
9240     }
9241   }
9242   /* Intuit whether verb (first word of cmd) is a DCL command:
9243    *   - if first nonspace char is '@', it's a DCL indirection
9244    * otherwise
9245    *   - if verb contains a filespec separator, it's not a DCL command
9246    *   - if it doesn't, caller tells us whether to default to a DCL
9247    *     command, or to a local image unless told it's DCL (by leading '$')
9248    */
9249   if (*s == '@') {
9250       isdcl = 1;
9251       if (suggest_quote) *suggest_quote = 1;
9252   } else {
9253     register char *filespec = strpbrk(s,":<[.;");
9254     rest = wordbreak = strpbrk(s," \"\t/");
9255     if (!wordbreak) wordbreak = s + strlen(s);
9256     if (*s == '$') check_img = 0;
9257     if (filespec && (filespec < wordbreak)) isdcl = 0;
9258     else isdcl = !check_img;
9259   }
9260
9261   if (!isdcl) {
9262     int rsts;
9263     imgdsc.dsc$a_pointer = s;
9264     imgdsc.dsc$w_length = wordbreak - s;
9265     retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9266     if (!(retsts&1)) {
9267         _ckvmssts(lib$find_file_end(&cxt));
9268         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9269       if (!(retsts & 1) && *s == '$') {
9270         _ckvmssts(lib$find_file_end(&cxt));
9271         imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9272         retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9273         if (!(retsts&1)) {
9274           _ckvmssts(lib$find_file_end(&cxt));
9275           retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9276         }
9277       }
9278     }
9279     _ckvmssts(lib$find_file_end(&cxt));
9280
9281     if (retsts & 1) {
9282       FILE *fp;
9283       s = resspec;
9284       while (*s && !isspace(*s)) s++;
9285       *s = '\0';
9286
9287       /* check that it's really not DCL with no file extension */
9288       fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9289       if (fp) {
9290         char b[256] = {0,0,0,0};
9291         read(fileno(fp), b, 256);
9292         isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9293         if (isdcl) {
9294           int shebang_len;
9295
9296           /* Check for script */
9297           shebang_len = 0;
9298           if ((b[0] == '#') && (b[1] == '!'))
9299              shebang_len = 2;
9300 #ifdef ALTERNATE_SHEBANG
9301           else {
9302             shebang_len = strlen(ALTERNATE_SHEBANG);
9303             if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9304               char * perlstr;
9305                 perlstr = strstr("perl",b);
9306                 if (perlstr == NULL)
9307                   shebang_len = 0;
9308             }
9309             else
9310               shebang_len = 0;
9311           }
9312 #endif
9313
9314           if (shebang_len > 0) {
9315           int i;
9316           int j;
9317           char tmpspec[NAM$C_MAXRSS + 1];
9318
9319             i = shebang_len;
9320              /* Image is following after white space */
9321             /*--------------------------------------*/
9322             while (isprint(b[i]) && isspace(b[i]))
9323                 i++;
9324
9325             j = 0;
9326             while (isprint(b[i]) && !isspace(b[i])) {
9327                 tmpspec[j++] = b[i++];
9328                 if (j >= NAM$C_MAXRSS)
9329                    break;
9330             }
9331             tmpspec[j] = '\0';
9332
9333              /* There may be some default parameters to the image */
9334             /*---------------------------------------------------*/
9335             j = 0;
9336             while (isprint(b[i])) {
9337                 image_argv[j++] = b[i++];
9338                 if (j >= NAM$C_MAXRSS)
9339                    break;
9340             }
9341             while ((j > 0) && !isprint(image_argv[j-1]))
9342                 j--;
9343             image_argv[j] = 0;
9344
9345             /* It will need to be converted to VMS format and validated */
9346             if (tmpspec[0] != '\0') {
9347               char * iname;
9348
9349                /* Try to find the exact program requested to be run */
9350               /*---------------------------------------------------*/
9351               iname = do_rmsexpand
9352                  (tmpspec, image_name, 0, ".exe",
9353                   PERL_RMSEXPAND_M_VMS, NULL, NULL);
9354               if (iname != NULL) {
9355                 if (cando_by_name_int
9356                         (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9357                   /* MCR prefix needed */
9358                   isdcl = 0;
9359                 }
9360                 else {
9361                    /* Try again with a null type */
9362                   /*----------------------------*/
9363                   iname = do_rmsexpand
9364                     (tmpspec, image_name, 0, ".",
9365                      PERL_RMSEXPAND_M_VMS, NULL, NULL);
9366                   if (iname != NULL) {
9367                     if (cando_by_name_int
9368                          (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9369                       /* MCR prefix needed */
9370                       isdcl = 0;
9371                     }
9372                   }
9373                 }
9374
9375                  /* Did we find the image to run the script? */
9376                 /*------------------------------------------*/
9377                 if (isdcl) {
9378                   char *tchr;
9379
9380                    /* Assume DCL or foreign command exists */
9381                   /*--------------------------------------*/
9382                   tchr = strrchr(tmpspec, '/');
9383                   if (tchr != NULL) {
9384                     tchr++;
9385                   }
9386                   else {
9387                     tchr = tmpspec;
9388                   }
9389                   strcpy(image_name, tchr);
9390                 }
9391               }
9392             }
9393           }
9394         }
9395         fclose(fp);
9396       }
9397       if (check_img && isdcl) return RMS$_FNF;
9398
9399       if (cando_by_name(S_IXUSR,0,resspec)) {
9400         vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9401         if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9402         if (!isdcl) {
9403             strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9404             if (image_name[0] != 0) {
9405                 strcat(vmscmd->dsc$a_pointer, image_name);
9406                 strcat(vmscmd->dsc$a_pointer, " ");
9407             }
9408         } else if (image_name[0] != 0) {
9409             strcpy(vmscmd->dsc$a_pointer, image_name);
9410             strcat(vmscmd->dsc$a_pointer, " ");
9411         } else {
9412             strcpy(vmscmd->dsc$a_pointer,"@");
9413         }
9414         if (suggest_quote) *suggest_quote = 1;
9415
9416         /* If there is an image name, use original command */
9417         if (image_name[0] == 0)
9418             strcat(vmscmd->dsc$a_pointer,resspec);
9419         else {
9420             rest = cmd;
9421             while (*rest && isspace(*rest)) rest++;
9422         }
9423
9424         if (image_argv[0] != 0) {
9425           strcat(vmscmd->dsc$a_pointer,image_argv);
9426           strcat(vmscmd->dsc$a_pointer, " ");
9427         }
9428         if (rest) {
9429            int rest_len;
9430            int vmscmd_len;
9431
9432            rest_len = strlen(rest);
9433            vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9434            if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9435               strcat(vmscmd->dsc$a_pointer,rest);
9436            else
9437              retsts = CLI$_BUFOVF;
9438         }
9439         vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9440         PerlMem_free(cmd);
9441         return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9442       }
9443       else
9444         retsts = RMS$_PRV;
9445     }
9446   }
9447   /* It's either a DCL command or we couldn't find a suitable image */
9448   vmscmd->dsc$w_length = strlen(cmd);
9449
9450   vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9451   strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9452   vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9453
9454   PerlMem_free(cmd);
9455
9456   /* check if it's a symbol (for quoting purposes) */
9457   if (suggest_quote && !*suggest_quote) {
9458     int iss;
9459     char equiv[LNM$C_NAMLENGTH];
9460     struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9461     eqvdsc.dsc$a_pointer = equiv;
9462
9463     iss = lib$get_symbol(vmscmd,&eqvdsc);
9464     if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9465   }
9466   if (!(retsts & 1)) {
9467     /* just hand off status values likely to be due to user error */
9468     if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9469         retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9470        (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9471     else { _ckvmssts(retsts); }
9472   }
9473
9474   return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9475
9476 }  /* end of setup_cmddsc() */
9477
9478
9479 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9480 bool
9481 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9482 {
9483 bool exec_sts;
9484 char * cmd;
9485
9486   if (sp > mark) {
9487     if (vfork_called) {           /* this follows a vfork - act Unixish */
9488       vfork_called--;
9489       if (vfork_called < 0) {
9490         Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9491         vfork_called = 0;
9492       }
9493       else return do_aexec(really,mark,sp);
9494     }
9495                                            /* no vfork - act VMSish */
9496     cmd = setup_argstr(aTHX_ really,mark,sp);
9497     exec_sts = vms_do_exec(cmd);
9498     Safefree(cmd);  /* Clean up from setup_argstr() */
9499     return exec_sts;
9500   }
9501
9502   return FALSE;
9503 }  /* end of vms_do_aexec() */
9504 /*}}}*/
9505
9506 /* {{{bool vms_do_exec(char *cmd) */
9507 bool
9508 Perl_vms_do_exec(pTHX_ const char *cmd)
9509 {
9510   struct dsc$descriptor_s *vmscmd;
9511
9512   if (vfork_called) {             /* this follows a vfork - act Unixish */
9513     vfork_called--;
9514     if (vfork_called < 0) {
9515       Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9516       vfork_called = 0;
9517     }
9518     else return do_exec(cmd);
9519   }
9520
9521   {                               /* no vfork - act VMSish */
9522     unsigned long int retsts;
9523
9524     TAINT_ENV();
9525     TAINT_PROPER("exec");
9526     if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9527       retsts = lib$do_command(vmscmd);
9528
9529     switch (retsts) {
9530       case RMS$_FNF: case RMS$_DNF:
9531         set_errno(ENOENT); break;
9532       case RMS$_DIR:
9533         set_errno(ENOTDIR); break;
9534       case RMS$_DEV:
9535         set_errno(ENODEV); break;
9536       case RMS$_PRV:
9537         set_errno(EACCES); break;
9538       case RMS$_SYN:
9539         set_errno(EINVAL); break;
9540       case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9541         set_errno(E2BIG); break;
9542       case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9543         _ckvmssts(retsts); /* fall through */
9544       default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9545         set_errno(EVMSERR);
9546     }
9547     set_vaxc_errno(retsts);
9548     if (ckWARN(WARN_EXEC)) {
9549       Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9550              vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9551     }
9552     vms_execfree(vmscmd);
9553   }
9554
9555   return FALSE;
9556
9557 }  /* end of vms_do_exec() */
9558 /*}}}*/
9559
9560 unsigned long int Perl_do_spawn(pTHX_ const char *);
9561
9562 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9563 unsigned long int
9564 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9565 {
9566 unsigned long int sts;
9567 char * cmd;
9568
9569   if (sp > mark) {
9570     cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9571     sts = do_spawn(cmd);
9572     /* pp_sys will clean up cmd */
9573     return sts;
9574   }
9575   return SS$_ABORT;
9576 }  /* end of do_aspawn() */
9577 /*}}}*/
9578
9579 /* {{{unsigned long int do_spawn(char *cmd) */
9580 unsigned long int
9581 Perl_do_spawn(pTHX_ const char *cmd)
9582 {
9583   unsigned long int sts, substs;
9584
9585   /* The caller of this routine expects to Safefree(PL_Cmd) */
9586   Newx(PL_Cmd,10,char);
9587
9588   TAINT_ENV();
9589   TAINT_PROPER("spawn");
9590   if (!cmd || !*cmd) {
9591     sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9592     if (!(sts & 1)) {
9593       switch (sts) {
9594         case RMS$_FNF:  case RMS$_DNF:
9595           set_errno(ENOENT); break;
9596         case RMS$_DIR:
9597           set_errno(ENOTDIR); break;
9598         case RMS$_DEV:
9599           set_errno(ENODEV); break;
9600         case RMS$_PRV:
9601           set_errno(EACCES); break;
9602         case RMS$_SYN:
9603           set_errno(EINVAL); break;
9604         case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9605           set_errno(E2BIG); break;
9606         case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9607           _ckvmssts(sts); /* fall through */
9608         default:  /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9609           set_errno(EVMSERR);
9610       }
9611       set_vaxc_errno(sts);
9612       if (ckWARN(WARN_EXEC)) {
9613         Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9614                     Strerror(errno));
9615       }
9616     }
9617     sts = substs;
9618   }
9619   else {
9620     PerlIO * fp;
9621     fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9622     if (fp != NULL)
9623       my_pclose(fp);
9624   }
9625   return sts;
9626 }  /* end of do_spawn() */
9627 /*}}}*/
9628
9629
9630 static unsigned int *sockflags, sockflagsize;
9631
9632 /*
9633  * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9634  * routines found in some versions of the CRTL can't deal with sockets.
9635  * We don't shim the other file open routines since a socket isn't
9636  * likely to be opened by a name.
9637  */
9638 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9639 FILE *my_fdopen(int fd, const char *mode)
9640 {
9641   FILE *fp = fdopen(fd, mode);
9642
9643   if (fp) {
9644     unsigned int fdoff = fd / sizeof(unsigned int);
9645     Stat_t sbuf; /* native stat; we don't need flex_stat */
9646     if (!sockflagsize || fdoff > sockflagsize) {
9647       if (sockflags) Renew(     sockflags,fdoff+2,unsigned int);
9648       else           Newx  (sockflags,fdoff+2,unsigned int);
9649       memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9650       sockflagsize = fdoff + 2;
9651     }
9652     if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9653       sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9654   }
9655   return fp;
9656
9657 }
9658 /*}}}*/
9659
9660
9661 /*
9662  * Clear the corresponding bit when the (possibly) socket stream is closed.
9663  * There still a small hole: we miss an implicit close which might occur
9664  * via freopen().  >> Todo
9665  */
9666 /*{{{ int my_fclose(FILE *fp)*/
9667 int my_fclose(FILE *fp) {
9668   if (fp) {
9669     unsigned int fd = fileno(fp);
9670     unsigned int fdoff = fd / sizeof(unsigned int);
9671
9672     if (sockflagsize && fdoff <= sockflagsize)
9673       sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9674   }
9675   return fclose(fp);
9676 }
9677 /*}}}*/
9678
9679
9680 /*
9681  * A simple fwrite replacement which outputs itmsz*nitm chars without
9682  * introducing record boundaries every itmsz chars.
9683  * We are using fputs, which depends on a terminating null.  We may
9684  * well be writing binary data, so we need to accommodate not only
9685  * data with nulls sprinkled in the middle but also data with no null
9686  * byte at the end.
9687  */
9688 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9689 int
9690 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9691 {
9692   register char *cp, *end, *cpd, *data;
9693   register unsigned int fd = fileno(dest);
9694   register unsigned int fdoff = fd / sizeof(unsigned int);
9695   int retval;
9696   int bufsize = itmsz * nitm + 1;
9697
9698   if (fdoff < sockflagsize &&
9699       (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9700     if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9701     return nitm;
9702   }
9703
9704   _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9705   memcpy( data, src, itmsz*nitm );
9706   data[itmsz*nitm] = '\0';
9707
9708   end = data + itmsz * nitm;
9709   retval = (int) nitm; /* on success return # items written */
9710
9711   cpd = data;
9712   while (cpd <= end) {
9713     for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9714     if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9715     if (cp < end)
9716       if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9717     cpd = cp + 1;
9718   }
9719
9720   if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9721   return retval;
9722
9723 }  /* end of my_fwrite() */
9724 /*}}}*/
9725
9726 /*{{{ int my_flush(FILE *fp)*/
9727 int
9728 Perl_my_flush(pTHX_ FILE *fp)
9729 {
9730     int res;
9731     if ((res = fflush(fp)) == 0 && fp) {
9732 #ifdef VMS_DO_SOCKETS
9733         Stat_t s;
9734         if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9735 #endif
9736             res = fsync(fileno(fp));
9737     }
9738 /*
9739  * If the flush succeeded but set end-of-file, we need to clear
9740  * the error because our caller may check ferror().  BTW, this
9741  * probably means we just flushed an empty file.
9742  */
9743     if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9744
9745     return res;
9746 }
9747 /*}}}*/
9748
9749 /*
9750  * Here are replacements for the following Unix routines in the VMS environment:
9751  *      getpwuid    Get information for a particular UIC or UID
9752  *      getpwnam    Get information for a named user
9753  *      getpwent    Get information for each user in the rights database
9754  *      setpwent    Reset search to the start of the rights database
9755  *      endpwent    Finish searching for users in the rights database
9756  *
9757  * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9758  * (defined in pwd.h), which contains the following fields:-
9759  *      struct passwd {
9760  *              char        *pw_name;    Username (in lower case)
9761  *              char        *pw_passwd;  Hashed password
9762  *              unsigned int pw_uid;     UIC
9763  *              unsigned int pw_gid;     UIC group  number
9764  *              char        *pw_unixdir; Default device/directory (VMS-style)
9765  *              char        *pw_gecos;   Owner name
9766  *              char        *pw_dir;     Default device/directory (Unix-style)
9767  *              char        *pw_shell;   Default CLI name (eg. DCL)
9768  *      };
9769  * If the specified user does not exist, getpwuid and getpwnam return NULL.
9770  *
9771  * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9772  * not the UIC member number (eg. what's returned by getuid()),
9773  * getpwuid() can accept either as input (if uid is specified, the caller's
9774  * UIC group is used), though it won't recognise gid=0.
9775  *
9776  * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9777  * information about other users in your group or in other groups, respectively.
9778  * If the required privilege is not available, then these routines fill only
9779  * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9780  * string).
9781  *
9782  * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9783  */
9784
9785 /* sizes of various UAF record fields */
9786 #define UAI$S_USERNAME 12
9787 #define UAI$S_IDENT    31
9788 #define UAI$S_OWNER    31
9789 #define UAI$S_DEFDEV   31
9790 #define UAI$S_DEFDIR   63
9791 #define UAI$S_DEFCLI   31
9792 #define UAI$S_PWD       8
9793
9794 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT  && \
9795                         (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9796                         (uic).uic$v_group  != UIC$K_WILD_GROUP)
9797
9798 static char __empty[]= "";
9799 static struct passwd __passwd_empty=
9800     {(char *) __empty, (char *) __empty, 0, 0,
9801      (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9802 static int contxt= 0;
9803 static struct passwd __pwdcache;
9804 static char __pw_namecache[UAI$S_IDENT+1];
9805
9806 /*
9807  * This routine does most of the work extracting the user information.
9808  */
9809 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9810 {
9811     static struct {
9812         unsigned char length;
9813         char pw_gecos[UAI$S_OWNER+1];
9814     } owner;
9815     static union uicdef uic;
9816     static struct {
9817         unsigned char length;
9818         char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9819     } defdev;
9820     static struct {
9821         unsigned char length;
9822         char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9823     } defdir;
9824     static struct {
9825         unsigned char length;
9826         char pw_shell[UAI$S_DEFCLI+1];
9827     } defcli;
9828     static char pw_passwd[UAI$S_PWD+1];
9829
9830     static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9831     struct dsc$descriptor_s name_desc;
9832     unsigned long int sts;
9833
9834     static struct itmlst_3 itmlst[]= {
9835         {UAI$S_OWNER+1,    UAI$_OWNER,  &owner,    &lowner},
9836         {sizeof(uic),      UAI$_UIC,    &uic,      &luic},
9837         {UAI$S_DEFDEV+1,   UAI$_DEFDEV, &defdev,   &ldefdev},
9838         {UAI$S_DEFDIR+1,   UAI$_DEFDIR, &defdir,   &ldefdir},
9839         {UAI$S_DEFCLI+1,   UAI$_DEFCLI, &defcli,   &ldefcli},
9840         {UAI$S_PWD,        UAI$_PWD,    pw_passwd, &lpwd},
9841         {0,                0,           NULL,    NULL}};
9842
9843     name_desc.dsc$w_length=  strlen(name);
9844     name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9845     name_desc.dsc$b_class=   DSC$K_CLASS_S;
9846     name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9847
9848 /*  Note that sys$getuai returns many fields as counted strings. */
9849     sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9850     if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9851       set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9852     }
9853     else { _ckvmssts(sts); }
9854     if (!(sts & 1)) return 0;  /* out here in case _ckvmssts() doesn't abort */
9855
9856     if ((int) owner.length  < lowner)  lowner=  (int) owner.length;
9857     if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9858     if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9859     if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9860     memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9861     owner.pw_gecos[lowner]=            '\0';
9862     defdev.pw_dir[ldefdev+ldefdir]= '\0';
9863     defcli.pw_shell[ldefcli]=          '\0';
9864     if (valid_uic(uic)) {
9865         pwd->pw_uid= uic.uic$l_uic;
9866         pwd->pw_gid= uic.uic$v_group;
9867     }
9868     else
9869       Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9870     pwd->pw_passwd=  pw_passwd;
9871     pwd->pw_gecos=   owner.pw_gecos;
9872     pwd->pw_dir=     defdev.pw_dir;
9873     pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9874     pwd->pw_shell=   defcli.pw_shell;
9875     if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9876         int ldir;
9877         ldir= strlen(pwd->pw_unixdir) - 1;
9878         if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9879     }
9880     else
9881         strcpy(pwd->pw_unixdir, pwd->pw_dir);
9882     if (!decc_efs_case_preserve)
9883         __mystrtolower(pwd->pw_unixdir);
9884     return 1;
9885 }
9886
9887 /*
9888  * Get information for a named user.
9889 */
9890 /*{{{struct passwd *getpwnam(char *name)*/
9891 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9892 {
9893     struct dsc$descriptor_s name_desc;
9894     union uicdef uic;
9895     unsigned long int status, sts;
9896
9897     __pwdcache = __passwd_empty;
9898     if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9899       /* We still may be able to determine pw_uid and pw_gid */
9900       name_desc.dsc$w_length=  strlen(name);
9901       name_desc.dsc$b_dtype=   DSC$K_DTYPE_T;
9902       name_desc.dsc$b_class=   DSC$K_CLASS_S;
9903       name_desc.dsc$a_pointer= (char *) name;
9904       if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9905         __pwdcache.pw_uid= uic.uic$l_uic;
9906         __pwdcache.pw_gid= uic.uic$v_group;
9907       }
9908       else {
9909         if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9910           set_vaxc_errno(sts);
9911           set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9912           return NULL;
9913         }
9914         else { _ckvmssts(sts); }
9915       }
9916     }
9917     strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9918     __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9919     __pwdcache.pw_name= __pw_namecache;
9920     return &__pwdcache;
9921 }  /* end of my_getpwnam() */
9922 /*}}}*/
9923
9924 /*
9925  * Get information for a particular UIC or UID.
9926  * Called by my_getpwent with uid=-1 to list all users.
9927 */
9928 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9929 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9930 {
9931     const $DESCRIPTOR(name_desc,__pw_namecache);
9932     unsigned short lname;
9933     union uicdef uic;
9934     unsigned long int status;
9935
9936     if (uid == (unsigned int) -1) {
9937       do {
9938         status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9939         if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9940           set_vaxc_errno(status);
9941           set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9942           my_endpwent();
9943           return NULL;
9944         }
9945         else { _ckvmssts(status); }
9946       } while (!valid_uic (uic));
9947     }
9948     else {
9949       uic.uic$l_uic= uid;
9950       if (!uic.uic$v_group)
9951         uic.uic$v_group= PerlProc_getgid();
9952       if (valid_uic(uic))
9953         status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9954       else status = SS$_IVIDENT;
9955       if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9956           status == RMS$_PRV) {
9957         set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9958         return NULL;
9959       }
9960       else { _ckvmssts(status); }
9961     }
9962     __pw_namecache[lname]= '\0';
9963     __mystrtolower(__pw_namecache);
9964
9965     __pwdcache = __passwd_empty;
9966     __pwdcache.pw_name = __pw_namecache;
9967
9968 /*  Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9969     The identifier's value is usually the UIC, but it doesn't have to be,
9970     so if we can, we let fillpasswd update this. */
9971     __pwdcache.pw_uid =  uic.uic$l_uic;
9972     __pwdcache.pw_gid =  uic.uic$v_group;
9973
9974     fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9975     return &__pwdcache;
9976
9977 }  /* end of my_getpwuid() */
9978 /*}}}*/
9979
9980 /*
9981  * Get information for next user.
9982 */
9983 /*{{{struct passwd *my_getpwent()*/
9984 struct passwd *Perl_my_getpwent(pTHX)
9985 {
9986     return (my_getpwuid((unsigned int) -1));
9987 }
9988 /*}}}*/
9989
9990 /*
9991  * Finish searching rights database for users.
9992 */
9993 /*{{{void my_endpwent()*/
9994 void Perl_my_endpwent(pTHX)
9995 {
9996     if (contxt) {
9997       _ckvmssts(sys$finish_rdb(&contxt));
9998       contxt= 0;
9999     }
10000 }
10001 /*}}}*/
10002
10003 #ifdef HOMEGROWN_POSIX_SIGNALS
10004   /* Signal handling routines, pulled into the core from POSIX.xs.
10005    *
10006    * We need these for threads, so they've been rolled into the core,
10007    * rather than left in POSIX.xs.
10008    *
10009    * (DRS, Oct 23, 1997)
10010    */
10011
10012   /* sigset_t is atomic under VMS, so these routines are easy */
10013 /*{{{int my_sigemptyset(sigset_t *) */
10014 int my_sigemptyset(sigset_t *set) {
10015     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10016     *set = 0; return 0;
10017 }
10018 /*}}}*/
10019
10020
10021 /*{{{int my_sigfillset(sigset_t *)*/
10022 int my_sigfillset(sigset_t *set) {
10023     int i;
10024     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10025     for (i = 0; i < NSIG; i++) *set |= (1 << i);
10026     return 0;
10027 }
10028 /*}}}*/
10029
10030
10031 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10032 int my_sigaddset(sigset_t *set, int sig) {
10033     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10034     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10035     *set |= (1 << (sig - 1));
10036     return 0;
10037 }
10038 /*}}}*/
10039
10040
10041 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10042 int my_sigdelset(sigset_t *set, int sig) {
10043     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10044     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10045     *set &= ~(1 << (sig - 1));
10046     return 0;
10047 }
10048 /*}}}*/
10049
10050
10051 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10052 int my_sigismember(sigset_t *set, int sig) {
10053     if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10054     if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10055     return *set & (1 << (sig - 1));
10056 }
10057 /*}}}*/
10058
10059
10060 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10061 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10062     sigset_t tempmask;
10063
10064     /* If set and oset are both null, then things are badly wrong. Bail out. */
10065     if ((oset == NULL) && (set == NULL)) {
10066       set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10067       return -1;
10068     }
10069
10070     /* If set's null, then we're just handling a fetch. */
10071     if (set == NULL) {
10072         tempmask = sigblock(0);
10073     }
10074     else {
10075       switch (how) {
10076       case SIG_SETMASK:
10077         tempmask = sigsetmask(*set);
10078         break;
10079       case SIG_BLOCK:
10080         tempmask = sigblock(*set);
10081         break;
10082       case SIG_UNBLOCK:
10083         tempmask = sigblock(0);
10084         sigsetmask(*oset & ~tempmask);
10085         break;
10086       default:
10087         set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10088         return -1;
10089       }
10090     }
10091
10092     /* Did they pass us an oset? If so, stick our holding mask into it */
10093     if (oset)
10094       *oset = tempmask;
10095
10096     return 0;
10097 }
10098 /*}}}*/
10099 #endif  /* HOMEGROWN_POSIX_SIGNALS */
10100
10101
10102 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10103  * my_utime(), and flex_stat(), all of which operate on UTC unless
10104  * VMSISH_TIMES is true.
10105  */
10106 /* method used to handle UTC conversions:
10107  *   1 == CRTL gmtime();  2 == SYS$TIMEZONE_DIFFERENTIAL;  3 == no correction
10108  */
10109 static int gmtime_emulation_type;
10110 /* number of secs to add to UTC POSIX-style time to get local time */
10111 static long int utc_offset_secs;
10112
10113 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10114  * in vmsish.h.  #undef them here so we can call the CRTL routines
10115  * directly.
10116  */
10117 #undef gmtime
10118 #undef localtime
10119 #undef time
10120
10121
10122 /*
10123  * DEC C previous to 6.0 corrupts the behavior of the /prefix
10124  * qualifier with the extern prefix pragma.  This provisional
10125  * hack circumvents this prefix pragma problem in previous
10126  * precompilers.
10127  */
10128 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10129 #  if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10130 #    pragma __extern_prefix save
10131 #    pragma __extern_prefix ""  /* set to empty to prevent prefixing */
10132 #    define gmtime decc$__utctz_gmtime
10133 #    define localtime decc$__utctz_localtime
10134 #    define time decc$__utc_time
10135 #    pragma __extern_prefix restore
10136
10137      struct tm *gmtime(), *localtime();
10138
10139 #  endif
10140 #endif
10141
10142
10143 static time_t toutc_dst(time_t loc) {
10144   struct tm *rsltmp;
10145
10146   if ((rsltmp = localtime(&loc)) == NULL) return -1;
10147   loc -= utc_offset_secs;
10148   if (rsltmp->tm_isdst) loc -= 3600;
10149   return loc;
10150 }
10151 #define _toutc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10152        ((gmtime_emulation_type || my_time(NULL)), \
10153        (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10154        ((secs) - utc_offset_secs))))
10155
10156 static time_t toloc_dst(time_t utc) {
10157   struct tm *rsltmp;
10158
10159   utc += utc_offset_secs;
10160   if ((rsltmp = localtime(&utc)) == NULL) return -1;
10161   if (rsltmp->tm_isdst) utc += 3600;
10162   return utc;
10163 }
10164 #define _toloc(secs)  ((secs) == (time_t) -1 ? (time_t) -1 : \
10165        ((gmtime_emulation_type || my_time(NULL)), \
10166        (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10167        ((secs) + utc_offset_secs))))
10168
10169 #ifndef RTL_USES_UTC
10170 /*
10171
10172     ucx$tz = "EST5EDT4,M4.1.0,M10.5.0"  typical
10173         DST starts on 1st sun of april      at 02:00  std time
10174             ends on last sun of october     at 02:00  dst time
10175     see the UCX management command reference, SET CONFIG TIMEZONE
10176     for formatting info.
10177
10178     No, it's not as general as it should be, but then again, NOTHING
10179     will handle UK times in a sensible way.
10180 */
10181
10182
10183 /*
10184     parse the DST start/end info:
10185     (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10186 */
10187
10188 static char *
10189 tz_parse_startend(char *s, struct tm *w, int *past)
10190 {
10191     int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10192     int ly, dozjd, d, m, n, hour, min, sec, j, k;
10193     time_t g;
10194
10195     if (!s)    return 0;
10196     if (!w) return 0;
10197     if (!past) return 0;
10198
10199     ly = 0;
10200     if (w->tm_year % 4        == 0) ly = 1;
10201     if (w->tm_year % 100      == 0) ly = 0;
10202     if (w->tm_year+1900 % 400 == 0) ly = 1;
10203     if (ly) dinm[1]++;
10204
10205     dozjd = isdigit(*s);
10206     if (*s == 'J' || *s == 'j' || dozjd) {
10207         if (!dozjd && !isdigit(*++s)) return 0;
10208         d = *s++ - '0';
10209         if (isdigit(*s)) {
10210             d = d*10 + *s++ - '0';
10211             if (isdigit(*s)) {
10212                 d = d*10 + *s++ - '0';
10213             }
10214         }
10215         if (d == 0) return 0;
10216         if (d > 366) return 0;
10217         d--;
10218         if (!dozjd && d > 58 && ly) d++;  /* after 28 feb */
10219         g = d * 86400;
10220         dozjd = 1;
10221     } else if (*s == 'M' || *s == 'm') {
10222         if (!isdigit(*++s)) return 0;
10223         m = *s++ - '0';
10224         if (isdigit(*s)) m = 10*m + *s++ - '0';
10225         if (*s != '.') return 0;
10226         if (!isdigit(*++s)) return 0;
10227         n = *s++ - '0';
10228         if (n < 1 || n > 5) return 0;
10229         if (*s != '.') return 0;
10230         if (!isdigit(*++s)) return 0;
10231         d = *s++ - '0';
10232         if (d > 6) return 0;
10233     }
10234
10235     if (*s == '/') {
10236         if (!isdigit(*++s)) return 0;
10237         hour = *s++ - '0';
10238         if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10239         if (*s == ':') {
10240             if (!isdigit(*++s)) return 0;
10241             min = *s++ - '0';
10242             if (isdigit(*s)) min = 10*min + *s++ - '0';
10243             if (*s == ':') {
10244                 if (!isdigit(*++s)) return 0;
10245                 sec = *s++ - '0';
10246                 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10247             }
10248         }
10249     } else {
10250         hour = 2;
10251         min = 0;
10252         sec = 0;
10253     }
10254
10255     if (dozjd) {
10256         if (w->tm_yday < d) goto before;
10257         if (w->tm_yday > d) goto after;
10258     } else {
10259         if (w->tm_mon+1 < m) goto before;
10260         if (w->tm_mon+1 > m) goto after;
10261
10262         j = (42 + w->tm_wday - w->tm_mday)%7;   /*dow of mday 0 */
10263         k = d - j; /* mday of first d */
10264         if (k <= 0) k += 7;
10265         k += 7 * ((n>4?4:n)-1);  /* mday of n'th d */
10266         if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10267         if (w->tm_mday < k) goto before;
10268         if (w->tm_mday > k) goto after;
10269     }
10270
10271     if (w->tm_hour < hour) goto before;
10272     if (w->tm_hour > hour) goto after;
10273     if (w->tm_min  < min)  goto before;
10274     if (w->tm_min  > min)  goto after;
10275     if (w->tm_sec  < sec)  goto before;
10276     goto after;
10277
10278 before:
10279     *past = 0;
10280     return s;
10281 after:
10282     *past = 1;
10283     return s;
10284 }
10285
10286
10287
10288
10289 /*  parse the offset:   (+|-)hh[:mm[:ss]]  */
10290
10291 static char *
10292 tz_parse_offset(char *s, int *offset)
10293 {
10294     int hour = 0, min = 0, sec = 0;
10295     int neg = 0;
10296     if (!s) return 0;
10297     if (!offset) return 0;
10298
10299     if (*s == '-') {neg++; s++;}
10300     if (*s == '+') s++;
10301     if (!isdigit(*s)) return 0;
10302     hour = *s++ - '0';
10303     if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10304     if (hour > 24) return 0;
10305     if (*s == ':') {
10306         if (!isdigit(*++s)) return 0;
10307         min = *s++ - '0';
10308         if (isdigit(*s)) min = min*10 + (*s++ - '0');
10309         if (min > 59) return 0;
10310         if (*s == ':') {
10311             if (!isdigit(*++s)) return 0;
10312             sec = *s++ - '0';
10313             if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10314             if (sec > 59) return 0;
10315         }
10316     }
10317
10318     *offset = (hour*60+min)*60 + sec;
10319     if (neg) *offset = -*offset;
10320     return s;
10321 }
10322
10323 /*
10324     input time is w, whatever type of time the CRTL localtime() uses.
10325     sets dst, the zone, and the gmtoff (seconds)
10326
10327     caches the value of TZ and UCX$TZ env variables; note that
10328     my_setenv looks for these and sets a flag if they're changed
10329     for efficiency.
10330
10331     We have to watch out for the "australian" case (dst starts in
10332     october, ends in april)...flagged by "reverse" and checked by
10333     scanning through the months of the previous year.
10334
10335 */
10336
10337 static int
10338 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10339 {
10340     time_t when;
10341     struct tm *w2;
10342     char *s,*s2;
10343     char *dstzone, *tz, *s_start, *s_end;
10344     int std_off, dst_off, isdst;
10345     int y, dststart, dstend;
10346     static char envtz[1025];  /* longer than any logical, symbol, ... */
10347     static char ucxtz[1025];
10348     static char reversed = 0;
10349
10350     if (!w) return 0;
10351
10352     if (tz_updated) {
10353         tz_updated = 0;
10354         reversed = -1;  /* flag need to check  */
10355         envtz[0] = ucxtz[0] = '\0';
10356         tz = my_getenv("TZ",0);
10357         if (tz) strcpy(envtz, tz);
10358         tz = my_getenv("UCX$TZ",0);
10359         if (tz) strcpy(ucxtz, tz);
10360         if (!envtz[0] && !ucxtz[0]) return 0;  /* we give up */
10361     }
10362     tz = envtz;
10363     if (!*tz) tz = ucxtz;
10364
10365     s = tz;
10366     while (isalpha(*s)) s++;
10367     s = tz_parse_offset(s, &std_off);
10368     if (!s) return 0;
10369     if (!*s) {                  /* no DST, hurray we're done! */
10370         isdst = 0;
10371         goto done;
10372     }
10373
10374     dstzone = s;
10375     while (isalpha(*s)) s++;
10376     s2 = tz_parse_offset(s, &dst_off);
10377     if (s2) {
10378         s = s2;
10379     } else {
10380         dst_off = std_off - 3600;
10381     }
10382
10383     if (!*s) {      /* default dst start/end?? */
10384         if (tz != ucxtz) {          /* if TZ tells zone only, UCX$TZ tells rule */
10385             s = strchr(ucxtz,',');
10386         }
10387         if (!s || !*s) s = ",M4.1.0,M10.5.0";   /* we know we do dst, default rule */
10388     }
10389     if (*s != ',') return 0;
10390
10391     when = *w;
10392     when = _toutc(when);      /* convert to utc */
10393     when = when - std_off;    /* convert to pseudolocal time*/
10394
10395     w2 = localtime(&when);
10396     y = w2->tm_year;
10397     s_start = s+1;
10398     s = tz_parse_startend(s_start,w2,&dststart);
10399     if (!s) return 0;
10400     if (*s != ',') return 0;
10401
10402     when = *w;
10403     when = _toutc(when);      /* convert to utc */
10404     when = when - dst_off;    /* convert to pseudolocal time*/
10405     w2 = localtime(&when);
10406     if (w2->tm_year != y) {   /* spans a year, just check one time */
10407         when += dst_off - std_off;
10408         w2 = localtime(&when);
10409     }
10410     s_end = s+1;
10411     s = tz_parse_startend(s_end,w2,&dstend);
10412     if (!s) return 0;
10413
10414     if (reversed == -1) {  /* need to check if start later than end */
10415         int j, ds, de;
10416
10417         when = *w;
10418         if (when < 2*365*86400) {
10419             when += 2*365*86400;
10420         } else {
10421             when -= 365*86400;
10422         }
10423         w2 =localtime(&when);
10424         when = when + (15 - w2->tm_yday) * 86400;   /* jan 15 */
10425
10426         for (j = 0; j < 12; j++) {
10427             w2 =localtime(&when);
10428             tz_parse_startend(s_start,w2,&ds);
10429             tz_parse_startend(s_end,w2,&de);
10430             if (ds != de) break;
10431             when += 30*86400;
10432         }
10433         reversed = 0;
10434         if (de && !ds) reversed = 1;
10435     }
10436
10437     isdst = dststart && !dstend;
10438     if (reversed) isdst = dststart  || !dstend;
10439
10440 done:
10441     if (dst)    *dst = isdst;
10442     if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10443     if (isdst)  tz = dstzone;
10444     if (zone) {
10445         while(isalpha(*tz))  *zone++ = *tz++;
10446         *zone = '\0';
10447     }
10448     return 1;
10449 }
10450
10451 #endif /* !RTL_USES_UTC */
10452
10453 /* my_time(), my_localtime(), my_gmtime()
10454  * By default traffic in UTC time values, using CRTL gmtime() or
10455  * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10456  * Note: We need to use these functions even when the CRTL has working
10457  * UTC support, since they also handle C<use vmsish qw(times);>
10458  *
10459  * Contributed by Chuck Lane  <lane@duphy4.physics.drexel.edu>
10460  * Modified by Charles Bailey <bailey@newman.upenn.edu>
10461  */
10462
10463 /*{{{time_t my_time(time_t *timep)*/
10464 time_t Perl_my_time(pTHX_ time_t *timep)
10465 {
10466   time_t when;
10467   struct tm *tm_p;
10468
10469   if (gmtime_emulation_type == 0) {
10470     int dstnow;
10471     time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between    */
10472                               /* results of calls to gmtime() and localtime() */
10473                               /* for same &base */
10474
10475     gmtime_emulation_type++;
10476     if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10477       char off[LNM$C_NAMLENGTH+1];;
10478
10479       gmtime_emulation_type++;
10480       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10481         gmtime_emulation_type++;
10482         utc_offset_secs = 0;
10483         Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10484       }
10485       else { utc_offset_secs = atol(off); }
10486     }
10487     else { /* We've got a working gmtime() */
10488       struct tm gmt, local;
10489
10490       gmt = *tm_p;
10491       tm_p = localtime(&base);
10492       local = *tm_p;
10493       utc_offset_secs  = (local.tm_mday - gmt.tm_mday) * 86400;
10494       utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10495       utc_offset_secs += (local.tm_min  - gmt.tm_min)  * 60;
10496       utc_offset_secs += (local.tm_sec  - gmt.tm_sec);
10497     }
10498   }
10499
10500   when = time(NULL);
10501 # ifdef VMSISH_TIME
10502 # ifdef RTL_USES_UTC
10503   if (VMSISH_TIME) when = _toloc(when);
10504 # else
10505   if (!VMSISH_TIME) when = _toutc(when);
10506 # endif
10507 # endif
10508   if (timep != NULL) *timep = when;
10509   return when;
10510
10511 }  /* end of my_time() */
10512 /*}}}*/
10513
10514
10515 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10516 struct tm *
10517 Perl_my_gmtime(pTHX_ const time_t *timep)
10518 {
10519   char *p;
10520   time_t when;
10521   struct tm *rsltmp;
10522
10523   if (timep == NULL) {
10524     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10525     return NULL;
10526   }
10527   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10528
10529   when = *timep;
10530 # ifdef VMSISH_TIME
10531   if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10532 #  endif
10533 # ifdef RTL_USES_UTC  /* this implies that the CRTL has a working gmtime() */
10534   return gmtime(&when);
10535 # else
10536   /* CRTL localtime() wants local time as input, so does no tz correction */
10537   rsltmp = localtime(&when);
10538   if (rsltmp) rsltmp->tm_isdst = 0;  /* We already took DST into account */
10539   return rsltmp;
10540 #endif
10541 }  /* end of my_gmtime() */
10542 /*}}}*/
10543
10544
10545 /*{{{struct tm *my_localtime(const time_t *timep)*/
10546 struct tm *
10547 Perl_my_localtime(pTHX_ const time_t *timep)
10548 {
10549   time_t when, whenutc;
10550   struct tm *rsltmp;
10551   int dst, offset;
10552
10553   if (timep == NULL) {
10554     set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10555     return NULL;
10556   }
10557   if (*timep == 0) gmtime_emulation_type = 0;  /* possibly reset TZ */
10558   if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10559
10560   when = *timep;
10561 # ifdef RTL_USES_UTC
10562 # ifdef VMSISH_TIME
10563   if (VMSISH_TIME) when = _toutc(when);
10564 # endif
10565   /* CRTL localtime() wants UTC as input, does tz correction itself */
10566   return localtime(&when);
10567
10568 # else /* !RTL_USES_UTC */
10569   whenutc = when;
10570 # ifdef VMSISH_TIME
10571   if (!VMSISH_TIME) when = _toloc(whenutc);  /*  input was UTC */
10572   if (VMSISH_TIME) whenutc = _toutc(when);   /*  input was truelocal */
10573 # endif
10574   dst = -1;
10575 #ifndef RTL_USES_UTC
10576   if (tz_parse(aTHX_ &when, &dst, 0, &offset)) {   /* truelocal determines DST*/
10577       when = whenutc - offset;                   /* pseudolocal time*/
10578   }
10579 # endif
10580   /* CRTL localtime() wants local time as input, so does no tz correction */
10581   rsltmp = localtime(&when);
10582   if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10583   return rsltmp;
10584 # endif
10585
10586 } /*  end of my_localtime() */
10587 /*}}}*/
10588
10589 /* Reset definitions for later calls */
10590 #define gmtime(t)    my_gmtime(t)
10591 #define localtime(t) my_localtime(t)
10592 #define time(t)      my_time(t)
10593
10594
10595 /* my_utime - update modification/access time of a file
10596  *
10597  * VMS 7.3 and later implementation
10598  * Only the UTC translation is home-grown. The rest is handled by the
10599  * CRTL utime(), which will take into account the relevant feature
10600  * logicals and ODS-5 volume characteristics for true access times.
10601  *
10602  * pre VMS 7.3 implementation:
10603  * The calling sequence is identical to POSIX utime(), but under
10604  * VMS with ODS-2, only the modification time is changed; ODS-2 does
10605  * not maintain access times.  Restrictions differ from the POSIX
10606  * definition in that the time can be changed as long as the
10607  * caller has permission to execute the necessary IO$_MODIFY $QIO;
10608  * no separate checks are made to insure that the caller is the
10609  * owner of the file or has special privs enabled.
10610  * Code here is based on Joe Meadows' FILE utility.
10611  *
10612  */
10613
10614 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10615  *              to VMS epoch  (01-JAN-1858 00:00:00.00)
10616  * in 100 ns intervals.
10617  */
10618 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10619
10620 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10621 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10622 {
10623 #if __CRTL_VER >= 70300000
10624   struct utimbuf utc_utimes, *utc_utimesp;
10625
10626   if (utimes != NULL) {
10627     utc_utimes.actime = utimes->actime;
10628     utc_utimes.modtime = utimes->modtime;
10629 # ifdef VMSISH_TIME
10630     /* If input was local; convert to UTC for sys svc */
10631     if (VMSISH_TIME) {
10632       utc_utimes.actime = _toutc(utimes->actime);
10633       utc_utimes.modtime = _toutc(utimes->modtime);
10634     }
10635 # endif
10636     utc_utimesp = &utc_utimes;
10637   }
10638   else {
10639     utc_utimesp = NULL;
10640   }
10641
10642   return utime(file, utc_utimesp);
10643
10644 #else /* __CRTL_VER < 70300000 */
10645
10646   register int i;
10647   int sts;
10648   long int bintime[2], len = 2, lowbit, unixtime,
10649            secscale = 10000000; /* seconds --> 100 ns intervals */
10650   unsigned long int chan, iosb[2], retsts;
10651   char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10652   struct FAB myfab = cc$rms_fab;
10653   struct NAM mynam = cc$rms_nam;
10654 #if defined (__DECC) && defined (__VAX)
10655   /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10656    * at least through VMS V6.1, which causes a type-conversion warning.
10657    */
10658 #  pragma message save
10659 #  pragma message disable cvtdiftypes
10660 #endif
10661   struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10662   struct fibdef myfib;
10663 #if defined (__DECC) && defined (__VAX)
10664   /* This should be right after the declaration of myatr, but due
10665    * to a bug in VAX DEC C, this takes effect a statement early.
10666    */
10667 #  pragma message restore
10668 #endif
10669   /* cast ok for read only parameter */
10670   struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10671                         devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10672                         fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10673
10674   if (file == NULL || *file == '\0') {
10675     SETERRNO(ENOENT, LIB$_INVARG);
10676     return -1;
10677   }
10678
10679   /* Convert to VMS format ensuring that it will fit in 255 characters */
10680   if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10681       SETERRNO(ENOENT, LIB$_INVARG);
10682       return -1;
10683   }
10684   if (utimes != NULL) {
10685     /* Convert Unix time    (seconds since 01-JAN-1970 00:00:00.00)
10686      * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10687      * Since time_t is unsigned long int, and lib$emul takes a signed long int
10688      * as input, we force the sign bit to be clear by shifting unixtime right
10689      * one bit, then multiplying by an extra factor of 2 in lib$emul().
10690      */
10691     lowbit = (utimes->modtime & 1) ? secscale : 0;
10692     unixtime = (long int) utimes->modtime;
10693 #   ifdef VMSISH_TIME
10694     /* If input was UTC; convert to local for sys svc */
10695     if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10696 #   endif
10697     unixtime >>= 1;  secscale <<= 1;
10698     retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10699     if (!(retsts & 1)) {
10700       SETERRNO(EVMSERR, retsts);
10701       return -1;
10702     }
10703     retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10704     if (!(retsts & 1)) {
10705       SETERRNO(EVMSERR, retsts);
10706       return -1;
10707     }
10708   }
10709   else {
10710     /* Just get the current time in VMS format directly */
10711     retsts = sys$gettim(bintime);
10712     if (!(retsts & 1)) {
10713       SETERRNO(EVMSERR, retsts);
10714       return -1;
10715     }
10716   }
10717
10718   myfab.fab$l_fna = vmsspec;
10719   myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10720   myfab.fab$l_nam = &mynam;
10721   mynam.nam$l_esa = esa;
10722   mynam.nam$b_ess = (unsigned char) sizeof esa;
10723   mynam.nam$l_rsa = rsa;
10724   mynam.nam$b_rss = (unsigned char) sizeof rsa;
10725   if (decc_efs_case_preserve)
10726       mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10727
10728   /* Look for the file to be affected, letting RMS parse the file
10729    * specification for us as well.  I have set errno using only
10730    * values documented in the utime() man page for VMS POSIX.
10731    */
10732   retsts = sys$parse(&myfab,0,0);
10733   if (!(retsts & 1)) {
10734     set_vaxc_errno(retsts);
10735     if      (retsts == RMS$_PRV) set_errno(EACCES);
10736     else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10737     else                         set_errno(EVMSERR);
10738     return -1;
10739   }
10740   retsts = sys$search(&myfab,0,0);
10741   if (!(retsts & 1)) {
10742     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10743     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10744     set_vaxc_errno(retsts);
10745     if      (retsts == RMS$_PRV) set_errno(EACCES);
10746     else if (retsts == RMS$_FNF) set_errno(ENOENT);
10747     else                         set_errno(EVMSERR);
10748     return -1;
10749   }
10750
10751   devdsc.dsc$w_length = mynam.nam$b_dev;
10752   /* cast ok for read only parameter */
10753   devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10754
10755   retsts = sys$assign(&devdsc,&chan,0,0);
10756   if (!(retsts & 1)) {
10757     mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10758     myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10759     set_vaxc_errno(retsts);
10760     if      (retsts == SS$_IVDEVNAM)   set_errno(ENOTDIR);
10761     else if (retsts == SS$_NOPRIV)     set_errno(EACCES);
10762     else if (retsts == SS$_NOSUCHDEV)  set_errno(ENOTDIR);
10763     else                               set_errno(EVMSERR);
10764     return -1;
10765   }
10766
10767   fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10768   fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10769
10770   memset((void *) &myfib, 0, sizeof myfib);
10771 #if defined(__DECC) || defined(__DECCXX)
10772   for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10773   for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10774   /* This prevents the revision time of the file being reset to the current
10775    * time as a result of our IO$_MODIFY $QIO. */
10776   myfib.fib$l_acctl = FIB$M_NORECORD;
10777 #else
10778   for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10779   for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10780   myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10781 #endif
10782   retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10783   mynam.nam$b_nop |= NAM$M_SYNCHK;  mynam.nam$l_rlf = NULL;
10784   myfab.fab$b_dns = 0;  sts = sys$parse(&myfab,0,0);
10785   _ckvmssts(sys$dassgn(chan));
10786   if (retsts & 1) retsts = iosb[0];
10787   if (!(retsts & 1)) {
10788     set_vaxc_errno(retsts);
10789     if (retsts == SS$_NOPRIV) set_errno(EACCES);
10790     else                      set_errno(EVMSERR);
10791     return -1;
10792   }
10793
10794   return 0;
10795
10796 #endif /* #if __CRTL_VER >= 70300000 */
10797
10798 }  /* end of my_utime() */
10799 /*}}}*/
10800
10801 /*
10802  * flex_stat, flex_lstat, flex_fstat
10803  * basic stat, but gets it right when asked to stat
10804  * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10805  */
10806
10807 #ifndef _USE_STD_STAT
10808 /* encode_dev packs a VMS device name string into an integer to allow
10809  * simple comparisons. This can be used, for example, to check whether two
10810  * files are located on the same device, by comparing their encoded device
10811  * names. Even a string comparison would not do, because stat() reuses the
10812  * device name buffer for each call; so without encode_dev, it would be
10813  * necessary to save the buffer and use strcmp (this would mean a number of
10814  * changes to the standard Perl code, to say nothing of what a Perl script
10815  * would have to do.
10816  *
10817  * The device lock id, if it exists, should be unique (unless perhaps compared
10818  * with lock ids transferred from other nodes). We have a lock id if the disk is
10819  * mounted cluster-wide, which is when we tend to get long (host-qualified)
10820  * device names. Thus we use the lock id in preference, and only if that isn't
10821  * available, do we try to pack the device name into an integer (flagged by
10822  * the sign bit (LOCKID_MASK) being set).
10823  *
10824  * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10825  * name and its encoded form, but it seems very unlikely that we will find
10826  * two files on different disks that share the same encoded device names,
10827  * and even more remote that they will share the same file id (if the test
10828  * is to check for the same file).
10829  *
10830  * A better method might be to use sys$device_scan on the first call, and to
10831  * search for the device, returning an index into the cached array.
10832  * The number returned would be more intelligible.
10833  * This is probably not worth it, and anyway would take quite a bit longer
10834  * on the first call.
10835  */
10836 #define LOCKID_MASK 0x80000000     /* Use 0 to force device name use only */
10837 static mydev_t encode_dev (pTHX_ const char *dev)
10838 {
10839   int i;
10840   unsigned long int f;
10841   mydev_t enc;
10842   char c;
10843   const char *q;
10844
10845   if (!dev || !dev[0]) return 0;
10846
10847 #if LOCKID_MASK
10848   {
10849     struct dsc$descriptor_s dev_desc;
10850     unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10851
10852     /* For cluster-mounted disks, the disk lock identifier is unique, so we
10853        can try that first. */
10854     dev_desc.dsc$w_length =  strlen (dev);
10855     dev_desc.dsc$b_dtype =   DSC$K_DTYPE_T;
10856     dev_desc.dsc$b_class =   DSC$K_CLASS_S;
10857     dev_desc.dsc$a_pointer = (char *) dev;  /* Read only parameter */
10858     status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10859     if (!$VMS_STATUS_SUCCESS(status)) {
10860       switch (status) {
10861         case SS$_NOSUCHDEV:
10862           SETERRNO(ENODEV, status);
10863           return 0;
10864         default:
10865           _ckvmssts(status);
10866       }
10867     }
10868     if (lockid) return (lockid & ~LOCKID_MASK);
10869   }
10870 #endif
10871
10872   /* Otherwise we try to encode the device name */
10873   enc = 0;
10874   f = 1;
10875   i = 0;
10876   for (q = dev + strlen(dev); q--; q >= dev) {
10877     if (*q == ':')
10878         break;
10879     if (isdigit (*q))
10880       c= (*q) - '0';
10881     else if (isalpha (toupper (*q)))
10882       c= toupper (*q) - 'A' + (char)10;
10883     else
10884       continue; /* Skip '$'s */
10885     i++;
10886     if (i>6) break;     /* 36^7 is too large to fit in an unsigned long int */
10887     if (i>1) f *= 36;
10888     enc += f * (unsigned long int) c;
10889   }
10890   return (enc | LOCKID_MASK);  /* May have already overflowed into bit 31 */
10891
10892 }  /* end of encode_dev() */
10893 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10894         device_no = encode_dev(aTHX_ devname)
10895 #else
10896 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10897         device_no = new_dev_no
10898 #endif
10899
10900 static int
10901 is_null_device(name)
10902     const char *name;
10903 {
10904   if (decc_bug_devnull != 0) {
10905     if (strncmp("/dev/null", name, 9) == 0)
10906       return 1;
10907   }
10908     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10909        The underscore prefix, controller letter, and unit number are
10910        independently optional; for our purposes, the colon punctuation
10911        is not.  The colon can be trailed by optional directory and/or
10912        filename, but two consecutive colons indicates a nodename rather
10913        than a device.  [pr]  */
10914   if (*name == '_') ++name;
10915   if (tolower(*name++) != 'n') return 0;
10916   if (tolower(*name++) != 'l') return 0;
10917   if (tolower(*name) == 'a') ++name;
10918   if (*name == '0') ++name;
10919   return (*name++ == ':') && (*name != ':');
10920 }
10921
10922
10923 static I32
10924 Perl_cando_by_name_int
10925    (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10926 {
10927   static char usrname[L_cuserid];
10928   static struct dsc$descriptor_s usrdsc =
10929          {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10930   char vmsname[NAM$C_MAXRSS+1];
10931   char *fileified;
10932   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10933   unsigned short int retlen, trnlnm_iter_count;
10934   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10935   union prvdef curprv;
10936   struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10937          {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10938          {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10939   struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10940          {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10941          {0,0,0,0}};
10942   struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10943          {0,0,0,0}};
10944   struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10945
10946   if (!fname || !*fname) return FALSE;
10947   /* Make sure we expand logical names, since sys$check_access doesn't */
10948
10949   fileified = NULL;
10950   if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
10951     fileified = PerlMem_malloc(VMS_MAXRSS);
10952     if (!strpbrk(fname,"/]>:")) {
10953       strcpy(fileified,fname);
10954       trnlnm_iter_count = 0;
10955       while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10956         trnlnm_iter_count++;
10957         if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10958       }
10959       fname = fileified;
10960     }
10961     if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10962       PerlMem_free(fileified);
10963       return FALSE;
10964     }
10965     retlen = namdsc.dsc$w_length = strlen(vmsname);
10966     namdsc.dsc$a_pointer = vmsname;
10967     if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10968       vmsname[retlen-1] == ':') {
10969       if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) return FALSE;
10970       namdsc.dsc$w_length = strlen(fileified);
10971       namdsc.dsc$a_pointer = fileified;
10972     }
10973   }
10974   else {
10975     retlen = namdsc.dsc$w_length = strlen(fname);
10976     namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
10977   }
10978
10979   switch (bit) {
10980     case S_IXUSR: case S_IXGRP: case S_IXOTH:
10981       access = ARM$M_EXECUTE;
10982       flags = CHP$M_READ;
10983       break;
10984     case S_IRUSR: case S_IRGRP: case S_IROTH:
10985       access = ARM$M_READ;
10986       flags = CHP$M_READ | CHP$M_USEREADALL;
10987       break;
10988     case S_IWUSR: case S_IWGRP: case S_IWOTH:
10989       access = ARM$M_WRITE;
10990       flags = CHP$M_READ | CHP$M_WRITE;
10991       break;
10992     case S_IDUSR: case S_IDGRP: case S_IDOTH:
10993       access = ARM$M_DELETE;
10994       flags = CHP$M_READ | CHP$M_WRITE;
10995       break;
10996     default:
10997       if (fileified != NULL)
10998         PerlMem_free(fileified);
10999       return FALSE;
11000   }
11001
11002   /* Before we call $check_access, create a user profile with the current
11003    * process privs since otherwise it just uses the default privs from the
11004    * UAF and might give false positives or negatives.  This only works on
11005    * VMS versions v6.0 and later since that's when sys$create_user_profile
11006    * became available.
11007    */
11008
11009   /* get current process privs and username */
11010   _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11011   _ckvmssts(iosb[0]);
11012
11013 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11014
11015   /* find out the space required for the profile */
11016   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11017                                     &usrprodsc.dsc$w_length,0));
11018
11019   /* allocate space for the profile and get it filled in */
11020   usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11021   if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11022   _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11023                                     &usrprodsc.dsc$w_length,0));
11024
11025   /* use the profile to check access to the file; free profile & analyze results */
11026   retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
11027   PerlMem_free(usrprodsc.dsc$a_pointer);
11028   if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11029
11030 #else
11031
11032   retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11033
11034 #endif
11035
11036   if (retsts == SS$_NOPRIV      || retsts == SS$_NOSUCHOBJECT ||
11037       retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11038       retsts == RMS$_DIR        || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11039     set_vaxc_errno(retsts);
11040     if (retsts == SS$_NOPRIV) set_errno(EACCES);
11041     else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11042     else set_errno(ENOENT);
11043     if (fileified != NULL)
11044       PerlMem_free(fileified);
11045     return FALSE;
11046   }
11047   if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11048     if (fileified != NULL)
11049       PerlMem_free(fileified);
11050     return TRUE;
11051   }
11052   _ckvmssts(retsts);
11053
11054   if (fileified != NULL)
11055     PerlMem_free(fileified);
11056   return FALSE;  /* Should never get here */
11057
11058 }
11059
11060 /* Do the permissions allow some operation?  Assumes PL_statcache already set. */
11061 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11062  * subset of the applicable information.
11063  */
11064 bool
11065 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11066 {
11067   return cando_by_name_int
11068         (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11069 }  /* end of cando() */
11070 /*}}}*/
11071
11072
11073 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11074 I32
11075 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11076 {
11077    return cando_by_name_int(bit, effective, fname, 0);
11078
11079 }  /* end of cando_by_name() */
11080 /*}}}*/
11081
11082
11083 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11084 int
11085 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11086 {
11087   if (!fstat(fd,(stat_t *) statbufp)) {
11088     char *cptr;
11089     char *vms_filename;
11090     vms_filename = PerlMem_malloc(VMS_MAXRSS);
11091     if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11092
11093     /* Save name for cando by name in VMS format */
11094     cptr = getname(fd, vms_filename, 1);
11095
11096     /* This should not happen, but just in case */
11097     if (cptr == NULL) {
11098         statbufp->st_devnam[0] = 0;
11099     }
11100     else {
11101         /* Make sure that the saved name fits in 255 characters */
11102         cptr = do_rmsexpand
11103                        (vms_filename,
11104                         statbufp->st_devnam,
11105                         0,
11106                         NULL,
11107                         PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11108                         NULL,
11109                         NULL);
11110         if (cptr == NULL)
11111             statbufp->st_devnam[0] = 0;
11112     }
11113     PerlMem_free(vms_filename);
11114
11115     VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11116     VMS_DEVICE_ENCODE
11117         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11118
11119 #   ifdef RTL_USES_UTC
11120 #   ifdef VMSISH_TIME
11121     if (VMSISH_TIME) {
11122       statbufp->st_mtime = _toloc(statbufp->st_mtime);
11123       statbufp->st_atime = _toloc(statbufp->st_atime);
11124       statbufp->st_ctime = _toloc(statbufp->st_ctime);
11125     }
11126 #   endif
11127 #   else
11128 #   ifdef VMSISH_TIME
11129     if (!VMSISH_TIME) { /* Return UTC instead of local time */
11130 #   else
11131     if (1) {
11132 #   endif
11133       statbufp->st_mtime = _toutc(statbufp->st_mtime);
11134       statbufp->st_atime = _toutc(statbufp->st_atime);
11135       statbufp->st_ctime = _toutc(statbufp->st_ctime);
11136     }
11137 #endif
11138     return 0;
11139   }
11140   return -1;
11141
11142 }  /* end of flex_fstat() */
11143 /*}}}*/
11144
11145 #if !defined(__VAX) && __CRTL_VER >= 80200000
11146 #ifdef lstat
11147 #undef lstat
11148 #endif
11149 #else
11150 #ifdef lstat
11151 #undef lstat
11152 #endif
11153 #define lstat(_x, _y) stat(_x, _y)
11154 #endif
11155
11156 #define flex_stat_int(a,b,c)            Perl_flex_stat_int(aTHX_ a,b,c)
11157
11158 static int
11159 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11160 {
11161     char fileified[VMS_MAXRSS];
11162     char temp_fspec[VMS_MAXRSS];
11163     char *save_spec;
11164     int retval = -1;
11165     int saved_errno, saved_vaxc_errno;
11166
11167     if (!fspec) return retval;
11168     saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11169     strcpy(temp_fspec, fspec);
11170
11171     if (decc_bug_devnull != 0) {
11172       if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11173         memset(statbufp,0,sizeof *statbufp);
11174         VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11175         statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11176         statbufp->st_uid = 0x00010001;
11177         statbufp->st_gid = 0x0001;
11178         time((time_t *)&statbufp->st_mtime);
11179         statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11180         return 0;
11181       }
11182     }
11183
11184     /* Try for a directory name first.  If fspec contains a filename without
11185      * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11186      * and sea:[wine.dark]water. exist, we prefer the directory here.
11187      * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11188      * not sea:[wine.dark]., if the latter exists.  If the intended target is
11189      * the file with null type, specify this by calling flex_stat() with
11190      * a '.' at the end of fspec.
11191      *
11192      * If we are in Posix filespec mode, accept the filename as is.
11193      */
11194 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11195   if (decc_posix_compliant_pathnames == 0) {
11196 #endif
11197     if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11198       if (lstat_flag == 0)
11199         retval = stat(fileified,(stat_t *) statbufp);
11200       else
11201         retval = lstat(fileified,(stat_t *) statbufp);
11202       save_spec = fileified;
11203     }
11204     if (retval) {
11205       if (lstat_flag == 0)
11206         retval = stat(temp_fspec,(stat_t *) statbufp);
11207       else
11208         retval = lstat(temp_fspec,(stat_t *) statbufp);
11209       save_spec = temp_fspec;
11210     }
11211 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11212   } else {
11213     if (lstat_flag == 0)
11214       retval = stat(temp_fspec,(stat_t *) statbufp);
11215     else
11216       retval = lstat(temp_fspec,(stat_t *) statbufp);
11217       save_spec = temp_fspec;
11218   }
11219 #endif
11220     if (!retval) {
11221     char * cptr;
11222       cptr = do_rmsexpand
11223        (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
11224       if (cptr == NULL)
11225         statbufp->st_devnam[0] = 0;
11226
11227       VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11228       VMS_DEVICE_ENCODE
11229         (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11230 #     ifdef RTL_USES_UTC
11231 #     ifdef VMSISH_TIME
11232       if (VMSISH_TIME) {
11233         statbufp->st_mtime = _toloc(statbufp->st_mtime);
11234         statbufp->st_atime = _toloc(statbufp->st_atime);
11235         statbufp->st_ctime = _toloc(statbufp->st_ctime);
11236       }
11237 #     endif
11238 #     else
11239 #     ifdef VMSISH_TIME
11240       if (!VMSISH_TIME) { /* Return UTC instead of local time */
11241 #     else
11242       if (1) {
11243 #     endif
11244         statbufp->st_mtime = _toutc(statbufp->st_mtime);
11245         statbufp->st_atime = _toutc(statbufp->st_atime);
11246         statbufp->st_ctime = _toutc(statbufp->st_ctime);
11247       }
11248 #     endif
11249     }
11250     /* If we were successful, leave errno where we found it */
11251     if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
11252     return retval;
11253
11254 }  /* end of flex_stat_int() */
11255
11256
11257 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
11258 int
11259 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
11260 {
11261    return flex_stat_int(fspec, statbufp, 0);
11262 }
11263 /*}}}*/
11264
11265 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
11266 int
11267 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
11268 {
11269    return flex_stat_int(fspec, statbufp, 1);
11270 }
11271 /*}}}*/
11272
11273
11274 /*{{{char *my_getlogin()*/
11275 /* VMS cuserid == Unix getlogin, except calling sequence */
11276 char *
11277 my_getlogin(void)
11278 {
11279     static char user[L_cuserid];
11280     return cuserid(user);
11281 }
11282 /*}}}*/
11283
11284
11285 /*  rmscopy - copy a file using VMS RMS routines
11286  *
11287  *  Copies contents and attributes of spec_in to spec_out, except owner
11288  *  and protection information.  Name and type of spec_in are used as
11289  *  defaults for spec_out.  The third parameter specifies whether rmscopy()
11290  *  should try to propagate timestamps from the input file to the output file.
11291  *  If it is less than 0, no timestamps are preserved.  If it is 0, then
11292  *  rmscopy() will behave similarly to the DCL COPY command: timestamps are
11293  *  propagated to the output file at creation iff the output file specification
11294  *  did not contain an explicit name or type, and the revision date is always
11295  *  updated at the end of the copy operation.  If it is greater than 0, then
11296  *  it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11297  *  other than the revision date should be propagated, and bit 1 indicates
11298  *  that the revision date should be propagated.
11299  *
11300  *  Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11301  *
11302  *  Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11303  *  Incorporates, with permission, some code from EZCOPY by Tim Adye
11304  *  <T.J.Adye@rl.ac.uk>.  Permission is given to distribute this code
11305  * as part of the Perl standard distribution under the terms of the
11306  * GNU General Public License or the Perl Artistic License.  Copies
11307  * of each may be found in the Perl standard distribution.
11308  */ /* FIXME */
11309 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11310 int
11311 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11312 {
11313     char *vmsin, * vmsout, *esa, *esa_out,
11314          *rsa, *ubf;
11315     unsigned long int i, sts, sts2;
11316     int dna_len;
11317     struct FAB fab_in, fab_out;
11318     struct RAB rab_in, rab_out;
11319     rms_setup_nam(nam);
11320     rms_setup_nam(nam_out);
11321     struct XABDAT xabdat;
11322     struct XABFHC xabfhc;
11323     struct XABRDT xabrdt;
11324     struct XABSUM xabsum;
11325
11326     vmsin = PerlMem_malloc(VMS_MAXRSS);
11327     if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11328     vmsout = PerlMem_malloc(VMS_MAXRSS);
11329     if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11330     if (!spec_in  || !*spec_in  || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11331         !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11332       PerlMem_free(vmsin);
11333       PerlMem_free(vmsout);
11334       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11335       return 0;
11336     }
11337
11338     esa = PerlMem_malloc(VMS_MAXRSS);
11339     if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11340     fab_in = cc$rms_fab;
11341     rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11342     fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11343     fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11344     fab_in.fab$l_fop = FAB$M_SQO;
11345     rms_bind_fab_nam(fab_in, nam);
11346     fab_in.fab$l_xab = (void *) &xabdat;
11347
11348     rsa = PerlMem_malloc(VMS_MAXRSS);
11349     if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11350     rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11351     rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11352     rms_nam_esl(nam) = 0;
11353     rms_nam_rsl(nam) = 0;
11354     rms_nam_esll(nam) = 0;
11355     rms_nam_rsll(nam) = 0;
11356 #ifdef NAM$M_NO_SHORT_UPCASE
11357     if (decc_efs_case_preserve)
11358         rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11359 #endif
11360
11361     xabdat = cc$rms_xabdat;        /* To get creation date */
11362     xabdat.xab$l_nxt = (void *) &xabfhc;
11363
11364     xabfhc = cc$rms_xabfhc;        /* To get record length */
11365     xabfhc.xab$l_nxt = (void *) &xabsum;
11366
11367     xabsum = cc$rms_xabsum;        /* To get key and area information */
11368
11369     if (!((sts = sys$open(&fab_in)) & 1)) {
11370       PerlMem_free(vmsin);
11371       PerlMem_free(vmsout);
11372       PerlMem_free(esa);
11373       PerlMem_free(rsa);
11374       set_vaxc_errno(sts);
11375       switch (sts) {
11376         case RMS$_FNF: case RMS$_DNF:
11377           set_errno(ENOENT); break;
11378         case RMS$_DIR:
11379           set_errno(ENOTDIR); break;
11380         case RMS$_DEV:
11381           set_errno(ENODEV); break;
11382         case RMS$_SYN:
11383           set_errno(EINVAL); break;
11384         case RMS$_PRV:
11385           set_errno(EACCES); break;
11386         default:
11387           set_errno(EVMSERR);
11388       }
11389       return 0;
11390     }
11391
11392     nam_out = nam;
11393     fab_out = fab_in;
11394     fab_out.fab$w_ifi = 0;
11395     fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11396     fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11397     fab_out.fab$l_fop = FAB$M_SQO;
11398     rms_bind_fab_nam(fab_out, nam_out);
11399     rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11400     dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11401     rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11402     esa_out = PerlMem_malloc(VMS_MAXRSS);
11403     if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11404     rms_set_rsa(nam_out, NULL, 0);
11405     rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11406
11407     if (preserve_dates == 0) {  /* Act like DCL COPY */
11408       rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11409       fab_out.fab$l_xab = NULL;  /* Don't disturb data from input file */
11410       if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11411         PerlMem_free(vmsin);
11412         PerlMem_free(vmsout);
11413         PerlMem_free(esa);
11414         PerlMem_free(rsa);
11415         PerlMem_free(esa_out);
11416         set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11417         set_vaxc_errno(sts);
11418         return 0;
11419       }
11420       fab_out.fab$l_xab = (void *) &xabdat;
11421       if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11422         preserve_dates = 1;
11423     }
11424     if (preserve_dates < 0)   /* Clear all bits; we'll use it as a */
11425       preserve_dates =0;      /* bitmask from this point forward   */
11426
11427     if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11428     if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11429       PerlMem_free(vmsin);
11430       PerlMem_free(vmsout);
11431       PerlMem_free(esa);
11432       PerlMem_free(rsa);
11433       PerlMem_free(esa_out);
11434       set_vaxc_errno(sts);
11435       switch (sts) {
11436         case RMS$_DNF:
11437           set_errno(ENOENT); break;
11438         case RMS$_DIR:
11439           set_errno(ENOTDIR); break;
11440         case RMS$_DEV:
11441           set_errno(ENODEV); break;
11442         case RMS$_SYN:
11443           set_errno(EINVAL); break;
11444         case RMS$_PRV:
11445           set_errno(EACCES); break;
11446         default:
11447           set_errno(EVMSERR);
11448       }
11449       return 0;
11450     }
11451     fab_out.fab$l_fop |= FAB$M_DLT;  /* in case we have to bail out */
11452     if (preserve_dates & 2) {
11453       /* sys$close() will process xabrdt, not xabdat */
11454       xabrdt = cc$rms_xabrdt;
11455 #ifndef __GNUC__
11456       xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11457 #else
11458       /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11459        * is unsigned long[2], while DECC & VAXC use a struct */
11460       memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11461 #endif
11462       fab_out.fab$l_xab = (void *) &xabrdt;
11463     }
11464
11465     ubf = PerlMem_malloc(32256);
11466     if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11467     rab_in = cc$rms_rab;
11468     rab_in.rab$l_fab = &fab_in;
11469     rab_in.rab$l_rop = RAB$M_BIO;
11470     rab_in.rab$l_ubf = ubf;
11471     rab_in.rab$w_usz = 32256;
11472     if (!((sts = sys$connect(&rab_in)) & 1)) {
11473       sys$close(&fab_in); sys$close(&fab_out);
11474       PerlMem_free(vmsin);
11475       PerlMem_free(vmsout);
11476       PerlMem_free(esa);
11477       PerlMem_free(ubf);
11478       PerlMem_free(rsa);
11479       PerlMem_free(esa_out);
11480       set_errno(EVMSERR); set_vaxc_errno(sts);
11481       return 0;
11482     }
11483
11484     rab_out = cc$rms_rab;
11485     rab_out.rab$l_fab = &fab_out;
11486     rab_out.rab$l_rbf = ubf;
11487     if (!((sts = sys$connect(&rab_out)) & 1)) {
11488       sys$close(&fab_in); sys$close(&fab_out);
11489       PerlMem_free(vmsin);
11490       PerlMem_free(vmsout);
11491       PerlMem_free(esa);
11492       PerlMem_free(ubf);
11493       PerlMem_free(rsa);
11494       PerlMem_free(esa_out);
11495       set_errno(EVMSERR); set_vaxc_errno(sts);
11496       return 0;
11497     }
11498
11499     while ((sts = sys$read(&rab_in))) {  /* always true  */
11500       if (sts == RMS$_EOF) break;
11501       rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11502       if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11503         sys$close(&fab_in); sys$close(&fab_out);
11504         PerlMem_free(vmsin);
11505         PerlMem_free(vmsout);
11506         PerlMem_free(esa);
11507         PerlMem_free(ubf);
11508         PerlMem_free(rsa);
11509         PerlMem_free(esa_out);
11510         set_errno(EVMSERR); set_vaxc_errno(sts);
11511         return 0;
11512       }
11513     }
11514
11515
11516     fab_out.fab$l_fop &= ~FAB$M_DLT;  /* We got this far; keep the output */
11517     sys$close(&fab_in);  sys$close(&fab_out);
11518     sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11519     if (!(sts & 1)) {
11520       PerlMem_free(vmsin);
11521       PerlMem_free(vmsout);
11522       PerlMem_free(esa);
11523       PerlMem_free(ubf);
11524       PerlMem_free(rsa);
11525       PerlMem_free(esa_out);
11526       set_errno(EVMSERR); set_vaxc_errno(sts);
11527       return 0;
11528     }
11529
11530     PerlMem_free(vmsin);
11531     PerlMem_free(vmsout);
11532     PerlMem_free(esa);
11533     PerlMem_free(ubf);
11534     PerlMem_free(rsa);
11535     PerlMem_free(esa_out);
11536     return 1;
11537
11538 }  /* end of rmscopy() */
11539 /*}}}*/
11540
11541
11542 /***  The following glue provides 'hooks' to make some of the routines
11543  * from this file available from Perl.  These routines are sufficiently
11544  * basic, and are required sufficiently early in the build process,
11545  * that's it's nice to have them available to miniperl as well as the
11546  * full Perl, so they're set up here instead of in an extension.  The
11547  * Perl code which handles importation of these names into a given
11548  * package lives in [.VMS]Filespec.pm in @INC.
11549  */
11550
11551 void
11552 rmsexpand_fromperl(pTHX_ CV *cv)
11553 {
11554   dXSARGS;
11555   char *fspec, *defspec = NULL, *rslt;
11556   STRLEN n_a;
11557   int fs_utf8, dfs_utf8;
11558
11559   fs_utf8 = 0;
11560   dfs_utf8 = 0;
11561   if (!items || items > 2)
11562     Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11563   fspec = SvPV(ST(0),n_a);
11564   fs_utf8 = SvUTF8(ST(0));
11565   if (!fspec || !*fspec) XSRETURN_UNDEF;
11566   if (items == 2) {
11567     defspec = SvPV(ST(1),n_a);
11568     dfs_utf8 = SvUTF8(ST(1));
11569   }
11570   rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11571   ST(0) = sv_newmortal();
11572   if (rslt != NULL) {
11573     sv_usepvn(ST(0),rslt,strlen(rslt));
11574     if (fs_utf8) {
11575         SvUTF8_on(ST(0));
11576     }
11577   }
11578   XSRETURN(1);
11579 }
11580
11581 void
11582 vmsify_fromperl(pTHX_ CV *cv)
11583 {
11584   dXSARGS;
11585   char *vmsified;
11586   STRLEN n_a;
11587   int utf8_fl;
11588
11589   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11590   utf8_fl = SvUTF8(ST(0));
11591   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11592   ST(0) = sv_newmortal();
11593   if (vmsified != NULL) {
11594     sv_usepvn(ST(0),vmsified,strlen(vmsified));
11595     if (utf8_fl) {
11596         SvUTF8_on(ST(0));
11597     }
11598   }
11599   XSRETURN(1);
11600 }
11601
11602 void
11603 unixify_fromperl(pTHX_ CV *cv)
11604 {
11605   dXSARGS;
11606   char *unixified;
11607   STRLEN n_a;
11608   int utf8_fl;
11609
11610   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11611   utf8_fl = SvUTF8(ST(0));
11612   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11613   ST(0) = sv_newmortal();
11614   if (unixified != NULL) {
11615     sv_usepvn(ST(0),unixified,strlen(unixified));
11616     if (utf8_fl) {
11617         SvUTF8_on(ST(0));
11618     }
11619   }
11620   XSRETURN(1);
11621 }
11622
11623 void
11624 fileify_fromperl(pTHX_ CV *cv)
11625 {
11626   dXSARGS;
11627   char *fileified;
11628   STRLEN n_a;
11629   int utf8_fl;
11630
11631   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11632   utf8_fl = SvUTF8(ST(0));
11633   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11634   ST(0) = sv_newmortal();
11635   if (fileified != NULL) {
11636     sv_usepvn(ST(0),fileified,strlen(fileified));
11637     if (utf8_fl) {
11638         SvUTF8_on(ST(0));
11639     }
11640   }
11641   XSRETURN(1);
11642 }
11643
11644 void
11645 pathify_fromperl(pTHX_ CV *cv)
11646 {
11647   dXSARGS;
11648   char *pathified;
11649   STRLEN n_a;
11650   int utf8_fl;
11651
11652   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11653   utf8_fl = SvUTF8(ST(0));
11654   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11655   ST(0) = sv_newmortal();
11656   if (pathified != NULL) {
11657     sv_usepvn(ST(0),pathified,strlen(pathified));
11658     if (utf8_fl) {
11659         SvUTF8_on(ST(0));
11660     }
11661   }
11662   XSRETURN(1);
11663 }
11664
11665 void
11666 vmspath_fromperl(pTHX_ CV *cv)
11667 {
11668   dXSARGS;
11669   char *vmspath;
11670   STRLEN n_a;
11671   int utf8_fl;
11672
11673   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11674   utf8_fl = SvUTF8(ST(0));
11675   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11676   ST(0) = sv_newmortal();
11677   if (vmspath != NULL) {
11678     sv_usepvn(ST(0),vmspath,strlen(vmspath));
11679     if (utf8_fl) {
11680         SvUTF8_on(ST(0));
11681     }
11682   }
11683   XSRETURN(1);
11684 }
11685
11686 void
11687 unixpath_fromperl(pTHX_ CV *cv)
11688 {
11689   dXSARGS;
11690   char *unixpath;
11691   STRLEN n_a;
11692   int utf8_fl;
11693
11694   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11695   utf8_fl = SvUTF8(ST(0));
11696   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11697   ST(0) = sv_newmortal();
11698   if (unixpath != NULL) {
11699     sv_usepvn(ST(0),unixpath,strlen(unixpath));
11700     if (utf8_fl) {
11701         SvUTF8_on(ST(0));
11702     }
11703   }
11704   XSRETURN(1);
11705 }
11706
11707 void
11708 candelete_fromperl(pTHX_ CV *cv)
11709 {
11710   dXSARGS;
11711   char *fspec, *fsp;
11712   SV *mysv;
11713   IO *io;
11714   STRLEN n_a;
11715
11716   if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11717
11718   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11719   Newx(fspec, VMS_MAXRSS, char);
11720   if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11721   if (SvTYPE(mysv) == SVt_PVGV) {
11722     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11723       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11724       ST(0) = &PL_sv_no;
11725       Safefree(fspec);
11726       XSRETURN(1);
11727     }
11728     fsp = fspec;
11729   }
11730   else {
11731     if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11732       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11733       ST(0) = &PL_sv_no;
11734       Safefree(fspec);
11735       XSRETURN(1);
11736     }
11737   }
11738
11739   ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11740   Safefree(fspec);
11741   XSRETURN(1);
11742 }
11743
11744 void
11745 rmscopy_fromperl(pTHX_ CV *cv)
11746 {
11747   dXSARGS;
11748   char *inspec, *outspec, *inp, *outp;
11749   int date_flag;
11750   struct dsc$descriptor indsc  = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11751                         outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11752   unsigned long int sts;
11753   SV *mysv;
11754   IO *io;
11755   STRLEN n_a;
11756
11757   if (items < 2 || items > 3)
11758     Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11759
11760   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11761   Newx(inspec, VMS_MAXRSS, char);
11762   if (SvTYPE(mysv) == SVt_PVGV) {
11763     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11764       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11765       ST(0) = &PL_sv_no;
11766       Safefree(inspec);
11767       XSRETURN(1);
11768     }
11769     inp = inspec;
11770   }
11771   else {
11772     if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11773       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11774       ST(0) = &PL_sv_no;
11775       Safefree(inspec);
11776       XSRETURN(1);
11777     }
11778   }
11779   mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11780   Newx(outspec, VMS_MAXRSS, char);
11781   if (SvTYPE(mysv) == SVt_PVGV) {
11782     if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11783       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11784       ST(0) = &PL_sv_no;
11785       Safefree(inspec);
11786       Safefree(outspec);
11787       XSRETURN(1);
11788     }
11789     outp = outspec;
11790   }
11791   else {
11792     if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11793       set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11794       ST(0) = &PL_sv_no;
11795       Safefree(inspec);
11796       Safefree(outspec);
11797       XSRETURN(1);
11798     }
11799   }
11800   date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11801
11802   ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11803   Safefree(inspec);
11804   Safefree(outspec);
11805   XSRETURN(1);
11806 }
11807
11808 /* The mod2fname is limited to shorter filenames by design, so it should
11809  * not be modified to support longer EFS pathnames
11810  */
11811 void
11812 mod2fname(pTHX_ CV *cv)
11813 {
11814   dXSARGS;
11815   char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11816        workbuff[NAM$C_MAXRSS*1 + 1];
11817   int total_namelen = 3, counter, num_entries;
11818   /* ODS-5 ups this, but we want to be consistent, so... */
11819   int max_name_len = 39;
11820   AV *in_array = (AV *)SvRV(ST(0));
11821
11822   num_entries = av_len(in_array);
11823
11824   /* All the names start with PL_. */
11825   strcpy(ultimate_name, "PL_");
11826
11827   /* Clean up our working buffer */
11828   Zero(work_name, sizeof(work_name), char);
11829
11830   /* Run through the entries and build up a working name */
11831   for(counter = 0; counter <= num_entries; counter++) {
11832     /* If it's not the first name then tack on a __ */
11833     if (counter) {
11834       strcat(work_name, "__");
11835     }
11836     strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11837                            PL_na));
11838   }
11839
11840   /* Check to see if we actually have to bother...*/
11841   if (strlen(work_name) + 3 <= max_name_len) {
11842     strcat(ultimate_name, work_name);
11843   } else {
11844     /* It's too darned big, so we need to go strip. We use the same */
11845     /* algorithm as xsubpp does. First, strip out doubled __ */
11846     char *source, *dest, last;
11847     dest = workbuff;
11848     last = 0;
11849     for (source = work_name; *source; source++) {
11850       if (last == *source && last == '_') {
11851         continue;
11852       }
11853       *dest++ = *source;
11854       last = *source;
11855     }
11856     /* Go put it back */
11857     strcpy(work_name, workbuff);
11858     /* Is it still too big? */
11859     if (strlen(work_name) + 3 > max_name_len) {
11860       /* Strip duplicate letters */
11861       last = 0;
11862       dest = workbuff;
11863       for (source = work_name; *source; source++) {
11864         if (last == toupper(*source)) {
11865         continue;
11866         }
11867         *dest++ = *source;
11868         last = toupper(*source);
11869       }
11870       strcpy(work_name, workbuff);
11871     }
11872
11873     /* Is it *still* too big? */
11874     if (strlen(work_name) + 3 > max_name_len) {
11875       /* Too bad, we truncate */
11876       work_name[max_name_len - 2] = 0;
11877     }
11878     strcat(ultimate_name, work_name);
11879   }
11880
11881   /* Okay, return it */
11882   ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11883   XSRETURN(1);
11884 }
11885
11886 void
11887 hushexit_fromperl(pTHX_ CV *cv)
11888 {
11889     dXSARGS;
11890
11891     if (items > 0) {
11892         VMSISH_HUSHED = SvTRUE(ST(0));
11893     }
11894     ST(0) = boolSV(VMSISH_HUSHED);
11895     XSRETURN(1);
11896 }
11897
11898
11899 PerlIO *
11900 Perl_vms_start_glob
11901    (pTHX_ SV *tmpglob,
11902     IO *io)
11903 {
11904     PerlIO *fp;
11905     struct vs_str_st *rslt;
11906     char *vmsspec;
11907     char *rstr;
11908     char *begin, *cp;
11909     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11910     PerlIO *tmpfp;
11911     STRLEN i;
11912     struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11913     struct dsc$descriptor_vs rsdsc;
11914     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11915     unsigned long hasver = 0, isunix = 0;
11916     unsigned long int lff_flags = 0;
11917     int rms_sts;
11918
11919 #ifdef VMS_LONGNAME_SUPPORT
11920     lff_flags = LIB$M_FIL_LONG_NAMES;
11921 #endif
11922     /* The Newx macro will not allow me to assign a smaller array
11923      * to the rslt pointer, so we will assign it to the begin char pointer
11924      * and then copy the value into the rslt pointer.
11925      */
11926     Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11927     rslt = (struct vs_str_st *)begin;
11928     rslt->length = 0;
11929     rstr = &rslt->str[0];
11930     rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11931     rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11932     rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11933     rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11934
11935     Newx(vmsspec, VMS_MAXRSS, char);
11936
11937         /* We could find out if there's an explicit dev/dir or version
11938            by peeking into lib$find_file's internal context at
11939            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11940            but that's unsupported, so I don't want to do it now and
11941            have it bite someone in the future. */
11942         /* Fix-me: vms_split_path() is the only way to do this, the
11943            existing method will fail with many legal EFS or UNIX specifications
11944          */
11945
11946     cp = SvPV(tmpglob,i);
11947
11948     for (; i; i--) {
11949         if (cp[i] == ';') hasver = 1;
11950         if (cp[i] == '.') {
11951             if (sts) hasver = 1;
11952             else sts = 1;
11953         }
11954         if (cp[i] == '/') {
11955             hasdir = isunix = 1;
11956             break;
11957         }
11958         if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11959             hasdir = 1;
11960             break;
11961         }
11962     }
11963     if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11964         int found = 0;
11965         Stat_t st;
11966         int stat_sts;
11967         stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11968         if (!stat_sts && S_ISDIR(st.st_mode)) {
11969             wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
11970             ok = (wilddsc.dsc$a_pointer != NULL);
11971         }
11972         else {
11973             wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
11974             ok = (wilddsc.dsc$a_pointer != NULL);
11975         }
11976         if (ok)
11977             wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11978
11979         /* If not extended character set, replace ? with % */
11980         /* With extended character set, ? is a wildcard single character */
11981         if (!decc_efs_case_preserve) {
11982             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11983                 if (*cp == '?') *cp = '%';
11984         }
11985         sts = SS$_NORMAL;
11986         while (ok && $VMS_STATUS_SUCCESS(sts)) {
11987          char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11988          int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11989
11990             sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11991                                 &dfltdsc,NULL,&rms_sts,&lff_flags);
11992             if (!$VMS_STATUS_SUCCESS(sts))
11993                 break;
11994
11995             found++;
11996
11997             /* with varying string, 1st word of buffer contains result length */
11998             rstr[rslt->length] = '\0';
11999
12000              /* Find where all the components are */
12001              v_sts = vms_split_path
12002                        (rstr,
12003                         &v_spec,
12004                         &v_len,
12005                         &r_spec,
12006                         &r_len,
12007                         &d_spec,
12008                         &d_len,
12009                         &n_spec,
12010                         &n_len,
12011                         &e_spec,
12012                         &e_len,
12013                         &vs_spec,
12014                         &vs_len);
12015
12016             /* If no version on input, truncate the version on output */
12017             if (!hasver && (vs_len > 0)) {
12018                 *vs_spec = '\0';
12019                 vs_len = 0;
12020
12021                 /* No version & a null extension on UNIX handling */
12022                 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12023                     e_len = 0;
12024                     *e_spec = '\0';
12025                 }
12026             }
12027
12028             if (!decc_efs_case_preserve) {
12029                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12030             }
12031
12032             if (hasdir) {
12033                 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12034                 begin = rstr;
12035             }
12036             else {
12037                 /* Start with the name */
12038                 begin = n_spec;
12039             }
12040             strcat(begin,"\n");
12041             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12042         }
12043         if (cxt) (void)lib$find_file_end(&cxt);
12044
12045         if (!found) {
12046             /* Be POSIXish: return the input pattern when no matches */
12047             begin = SvPVX(tmpglob);
12048             strcat(begin,"\n");
12049             ok = (PerlIO_puts(tmpfp,begin) != EOF);
12050         }
12051
12052         if (ok && sts != RMS$_NMF &&
12053             sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12054         if (!ok) {
12055             if (!(sts & 1)) {
12056                 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12057             }
12058             PerlIO_close(tmpfp);
12059             fp = NULL;
12060         }
12061         else {
12062             PerlIO_rewind(tmpfp);
12063             IoTYPE(io) = IoTYPE_RDONLY;
12064             IoIFP(io) = fp = tmpfp;
12065             IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
12066         }
12067     }
12068     Safefree(vmsspec);
12069     Safefree(rslt);
12070     return fp;
12071 }
12072
12073
12074 #ifdef HAS_SYMLINK
12075 static char *
12076 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
12077
12078 void
12079 vms_realpath_fromperl(pTHX_ CV *cv)
12080 {
12081   dXSARGS;
12082   char *fspec, *rslt_spec, *rslt;
12083   STRLEN n_a;
12084
12085   if (!items || items != 1)
12086     Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12087
12088   fspec = SvPV(ST(0),n_a);
12089   if (!fspec || !*fspec) XSRETURN_UNDEF;
12090
12091   Newx(rslt_spec, VMS_MAXRSS + 1, char);
12092   rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12093   ST(0) = sv_newmortal();
12094   if (rslt != NULL)
12095     sv_usepvn(ST(0),rslt,strlen(rslt));
12096   else
12097     Safefree(rslt_spec);
12098   XSRETURN(1);
12099 }
12100 #endif
12101
12102 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12103 int do_vms_case_tolerant(void);
12104
12105 void
12106 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12107 {
12108   dXSARGS;
12109   ST(0) = boolSV(do_vms_case_tolerant());
12110   XSRETURN(1);
12111 }
12112 #endif
12113
12114 void
12115 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12116                           struct interp_intern *dst)
12117 {
12118     memcpy(dst,src,sizeof(struct interp_intern));
12119 }
12120
12121 void
12122 Perl_sys_intern_clear(pTHX)
12123 {
12124 }
12125
12126 void
12127 Perl_sys_intern_init(pTHX)
12128 {
12129     unsigned int ix = RAND_MAX;
12130     double x;
12131
12132     VMSISH_HUSHED = 0;
12133
12134     /* fix me later to track running under GNV */
12135     /* this allows some limited testing */
12136     MY_POSIX_EXIT = decc_filename_unix_report;
12137
12138     x = (float)ix;
12139     MY_INV_RAND_MAX = 1./x;
12140 }
12141
12142 void
12143 init_os_extras(void)
12144 {
12145   dTHX;
12146   char* file = __FILE__;
12147   if (decc_disable_to_vms_logname_translation) {
12148     no_translate_barewords = TRUE;
12149   } else {
12150     no_translate_barewords = FALSE;
12151   }
12152
12153   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
12154   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
12155   newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
12156   newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
12157   newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
12158   newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
12159   newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
12160   newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
12161   newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
12162   newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
12163   newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
12164 #ifdef HAS_SYMLINK
12165   newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
12166 #endif
12167 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12168   newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
12169 #endif
12170
12171   store_pipelocs(aTHX);         /* will redo any earlier attempts */
12172
12173   return;
12174 }
12175
12176 #ifdef HAS_SYMLINK
12177
12178 #if __CRTL_VER == 80200000
12179 /* This missed getting in to the DECC SDK for 8.2 */
12180 char *realpath(const char *file_name, char * resolved_name, ...);
12181 #endif
12182
12183 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
12184 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
12185  * The perl fallback routine to provide realpath() is not as efficient
12186  * on OpenVMS.
12187  */
12188 static char *
12189 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12190 {
12191     return realpath(filespec, outbuf);
12192 }
12193
12194 /*}}}*/
12195 /* External entry points */
12196 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12197 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
12198 #else
12199 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12200 { return NULL; }
12201 #endif
12202
12203
12204 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12205 /* case_tolerant */
12206
12207 /*{{{int do_vms_case_tolerant(void)*/
12208 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
12209  * controlled by a process setting.
12210  */
12211 int do_vms_case_tolerant(void)
12212 {
12213     return vms_process_case_tolerant;
12214 }
12215 /*}}}*/
12216 /* External entry points */
12217 int Perl_vms_case_tolerant(void)
12218 { return do_vms_case_tolerant(); }
12219 #else
12220 int Perl_vms_case_tolerant(void)
12221 { return vms_process_case_tolerant; }
12222 #endif
12223
12224
12225  /* Start of DECC RTL Feature handling */
12226
12227 static int sys_trnlnm
12228    (const char * logname,
12229     char * value,
12230     int value_len)
12231 {
12232     const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
12233     const unsigned long attr = LNM$M_CASE_BLIND;
12234     struct dsc$descriptor_s name_dsc;
12235     int status;
12236     unsigned short result;
12237     struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
12238                                 {0, 0, 0, 0}};
12239
12240     name_dsc.dsc$w_length = strlen(logname);
12241     name_dsc.dsc$a_pointer = (char *)logname;
12242     name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12243     name_dsc.dsc$b_class = DSC$K_CLASS_S;
12244
12245     status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
12246
12247     if ($VMS_STATUS_SUCCESS(status)) {
12248
12249          /* Null terminate and return the string */
12250         /*--------------------------------------*/
12251         value[result] = 0;
12252     }
12253
12254     return status;
12255 }
12256
12257 static int sys_crelnm
12258    (const char * logname,
12259     const char * value)
12260 {
12261     int ret_val;
12262     const char * proc_table = "LNM$PROCESS_TABLE";
12263     struct dsc$descriptor_s proc_table_dsc;
12264     struct dsc$descriptor_s logname_dsc;
12265     struct itmlst_3 item_list[2];
12266
12267     proc_table_dsc.dsc$a_pointer = (char *) proc_table;
12268     proc_table_dsc.dsc$w_length = strlen(proc_table);
12269     proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12270     proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
12271
12272     logname_dsc.dsc$a_pointer = (char *) logname;
12273     logname_dsc.dsc$w_length = strlen(logname);
12274     logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12275     logname_dsc.dsc$b_class = DSC$K_CLASS_S;
12276
12277     item_list[0].buflen = strlen(value);
12278     item_list[0].itmcode = LNM$_STRING;
12279     item_list[0].bufadr = (char *)value;
12280     item_list[0].retlen = NULL;
12281
12282     item_list[1].buflen = 0;
12283     item_list[1].itmcode = 0;
12284
12285     ret_val = sys$crelnm
12286                        (NULL,
12287                         (const struct dsc$descriptor_s *)&proc_table_dsc,
12288                         (const struct dsc$descriptor_s *)&logname_dsc,
12289                         NULL,
12290                         (const struct item_list_3 *) item_list);
12291
12292     return ret_val;
12293 }
12294
12295 /* C RTL Feature settings */
12296
12297 static int set_features
12298    (int (* init_coroutine)(int *, int *, void *),  /* Needs casts if used */
12299     int (* cli_routine)(void),  /* Not documented */
12300     void *image_info)           /* Not documented */
12301 {
12302     int status;
12303     int s;
12304     int dflt;
12305     char* str;
12306     char val_str[10];
12307 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12308     const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12309     const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12310     unsigned long case_perm;
12311     unsigned long case_image;
12312 #endif
12313
12314     /* Allow an exception to bring Perl into the VMS debugger */
12315     vms_debug_on_exception = 0;
12316     status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12317     if ($VMS_STATUS_SUCCESS(status)) {
12318        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12319          vms_debug_on_exception = 1;
12320        else
12321          vms_debug_on_exception = 0;
12322     }
12323
12324     /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
12325     vms_vtf7_filenames = 0;
12326     status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12327     if ($VMS_STATUS_SUCCESS(status)) {
12328        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12329          vms_vtf7_filenames = 1;
12330        else
12331          vms_vtf7_filenames = 0;
12332     }
12333
12334     /* Dectect running under GNV Bash or other UNIX like shell */
12335 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12336     gnv_unix_shell = 0;
12337     status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12338     if ($VMS_STATUS_SUCCESS(status)) {
12339        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12340          gnv_unix_shell = 1;
12341          set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12342          set_feature_default("DECC$EFS_CHARSET", 1);
12343          set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12344          set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12345          set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12346          set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12347        }
12348        else
12349          gnv_unix_shell = 0;
12350     }
12351 #endif
12352
12353     /* hacks to see if known bugs are still present for testing */
12354
12355     /* Readdir is returning filenames in VMS syntax always */
12356     decc_bug_readdir_efs1 = 1;
12357     status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12358     if ($VMS_STATUS_SUCCESS(status)) {
12359        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12360          decc_bug_readdir_efs1 = 1;
12361        else
12362          decc_bug_readdir_efs1 = 0;
12363     }
12364
12365     /* PCP mode requires creating /dev/null special device file */
12366     decc_bug_devnull = 0;
12367     status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12368     if ($VMS_STATUS_SUCCESS(status)) {
12369        if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12370           decc_bug_devnull = 1;
12371        else
12372           decc_bug_devnull = 0;
12373     }
12374
12375     /* fgetname returning a VMS name in UNIX mode */
12376     decc_bug_fgetname = 1;
12377     status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12378     if ($VMS_STATUS_SUCCESS(status)) {
12379       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12380         decc_bug_fgetname = 1;
12381       else
12382         decc_bug_fgetname = 0;
12383     }
12384
12385     /* UNIX directory names with no paths are broken in a lot of places */
12386     decc_dir_barename = 1;
12387     status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12388     if ($VMS_STATUS_SUCCESS(status)) {
12389       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12390         decc_dir_barename = 1;
12391       else
12392         decc_dir_barename = 0;
12393     }
12394
12395 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12396     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12397     if (s >= 0) {
12398         decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12399         if (decc_disable_to_vms_logname_translation < 0)
12400             decc_disable_to_vms_logname_translation = 0;
12401     }
12402
12403     s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12404     if (s >= 0) {
12405         decc_efs_case_preserve = decc$feature_get_value(s, 1);
12406         if (decc_efs_case_preserve < 0)
12407             decc_efs_case_preserve = 0;
12408     }
12409
12410     s = decc$feature_get_index("DECC$EFS_CHARSET");
12411     if (s >= 0) {
12412         decc_efs_charset = decc$feature_get_value(s, 1);
12413         if (decc_efs_charset < 0)
12414             decc_efs_charset = 0;
12415     }
12416
12417     s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12418     if (s >= 0) {
12419         decc_filename_unix_report = decc$feature_get_value(s, 1);
12420         if (decc_filename_unix_report > 0)
12421             decc_filename_unix_report = 1;
12422         else
12423             decc_filename_unix_report = 0;
12424     }
12425
12426     s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12427     if (s >= 0) {
12428         decc_filename_unix_only = decc$feature_get_value(s, 1);
12429         if (decc_filename_unix_only > 0) {
12430             decc_filename_unix_only = 1;
12431         }
12432         else {
12433             decc_filename_unix_only = 0;
12434         }
12435     }
12436
12437     s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12438     if (s >= 0) {
12439         decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12440         if (decc_filename_unix_no_version < 0)
12441             decc_filename_unix_no_version = 0;
12442     }
12443
12444     s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12445     if (s >= 0) {
12446         decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12447         if (decc_readdir_dropdotnotype < 0)
12448             decc_readdir_dropdotnotype = 0;
12449     }
12450
12451     status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12452     if ($VMS_STATUS_SUCCESS(status)) {
12453         s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12454         if (s >= 0) {
12455             dflt = decc$feature_get_value(s, 4);
12456             if (dflt > 0) {
12457                 decc_disable_posix_root = decc$feature_get_value(s, 1);
12458                 if (decc_disable_posix_root <= 0) {
12459                     decc$feature_set_value(s, 1, 1);
12460                     decc_disable_posix_root = 1;
12461                 }
12462             }
12463             else {
12464                 /* Traditionally Perl assumes this is off */
12465                 decc_disable_posix_root = 1;
12466                 decc$feature_set_value(s, 1, 1);
12467             }
12468         }
12469     }
12470
12471 #if __CRTL_VER >= 80200000
12472     s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12473     if (s >= 0) {
12474         decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12475         if (decc_posix_compliant_pathnames < 0)
12476             decc_posix_compliant_pathnames = 0;
12477         if (decc_posix_compliant_pathnames > 4)
12478             decc_posix_compliant_pathnames = 0;
12479     }
12480
12481 #endif
12482 #else
12483     status = sys_trnlnm
12484         ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12485     if ($VMS_STATUS_SUCCESS(status)) {
12486         val_str[0] = _toupper(val_str[0]);
12487         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12488            decc_disable_to_vms_logname_translation = 1;
12489         }
12490     }
12491
12492 #ifndef __VAX
12493     status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12494     if ($VMS_STATUS_SUCCESS(status)) {
12495         val_str[0] = _toupper(val_str[0]);
12496         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12497            decc_efs_case_preserve = 1;
12498         }
12499     }
12500 #endif
12501
12502     status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", 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_filename_unix_report = 1;
12507         }
12508     }
12509     status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12510     if ($VMS_STATUS_SUCCESS(status)) {
12511         val_str[0] = _toupper(val_str[0]);
12512         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12513            decc_filename_unix_only = 1;
12514            decc_filename_unix_report = 1;
12515         }
12516     }
12517     status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12518     if ($VMS_STATUS_SUCCESS(status)) {
12519         val_str[0] = _toupper(val_str[0]);
12520         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12521            decc_filename_unix_no_version = 1;
12522         }
12523     }
12524     status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12525     if ($VMS_STATUS_SUCCESS(status)) {
12526         val_str[0] = _toupper(val_str[0]);
12527         if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12528            decc_readdir_dropdotnotype = 1;
12529         }
12530     }
12531 #endif
12532
12533 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12534
12535      /* Report true case tolerance */
12536     /*----------------------------*/
12537     status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12538     if (!$VMS_STATUS_SUCCESS(status))
12539         case_perm = PPROP$K_CASE_BLIND;
12540     status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12541     if (!$VMS_STATUS_SUCCESS(status))
12542         case_image = PPROP$K_CASE_BLIND;
12543     if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12544         (case_image == PPROP$K_CASE_SENSITIVE))
12545         vms_process_case_tolerant = 0;
12546
12547 #endif
12548
12549
12550     /* CRTL can be initialized past this point, but not before. */
12551 /*    DECC$CRTL_INIT(); */
12552
12553     return SS$_NORMAL;
12554 }
12555
12556 #ifdef __DECC
12557 #pragma nostandard
12558 #pragma extern_model save
12559 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12560         const __align (LONGWORD) int spare[8] = {0};
12561
12562 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
12563 #if __DECC_VER >= 60560002
12564 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
12565 #else
12566 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
12567 #endif
12568 #endif /* __DECC */
12569
12570 const long vms_cc_features = (const long)set_features;
12571
12572 /*
12573 ** Force a reference to LIB$INITIALIZE to ensure it
12574 ** exists in the image.
12575 */
12576 int lib$initialize(void);
12577 #ifdef __DECC
12578 #pragma extern_model strict_refdef
12579 #endif
12580     int lib_init_ref = (int) lib$initialize;
12581
12582 #ifdef __DECC
12583 #pragma extern_model restore
12584 #pragma standard
12585 #endif
12586
12587 /*  End of vms.c */